/[eclipse]/eclipse/lib/sm/sm.lisp
ViewVC logotype

Diff of /eclipse/lib/sm/sm.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.10 by ihatchondo, Fri Mar 25 14:43:52 2005 UTC revision 1.11 by ihatchondo, Thu Sep 22 12:21:32 2005 UTC
# Line 1  Line 1 
1  ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SM-LIB; -*-  ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SM-LIB; -*-
2  ;;; $Id$  ;;; $Id$
3  ;;; ---------------------------------------------------------------------------  ;;; ---------------------------------------------------------------------------
4  ;;;     Title: SM Library  ;;;     Title: SM Library
5  ;;;   Created: 2004 01 15 15:28  ;;;   Created: 2004 01 15 15:28
6  ;;;    Author: Iban Hatchondo <hatchond@labri.fr>  ;;;    Author: Iban Hatchondo <hatchond@labri.fr>
7  ;;; ---------------------------------------------------------------------------  ;;; ---------------------------------------------------------------------------
8  ;;;  (c) copyright 2004 by Iban Hatchondo  ;;;  (c) copyright 2004 by Iban Hatchondo
9    
10  ;;;  ;;;
11  ;;; Permission is granted to any individual or institution to use,  ;;; Permission is granted to any individual or institution to use,
12  ;;; copy, modify, and distribute this software, provided that this  ;;; copy, modify, and distribute this software, provided that this
13  ;;; complete copyright and permission notice is maintained, intact, in  ;;; complete copyright and permission notice is maintained, intact, in
14  ;;; all copies and supporting documentation.  ;;; all copies and supporting documentation.
15  ;;;  ;;;
16  ;;; This program is distributed in the hope that it will be useful,  ;;; This program is distributed in the hope that it will be useful,
17  ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of  ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18  ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
19  ;;;  ;;;
20    
21  (in-package :SM-LIB)  (in-package :SM-LIB)
22    
23  ;;;; Constants & vars  ;;;; Constants & vars
24    
25  (defvar *xsmp* nil)  (defvar *xsmp* nil)
26    
27  ;; Protocol version  ;; Protocol version
28    
29  (defconstant +sm-proto-major+ 1)  (defconstant +sm-proto-major+ 1)
30  (defconstant +sm-proto-minor+ 0)  (defconstant +sm-proto-minor+ 0)
31    
32  ;; Protocol release and vendor names  ;; Protocol release and vendor names
33    
34  (defconstant +release-name+ "CL-SM-1.0")  (defconstant +release-name+ "CL-SM-1.0")
35  (defconstant +vendor-name+ "LoopFor & Mapcar corp")  (defconstant +vendor-name+ "LoopFor & Mapcar corp")
36    
37  ;;;; Types.  ;;;; Types.
38    
39  (deftype interact-style () `(member :none :errors :any))  (deftype interact-style () `(member :none :errors :any))
40  (deftype dialog-type () `(member :error :normal))  (deftype dialog-type () `(member :error :normal))
41  (deftype save-type () `(member :global :local :both))  (deftype save-type () `(member :global :local :both))
42  (deftype array8 () `(simple-array card8 (*)))  (deftype array8 () `(simple-array card8 (*)))
43  (deftype client-id () `string)  (deftype client-id () `string)
44    
45  (deftype array8s () 'list)  (deftype array8s () 'list)
46  (deftype strings () 'list)  (deftype strings () 'list)
47  (deftype properties () 'list)  (deftype properties () 'list)
48    
49  (defstruct property  (defstruct property
50    (name nil :type (or null string))    (name nil :type (or null string))
51    (type nil :type (or null string))    (type nil :type (or null string))
52    (values nil :type array8s))    (values nil :type array8s))
53    
54  (defun string->array8 (string)  (defun string->array8 (string)
55    "Transforms a string into an sm-lib:array8."    "Transforms a string into an sm-lib:array8."
56    (declare (type simple-string string))    (declare (type simple-string string))
57    (map 'array8 #'char-code string))    (map 'array8 #'char-code string))
58    
59  (defun array8->string (array)  (defun array8->string (array)
60    "Transforms an sm-lib:array8 into a string."    "Transforms an sm-lib:array8 into a string."
61    (declare (type array8 array))    (declare (type array8 array))
62    (map 'string #'code-char array))    (map 'string #'code-char array))
63    
64  (defun strings->array8s (&rest strings)  (defun strings->array8s (&rest strings)
65    "Transforms the given strings into a list of sm-lib:array8."    "Transforms the given strings into a list of sm-lib:array8."
66    (declare (type list strings))    (declare (type list strings))
67    (mapcar #'string->array8 strings))    (mapcar #'string->array8 strings))
68    
69  (defun array8s->strings (&rest array8s)  (defun array8s->strings (&rest array8s)
70    "Transforms the given sm-lib:array8's into a list of simple-string"    "Transforms the given sm-lib:array8's into a list of simple-string"
71    (declare (type array8s array8s))    (declare (type array8s array8s))
72    (mapcar #'array8->string array8s))    (mapcar #'array8->string array8s))
73    
74  ;; <type>-length functions  ;; <type>-length functions
75    
76  (defun interact-style-length (value)  (defun interact-style-length (value)
77    (declare (ignore value))    (declare (ignore value))
78    (declare (optimize (speed 3) (safety 0)))    (declare (optimize (speed 3) (safety 0)))
79    1)    1)
80    
81  (defun dialog-type-length (value)  (defun dialog-type-length (value)
82    (declare (ignore value))    (declare (ignore value))
83    (declare (optimize (speed 3) (safety 0)))    (declare (optimize (speed 3) (safety 0)))
84    1)    1)
85    
86  (defun save-type-length (value)  (defun save-type-length (value)
87    (declare (ignore value))    (declare (ignore value))
88    (declare (optimize (speed 3) (safety 0)))    (declare (optimize (speed 3) (safety 0)))
89    1)    1)
90    
91  (defun string-length (string)  (defun string-length (string)
92    (declare (type (or null simple-string) string))    (declare (type (or null simple-string) string))
93    (let ((length (+ 4 (if (null string) 0 (length string)))))    (let ((length (+ 4 (if (null string) 0 (length string)))))
94      (+ length (mod (- length) 8))))      (+ length (mod (- length) 8))))
95    
96  (defun array8-length (array)  (defun array8-length (array)
97    (declare (type (or null array8) array))    (declare (type (or null array8) array))
98    (let ((length (+ 4 (if (null array) 0 (length array)))))    (let ((length (+ 4 (if (null array) 0 (length array)))))
99      (+ length (mod (- length) 8))))      (+ length (mod (- length) 8))))
100    
101  (defun client-id-length (client-id)  (defun client-id-length (client-id)
102    (declare (type (or null client-id) client-id))    (declare (type (or null client-id) client-id))
103    (string-length client-id))    (string-length client-id))
104    
105  (defun strings-length (strings)  (defun strings-length (strings)
106    (declare (type strings strings))    (declare (type strings strings))
107    (+ 8 (loop for s in strings sum (string-length s))))    (+ 8 (loop for s in strings sum (string-length s))))
108    
109  (defun array8s-length (arrays)  (defun array8s-length (arrays)
110    (declare (type array8s arrays))    (declare (type array8s arrays))
111    (+ 8 (loop for a in arrays sum (array8-length a))))    (+ 8 (loop for a in arrays sum (array8-length a))))
112    
113  (defun property-length (property)  (defun property-length (property)
114    (declare (type property property))    (declare (type property property))
115    (+ (string-length (property-name property))    (+ (string-length (property-name property))
116       (string-length (property-type property))       (string-length (property-type property))
117       (array8s-length (property-values property))))       (array8s-length (property-values property))))
118    
119  (defun properties-length (properties)  (defun properties-length (properties)
120    (declare (type properties properties))    (declare (type properties properties))
121    (+ 8 (loop for p in properties sum (property-length p))))    (+ 8 (loop for p in properties sum (property-length p))))
122    
123  ;; type constructor  ;; type constructor
124    
125  (defun make-array8 (len &rest args &key (initial-element 0) &allow-other-keys)  (defun make-array8 (len &rest args &key (initial-element 0) &allow-other-keys)
126    "Creates and returns an array constructed of the most specialized type that    "Creates and returns an array constructed of the most specialized type that
127     can accommodate elements of type (unsigned-byte 8). For the rest of the     can accommodate elements of type (unsigned-byte 8). For the rest of the
128     options see common-lisp:make-array."     options see common-lisp:make-array."
129    (declare (type fixnum len))    (declare (type fixnum len))
130    (if (getf args :initial-contents)    (if (getf args :initial-contents)
131        (remf args :initial-element)        (remf args :initial-element)
132        (setf (getf args :initial-element) initial-element))        (setf (getf args :initial-element) initial-element))
133    (apply #'make-array len :element-type 'card8 args))    (apply #'make-array len :element-type 'card8 args))
134    
135  ;; macro accessor  ;; macro accessor
136    
137  (defmacro define-sequence-accessor (type element-type)  (defmacro define-sequence-accessor (type element-type)
138    (let ((read (sintern (format nil "BUFFER-READ-~a" element-type)))    (let ((read (sintern (format nil "BUFFER-READ-~a" element-type)))
139          (write (sintern (format nil "BUFFER-WRITE-~a" element-type))))          (write (sintern (format nil "BUFFER-WRITE-~a" element-type))))
140      `(define-accessor ,type      `(define-accessor ,type
141         ((buffer)         ((buffer)
142          (with-gensym (count buff)          (with-gensym (count buff)
143            `(multiple-value-bind (,buff ,count)            `(multiple-value-bind (,buff ,count)
144                 (values ,buffer (buffer-read-card32 ,buffer))                 (values ,buffer (buffer-read-card32 ,buffer))
145               (declare (type buffer ,buff))               (declare (type buffer ,buff))
146               (index+ ,buff 4)               (index+ ,buff 4)
147               (loop for i from 0 below ,count collect (,',read ,buff)))))               (loop for i from 0 below ,count collect (,',read ,buff)))))
148         ((sequence buffer)         ((sequence buffer)
149          (with-gensym (seq buff)          (with-gensym (seq buff)
150            `(let ((,seq ,sequence) (,buff ,buffer))            `(let ((,seq ,sequence) (,buff ,buffer))
151               (declare (type buffer ,buff))               (declare (type buffer ,buff))
152               (buffer-write-card32 (length ,seq) ,buff)               (buffer-write-card32 (length ,seq) ,buff)
153               (index+ ,buff 4)               (index+ ,buff 4)
154               (loop for e in ,seq do (,',write e ,buff))))))))               (loop for e in ,seq do (,',write e ,buff))))))))
155    
156  ;; <type>-{writer,reader} macros  ;; <type>-{writer,reader} macros
157    
158  (define-member8-accessor interact-style '#(:none :errors :any))  (define-member8-accessor interact-style '#(:none :errors :any))
159    
160  (define-member8-accessor dialog-type '#(:error :normal))  (define-member8-accessor dialog-type '#(:error :normal))
161    
162  (define-member8-accessor save-type '#(:global :local :both))  (define-member8-accessor save-type '#(:global :local :both))
163    
164  (define-accessor array8  (define-accessor array8
165    ((buffer)    ((buffer)
166     (with-gensym (length buff)     (with-gensym (length buff)
167       `(let* ((,buff ,buffer)       `(let* ((,buff ,buffer)
168               (,length (buffer-read-card32 ,buff)))               (,length (buffer-read-card32 ,buff)))
169          (declare (type buffer ,buff))          (declare (type buffer ,buff))
170          (prog1 (buffer-read-data ,buff ,length)          (prog1 (buffer-read-data ,buff ,length)
171            (index+ ,buff (mod (- (+ 4 ,length)) 8))))))            (index+ ,buff (mod (- (+ 4 ,length)) 8))))))
172    ((array buffer)    ((array buffer)
173     (with-gensym (length buff)     (with-gensym (length buff)
174       `(let ((,length (if (null ,array) 0 (length ,array)))       `(let ((,length (if (null ,array) 0 (length ,array)))
175              (,buff ,buffer))              (,buff ,buffer))
176          (declare (type buffer ,buff))          (declare (type buffer ,buff))
177          (buffer-write-card32 ,length ,buff)          (buffer-write-card32 ,length ,buff)
178          (buffer-write-data ,array ,buff)          (buffer-write-data ,array ,buff)
179          (index+ ,buff (mod (- (+ 4 ,length)) 8))))))          (index+ ,buff (mod (- (+ 4 ,length)) 8))))))
180    
181  (define-accessor string  (define-accessor string
182    ((buffer)    ((buffer)
183     `(map 'string #'code-char (buffer-read-array8 ,buffer)))     `(map 'string #'code-char (buffer-read-array8 ,buffer)))
184    ((string buffer)    ((string buffer)
185     `(buffer-write-array8 (map 'array8 #'char-code ,string) ,buffer)))     `(buffer-write-array8 (map 'array8 #'char-code ,string) ,buffer)))
186    
187  (define-sequence-accessor strings string)  (define-sequence-accessor strings string)
188    
189  (define-sequence-accessor array8s array8)  (define-sequence-accessor array8s array8)
190    
191  (define-accessor client-id  (define-accessor client-id
192    ((buffer) `(buffer-read-string ,buffer))    ((buffer) `(buffer-read-string ,buffer))
193    ((id buffer) `(buffer-write-string ,id ,buffer)))    ((id buffer) `(buffer-write-string ,id ,buffer)))
194    
195  (define-accessor property  (define-accessor property
196    ((buffer)    ((buffer)
197     (with-gensym (buff)     (with-gensym (buff)
198       `(let ((,buff ,buffer))       `(let ((,buff ,buffer))
199          (declare (type buffer ,buff))          (declare (type buffer ,buff))
200          (make-property          (make-property
201              :name (buffer-read-string ,buff)              :name (buffer-read-string ,buff)
202              :type (buffer-read-string ,buff)              :type (buffer-read-string ,buff)
203              :values (buffer-read-array8s ,buff)))))              :values (buffer-read-array8s ,buff)))))
204    ((property buffer)    ((property buffer)
205     (with-gensym (prop buff)     (with-gensym (prop buff)
206       `(multiple-value-bind (,prop ,buff) (values ,property ,buffer)       `(multiple-value-bind (,prop ,buff) (values ,property ,buffer)
207          (declare (type buffer ,buff))          (declare (type buffer ,buff))
208          (buffer-write-string (property-name ,prop) ,buff)          (buffer-write-string (property-name ,prop) ,buff)
209          (buffer-write-string (property-type ,prop) ,buff)          (buffer-write-string (property-type ,prop) ,buff)
210          (buffer-write-array8s (property-values ,prop) ,buff)))))          (buffer-write-array8s (property-values ,prop) ,buff)))))
211    
212  (define-sequence-accessor properties property)  (define-sequence-accessor properties property)
213    
214  ;;;; Request declarations.  ;;;; Request declarations.
215    
216  (define-request :register-client 1)  (define-request :register-client 1)
217  (define-request :register-client-reply 2)  (define-request :register-client-reply 2)
218  (define-request :save-yourself 3)  (define-request :save-yourself 3)
219  (define-request :save-yourself-request 4)  (define-request :save-yourself-request 4)
220  (define-request :interact-request 5)  (define-request :interact-request 5)
221  (define-request :interact 6)  (define-request :interact 6)
222  (define-request :interact-done 7)  (define-request :interact-done 7)
223  (define-request :save-yourself-done 8)  (define-request :save-yourself-done 8)
224  (define-request :die 9)  (define-request :die 9)
225  (define-request :shutdown-cancelled 10)  (define-request :shutdown-cancelled 10)
226  (define-request :connection-closed 11)  (define-request :connection-closed 11)
227  (define-request :set-properties 12)  (define-request :set-properties 12)
228  (define-request :delete-properties 13)  (define-request :delete-properties 13)
229  (define-request :get-properties 14)  (define-request :get-properties 14)
230  (define-request :get-properties-reply 15)  (define-request :get-properties-reply 15)
231  (define-request :save-yourself-phase2-request 16)  (define-request :save-yourself-phase2-request 16)
232  (define-request :save-yourself-phase2 17)  (define-request :save-yourself-phase2 17)
233  (define-request :save-complete 18)  (define-request :save-complete 18)
234    
235  (declare-request register-client (request)  (declare-request register-client (request)
236    ((major-opcode :initform *xsmp* :type card8)    ((major-opcode :initform *xsmp* :type card8)
237     (minor-opcode :type card8 :pad-size 2)     (minor-opcode :type card8 :pad-size 2)
238     (length :type card32 :initform 0)     (length :type card32 :initform 0)
239     (previous-id :type client-id))     (previous-id :type client-id))
240    (:documentation "The client must send this message to the SM to register the    (:documentation "The client must send this message to the SM to register the
241    client's existence. If a client is being restarted from a previous session,    client's existence. If a client is being restarted from a previous session,
242    the previous-ID field must contain the client ID string from the previous    the previous-ID field must contain the client ID string from the previous
243    session. For new clients, previous-ID should be NIL or the empty string. If    session. For new clients, previous-ID should be NIL or the empty string. If
244    previous-ID is not valid, the SM will send a BadValue error message to the    previous-ID is not valid, the SM will send a BadValue error message to the
245    client. At this point the SM reverts to the register state and waits for    client. At this point the SM reverts to the register state and waits for
246    another register-client. The client should then send a register-client with    another register-client. The client should then send a register-client with
247    a NIL previous-ID field."))    a NIL previous-ID field."))
248    
249  (declare-request register-client-reply (request)  (declare-request register-client-reply (request)
250    ((major-opcode :initform *xsmp* :type card8)    ((major-opcode :initform *xsmp* :type card8)
251     (minor-opcode :type card8 :pad-size 2)     (minor-opcode :type card8 :pad-size 2)
252     (length :type card32 :initform 0)     (length :type card32 :initform 0)
253     (client-id :type client-id))     (client-id :type client-id))
254    (:documentation "The client-id specifies a unique identification string for    (:documentation "The client-id specifies a unique identification string for
255    this client. If the client had specified an id in the previous-ID field of    this client. If the client had specified an id in the previous-ID field of
256    the register-client message, client-ID will be identical to the previously    the register-client message, client-ID will be identical to the previously
257    specified id.    specified id.
258     If previous-id was NIL, client-id will be a unique id freshly generated by  
259    the SM. The client-id format is specified in section 6 of xsmp specification.     If previous-id was NIL, client-id will be a unique id freshly generated by
260     If the client didn't supply a previous-id field to the register-client    the SM. The client-id format is specified in section 6 of xsmp specification.
261    message, the SM must send a save-yourself message with  
262    type = :local, shutdown-p = NIL, interact-style = :none, and fast-p = NIL     If the client didn't supply a previous-id field to the register-client
263    immediately after the register-client-reply. The client should respond to    message, the SM must send a save-yourself message with
264    this like any other save-yourself message."))    type = :local, shutdown-p = NIL, interact-style = :none, and fast-p = NIL
265      immediately after the register-client-reply. The client should respond to
266  (declare-request save-yourself (request)    this like any other save-yourself message."))
267    ((major-opcode :initform *xsmp* :type card8)  
268     (minor-opcode :type card8 :pad-size 2)  (declare-request save-yourself (request)
269     (length :type card32 :initform 0)    ((major-opcode :initform *xsmp* :type card8)
270     (type :type save-type)     (minor-opcode :type card8 :pad-size 2)
271     (shutdown-p :type boolean)     (length :type card32 :initform 0)
272     (interact-style :type interact-style)     (type :type save-type)
273     (fast-p :type boolean :pad-size 4))     (shutdown-p :type boolean)
274    (:documentation "The SM sends this message to a client to ask it to save its     (interact-style :type interact-style)
275    state. The client writes a state file, if necessary, and, if necessary, uses     (fast-p :type boolean :pad-size 4))
276    set-properties to inform the SM of how to restart it and how to discard the    (:documentation "The SM sends this message to a client to ask it to save its
277    saved state. During this process it can, if allowed by interact-style,    state. The client writes a state file, if necessary, and, if necessary, uses
278    request permission to interact with the user by sending an interact-request    set-properties to inform the SM of how to restart it and how to discard the
279    message. After the state has been saved, or if it cannot be successfully    saved state. During this process it can, if allowed by interact-style,
280    saved, and the properties are appropriately set, the client sends a    request permission to interact with the user by sending an interact-request
281    save-yourself-done message.    message. After the state has been saved, or if it cannot be successfully
282     If the client wants to save additional information after all the other    saved, and the properties are appropriately set, the client sends a
283    clients have finished changing their own state, the client should send    save-yourself-done message.
284    save-yourself-phase2-request instead of SaveYourselfDone. The client must  
285    then freeze interaction with the user and wait until it receives a     If the client wants to save additional information after all the other
286    save-complete, die, or a shutdown-cancelled message.    clients have finished changing their own state, the client should send
287     If interact-style is :none, the client must not interact with the user while    save-yourself-phase2-request instead of SaveYourselfDone. The client must
288    saving state. If the interact-style is :errors, the client may interact with    then freeze interaction with the user and wait until it receives a
289    the user only if an error condition arises.    save-complete, die, or a shutdown-cancelled message.
290     If interact-style is :any, then the client may interact with the user for  
291    any purpose. This is done by sending an interact-request message. The SM will     If interact-style is :none, the client must not interact with the user while
292    send an Interact message to each client that sent an interact-request.    saving state. If the interact-style is :errors, the client may interact with
293      the user only if an error condition arises.
294    When a client receives save-yourself and has not yet responded  
295    save-yourself-done to a previous save-yourself, it must send a     If interact-style is :any, then the client may interact with the user for
296    save-yourself-done and may then begin responding as appropriate    any purpose. This is done by sending an interact-request message. The SM will
297    to the newly received save-yourself.    send an Interact message to each client that sent an interact-request.
298    
299     The type slot specifies the type of information that should be saved:     When a client receives save-yourself and has not yet responded
300      :local  indicates that the application must update the properties to    save-yourself-done to a previous save-yourself, it must send a
301              reflect its current state, send a save-yourself-done and continue.    save-yourself-done and may then begin responding as appropriate
302              Specifically it should save enough information to restore the state    to the newly received save-yourself.
303              as seen by the user of this client. It should not affect the state  
304              as seen by other users.      The type slot specifies the type of information that should be saved:
305      :global indicates that the user wants the client to commit all of its data     - :local  indicates that the application must update the properties to
306              to permanent, globally-accessible storage.               reflect its current state, send a save-yourself-done and continue.
307      :both   indicates that the client should do both of these. In this case,               Specifically it should save enough information to restore the
308              the client should first commit the data to permanent storage before               state as seen by the user of this client. It should not affect
309              updating its SM properties.               the state as seen by other users.
310       - :global indicates that the user wants the client to commit all of its
311     The shutdown-p slot specifies whether the system is being shut down.               data to permanent, globally-accessible storage.
312       - :both   indicates that the client should do both of these. In this case,
313     The fast slot specifies whether or not the client should save its state as               the client should first commit the data to permanent storage
314    quickly as possible. For example, if the SM knows that power is about to               before updating its SM properties.
315    fail, it should set the fast field to True."))  
316       The shutdown-p slot specifies whether the system is being shut down.
317  (declare-request save-yourself-request (request)  
318    ((major-opcode :initform *xsmp* :type card8)     The fast slot specifies whether or not the client should save its state as
319     (minor-opcode :type card8 :pad-size 2)    quickly as possible. For example, if the SM knows that power is about to
320     (length :type card32 :initform 0)    fail, it should set the fast field to True."))
321     (type :type save-type)  
322     (shutdown-p :type boolean)  (declare-request save-yourself-request (request)
323     (interact-style :type interact-style)    ((major-opcode :initform *xsmp* :type card8)
324     (fast-p :type boolean)     (minor-opcode :type card8 :pad-size 2)
325     (global-p :type boolean :pad-size 3))     (length :type card32 :initform 0)
326    (:documentation "An application sends this to the SM to request a checkpoint.     (type :type save-type)
327    When the SM receives this request it may generate a save-yourself message in     (shutdown-p :type boolean)
328    response and it may leave the slots intact.     (interact-style :type interact-style)
329     If global-p is set True, then the resulting save-yourself should be sent to     (fast-p :type boolean)
330    all applications.     (global-p :type boolean :pad-size 3))
331     If global-p is NIL, then the resulting save-yourself should be sent to the    (:documentation "An application sends this to the SM to request a checkpoint.
332    application that sent the save-yourself-request."))    When the SM receives this request it may generate a save-yourself message in
333      response and it may leave the slots intact.
334  (declare-request interact-request (request)  
335    ((major-opcode :initform *xsmp* :type card8)     If global-p is set True, then the resulting save-yourself should be sent to
336     (minor-opcode :type card8)    all applications.
337     (dialog-type :type dialog-type :pad-size 1)  
338     (length :type card32 :initform 0))     If global-p is NIL, then the resulting save-yourself should be sent to the
339    (:documentation "During a checkpoint or session-save operation, only one    application that sent the save-yourself-request."))
340    client at a time might be granted the privilege of interacting with the user.  
341    The interact-request message causes the SM to emit an Interact message at  (declare-request interact-request (request)
342    some later time if the shutdown is not cancelled by another client first.    ((major-opcode :initform *xsmp* :type card8)
343     The dialog-type slot is one of :error :normal, indicating that the client     (minor-opcode :type card8)
344    wants to start an error dialog or normal, meaning the client wishes to start     (dialog-type :type dialog-type :pad-size 1)
345    a non-error dialog."))     (length :type card32 :initform 0))
346      (:documentation "During a checkpoint or session-save operation, only one
347  (declare-request interact (request)    client at a time might be granted the privilege of interacting with the user.
348    ((major-opcode :initform *xsmp* :type card8)    The interact-request message causes the SM to emit an Interact message at
349     (minor-opcode :type card8 :pad-size 2)    some later time if the shutdown is not cancelled by another client first.
350     (length :type card32 :initform 0))  
351    (:documentation "This message grants the client the privilege of interacting     The dialog-type slot is one of :error :normal, indicating that the client
352    with the user. When the client is done interacting with the user it must send    wants to start an error dialog or normal, meaning the client wishes to start
353    an interact-done message to the SM unless a shutdown cancel is received."))    a non-error dialog."))
354    
355  (declare-request interact-done (request)  (declare-request interact (request)
356    ((major-opcode :initform *xsmp* :type card8)    ((major-opcode :initform *xsmp* :type card8)
357     (minor-opcode :type card8)     (minor-opcode :type card8 :pad-size 2)
358     (cancel-shutdown-p :type boolean :pad-size 1)     (length :type card32 :initform 0))
359     (length :type card32 :initform 0))    (:documentation "This message grants the client the privilege of interacting
360    (:documentation "This message is used by a client to notify the SM that it is    with the user. When the client is done interacting with the user it must send
361    done interacting. Setting the cancel-shutdown-p to True indicates that the    an interact-done message to the SM unless a shutdown cancel is received."))
362    user has requested that the entire shutdown be cancelled. cancel-shutdown-p  
363    may only be True if the corresponding save-yourself message specified True in  (declare-request interact-done (request)
364    the shutdown-p slot and :any or :errors in the interact-style slot.    ((major-opcode :initform *xsmp* :type card8)
365    Otherwise, cancel-shutdown-p must be NIL."))     (minor-opcode :type card8)
366       (cancel-shutdown-p :type boolean :pad-size 1)
367  (declare-request save-yourself-done (request)     (length :type card32 :initform 0))
368    ((major-opcode :initform *xsmp* :type card8)    (:documentation "This message is used by a client to notify the SM that it is
369     (minor-opcode :type card8)    done interacting. Setting the cancel-shutdown-p to True indicates that the
370     (success-p :type boolean :pad-size 1)    user has requested that the entire shutdown be cancelled. cancel-shutdown-p
371     (length :type card32 :initform 0))    may only be True if the corresponding save-yourself message specified True in
372    (:documentation "This message is sent by a client to indicate that all of the    the shutdown-p slot and :any or :errors in the interact-style slot.
373    properties representing its state have been updated. After sending    Otherwise, cancel-shutdown-p must be NIL."))
374    save-yourself-done the client must wait for a save-complete,  
375    shutdown-cancelled, or die message before changing its state. If the  (declare-request save-yourself-done (request)
376    save-yourself operation was successful, then the client should set the    ((major-opcode :initform *xsmp* :type card8)
377    success-p slot to T; otherwise the client should set it to NIL."))     (minor-opcode :type card8)
378       (success-p :type boolean :pad-size 1)
379  (declare-request die (request)     (length :type card32 :initform 0))
380    ((major-opcode :initform *xsmp* :type card8)    (:documentation "This message is sent by a client to indicate that all of the
381     (minor-opcode :type card8 :pad-size 2)    properties representing its state have been updated. After sending
382     (length :type card32 :initform 0))    save-yourself-done the client must wait for a save-complete,
383    (:documentation "When the SM wants a client to die it sends a Die message.    shutdown-cancelled, or die message before changing its state. If the
384    Before the client dies it responds by sending a connection-closed message    save-yourself operation was successful, then the client should set the
385    and may then close its connection to the SM at any time."))    success-p slot to T; otherwise the client should set it to NIL."))
386    
387  (declare-request shutdown-cancelled (request)  (declare-request die (request)
388    ((major-opcode :initform *xsmp* :type card8)    ((major-opcode :initform *xsmp* :type card8)
389     (minor-opcode :type card8 :pad-size 2)     (minor-opcode :type card8 :pad-size 2)
390     (length :type card32 :initform 0))     (length :type card32 :initform 0))
391    (:documentation "The shutdown currently in process has been aborted. The    (:documentation "When the SM wants a client to die it sends a Die message.
392    client can now continue as if the shutdown had never happened. If the client    Before the client dies it responds by sending a connection-closed message
393    has not sent save-yourself-done yet, the client can either abort the save and    and may then close its connection to the SM at any time."))
394    send save-yourself-Done with the success-p slot set to Nil, or it can  
395    continue with the save and send a SaveYourselfDone with the success-p slot  (declare-request shutdown-cancelled (request)
396    set to reflect the outcome of the save."))    ((major-opcode :initform *xsmp* :type card8)
397       (minor-opcode :type card8 :pad-size 2)
398  (declare-request connection-closed (request)     (length :type card32 :initform 0))
399    ((major-opcode :initform *xsmp* :type card8)    (:documentation "The shutdown currently in process has been aborted. The
400     (minor-opcode :type card8 :pad-size 2)    client can now continue as if the shutdown had never happened. If the client
401     (length :type card32 :initform 0)    has not sent save-yourself-done yet, the client can either abort the save and
402     (reason :type strings))    send save-yourself-Done with the success-p slot set to Nil, or it can
403    (:documentation "Specifies that the client has decided to terminate. It    continue with the save and send a SaveYourselfDone with the success-p slot
404    should be immediately followed by closing the connection.    set to reflect the outcome of the save."))
405     The reason slot specifies why the client is resigning from the session. It  
406    is encoded as alist of simple strings. If the resignation is expected by the  (declare-request connection-closed (request)
407    user, there will typically be a NIL or a null string here. But if the client    ((major-opcode :initform *xsmp* :type card8)
408    encountered an unexpected fatal error, the error message (which might     (minor-opcode :type card8 :pad-size 2)
409    otherwise be printed on *standard-error*) should be forwarded to the SM here,     (length :type card32 :initform 0)
410    one string per line of the message. It is the responsibility of the SM to     (reason :type strings))
411    display this reason to the user.    (:documentation "Specifies that the client has decided to terminate. It
412     After sending this message, the client must not send any additional XSMP    should be immediately followed by closing the connection.
413    messages to the SM."))  
414       The reason slot specifies why the client is resigning from the session. It
415  (declare-request set-properties (request)    is encoded as alist of simple strings. If the resignation is expected by the
416    ((major-opcode :initform *xsmp* :type card8)    user, there will typically be a NIL or a null string here. But if the client
417     (minor-opcode :type card8 :pad-size 2)    encountered an unexpected fatal error, the error message (which might
418     (length :type card32 :initform 0)    otherwise be printed on *standard-error*) should be forwarded to the SM here,
419     (properties :type properties))    one string per line of the message. It is the responsibility of the SM to
420    (:documentation "Sets the specified properties to the specified values.    display this reason to the user.
421    Existing properties not specified in the SetProperties message are  
422    unaffected. Some properties have predefined semantics. See section 11,     After sending this message, the client must not send any additional XSMP
423    ``Predefined Properties.'' The protocol specification recommends that    messages to the SM."))
424    property names used for properties not defined by the standard should begin  
425    with an underscore. To prevent conflicts among organizations, additional  (declare-request set-properties (request)
426    prefixes should be chosen. The organizational prefixes should be registered    ((major-opcode :initform *xsmp* :type card8)
427    with the X Registry. The XSMP reserves all property names not beginning with     (minor-opcode :type card8 :pad-size 2)
428    an underscore for future use."))     (length :type card32 :initform 0)
429       (properties :type properties))
430  (declare-request delete-properties (request)    (:documentation "Sets the specified properties to the specified values.
431    ((major-opcode :initform *xsmp* :type card8)    Existing properties not specified in the SetProperties message are
432     (minor-opcode :type card8 :pad-size 2)    unaffected. Some properties have predefined semantics. See section 11,
433     (length :type card32 :initform 0)    ``Predefined Properties.'' The protocol specification recommends that
434     (properties :type strings))    property names used for properties not defined by the standard should begin
435    (:documentation "Removes the named properties."))    with an underscore. To prevent conflicts among organizations, additional
436      prefixes should be chosen. The organizational prefixes should be registered
437  (declare-request get-properties (request)    with the X Registry. The XSMP reserves all property names not beginning with
438    ((major-opcode :initform *xsmp* :type card8)    an underscore for future use."))
439     (minor-opcode :type card8 :pad-size 2)  
440     (length :type card32 :initform 0))  (declare-request delete-properties (request)
441    (:documentation "Requests that the SM respond with the values of all the    ((major-opcode :initform *xsmp* :type card8)
442    properties for this client."))     (minor-opcode :type card8 :pad-size 2)
443       (length :type card32 :initform 0)
444  (declare-request get-properties-reply (request)     (properties :type strings))
445    ((major-opcode :initform *xsmp* :type card8)    (:documentation "Removes the named properties."))
446     (minor-opcode :type card8 :pad-size 2)  
447     (length :type card32 :initform 0)  (declare-request get-properties (request)
448     (properties :type properties))    ((major-opcode :initform *xsmp* :type card8)
449    (:documentation "This message is sent in reply to a get-properties message     (minor-opcode :type card8 :pad-size 2)
450    and includes the values of all the properties."))     (length :type card32 :initform 0))
451      (:documentation "Requests that the SM respond with the values of all the
452  (declare-request save-yourself-phase2-request (request)    properties for this client."))
453    ((major-opcode :initform *xsmp* :type card8)  
454     (minor-opcode :type card8 :pad-size 2)  (declare-request get-properties-reply (request)
455     (length :type card32 :initform 0))    ((major-opcode :initform *xsmp* :type card8)
456    (:documentation "This message is sent by a client to indicate that it needs     (minor-opcode :type card8 :pad-size 2)
457    to be informed when all the other clients are quiescent, so it can continue     (length :type card32 :initform 0)
458    its state."))     (properties :type properties))
459      (:documentation "This message is sent in reply to a get-properties message
460  (declare-request save-yourself-phase2 (request)    and includes the values of all the properties."))
461    ((major-opcode :initform *xsmp* :type card8)  
462     (minor-opcode :type card8 :pad-size 2)  (declare-request save-yourself-phase2-request (request)
463     (length :type card32 :initform 0))    ((major-opcode :initform *xsmp* :type card8)
464    (:documentation "The SM sends this message to a client that has previously     (minor-opcode :type card8 :pad-size 2)
465    sent a save-yourself-phase2-request message. This message informs the client     (length :type card32 :initform 0))
466    that all other clients are in a fixed state and this client can save state    (:documentation "This message is sent by a client to indicate that it needs
467    that is associated with other clients.    to be informed when all the other clients are quiescent, so it can continue
468     The client writes a state file, if necessary, and, if necessary, uses    its state."))
469    set-properties to inform the SM of how to restart it and how to discard the  
470    saved state. During this process it can request permission to interact with  (declare-request save-yourself-phase2 (request)
471    the user by sending an interact-request message. This should only be done if    ((major-opcode :initform *xsmp* :type card8)
472    an error occurs that requires user interaction to resolve. After the state     (minor-opcode :type card8 :pad-size 2)
473    has been saved, or if it cannot be successfully saved, and the properties     (length :type card32 :initform 0))
474    are appropriately set, the client sends a save-yourself-done message."))    (:documentation "The SM sends this message to a client that has previously
475      sent a save-yourself-phase2-request message. This message informs the client
476  (declare-request save-complete (request)    that all other clients are in a fixed state and this client can save state
477    ((major-opcode :initform *xsmp* :type card8)    that is associated with other clients.
478     (minor-opcode :type card8 :pad-size 2)  
479     (length :type card32 :initform 0))     The client writes a state file, if necessary, and, if necessary, uses
480    (:documentation "When the SM is done with a checkpoint, it will send each    set-properties to inform the SM of how to restart it and how to discard the
481    of the clients a save-complete message. The client is then free to change    saved state. During this process it can request permission to interact with
482    its state."))    the user by sending an interact-request message. This should only be done if
483      an error occurs that requires user interaction to resolve. After the state
484  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;    has been saved, or if it cannot be successfully saved, and the properties
485  ;;;;                                                                       ;;;;    are appropriately set, the client sends a save-yourself-done message."))
486  ;;;;                               SM Library                              ;;;;  
487  ;;;;                                                                       ;;;;  (declare-request save-complete (request)
488  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;    ((major-opcode :initform *xsmp* :type card8)
489       (minor-opcode :type card8 :pad-size 2)
490  (defclass sm-connection (ice-connection)     (length :type card32 :initform 0))
491    ((client-id    (:documentation "When the SM is done with a checkpoint, it will send each
492       :initarg :client-id :type client-id    of the clients a save-complete message. The client is then free to change
493       :accessor sm-client-id)    its state."))
494     (sm-release  
495       :initarg :sm-release :type string  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
496       :accessor sm-release)  ;;;;                                                                       ;;;;
497     (sm-vendor  ;;;;                               SM Library                              ;;;;
498       :initarg :sm-vendor :type string  ;;;;                                                                       ;;;;
499       :accessor sm-vendor)  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
500     (sm-protocol-version  
501       :initarg :sm-protocol-version :type card16  (defclass sm-connection (ice-connection)
502       :accessor sm-protocol-version)    ((client-id
503     (sm-protocol-revision       :initarg :client-id :type client-id
504       :initarg :sm-protocol-revision :type card16       :accessor sm-client-id)
505       :accessor sm-protocol-revision)))     (sm-release
506         :initarg :sm-release :type string
507  (defun register-xsmp-protocol (opcode)       :accessor sm-release)
508    (register-protocol opcode     (sm-vendor
509      '#(:request-error :register-client :register-client-reply :save-yourself       :initarg :sm-vendor :type string
510         :save-yourself-request :interact-request :interact :interact-done       :accessor sm-vendor)
511         :save-yourself-done :die :shutdown-cancelled :connection-closed     (sm-protocol-version
512         :set-properties :delete-properties :get-properties :get-properties-reply       :initarg :sm-protocol-version :type card16
513         :save-yourself-phase2-request :save-yourself-phase2 :save-complete)))       :accessor sm-protocol-version)
514       (sm-protocol-revision
515  (define-condition session-manager-unavailable (error)       :initarg :sm-protocol-revision :type card16
516    ((reason       :accessor sm-protocol-revision)))
517       :initarg :reason :type string  
518       :reader session-manager-unavailable-reason))  (defun register-xsmp-protocol (opcode)
519    (:report (lambda (condition stream)    (register-protocol opcode
520               (format stream      '#(:request-error :register-client :register-client-reply :save-yourself
521                       "SM-lib: Unable to connect to session manager: ~a~%"         :save-yourself-request :interact-request :interact :interact-done
522                       (session-manager-unavailable-reason condition)))))         :save-yourself-done :die :shutdown-cancelled :connection-closed
523           :set-properties :delete-properties :get-properties :get-properties-reply
524  (defmacro signal-sm-error (string &rest args)         :save-yourself-phase2-request :save-yourself-phase2 :save-complete)))
525    `(error 'session-manager-unavailable :reason (format nil ,string ,@args)))  
526    (define-condition session-manager-unavailable (error)
527  (defun open-sm-connection (&key must-authenticate-p previous-id network-ids)    ((reason
528    "Returns an sm-connection object if it succeeds. Otherwise an error will be       :initarg :reason :type string
529     signaled. (its type will depend on the reason of the failure)       :reader session-manager-unavailable-reason))
530      (:report (lambda (condition stream)
531     - :network-ids : if given, must be a list of network-id for the session               (format stream
532     manager. If not given, the value of the SESSION_MANAGER environment variable                       "SM-lib: Unable to connect to session manager: ~a~%"
533     will be used. An attempt will be made to use the first network-id. If this                       (session-manager-unavailable-reason condition)))))
534     fails an attempt will be made to use the second one, and so on. Each  
535     network-id has the following format:  (defmacro signal-sm-error (string &rest args)
536       local/<HOST-NAME>:<PATH>    `(error 'session-manager-unavailable :reason (format nil ,string ,@args)))
537       tcp/<HOST-NAME>:<PORT-NUMBER>  
538       decnet/<HOST-NAME>::<OBJ>  (defun open-sm-connection (&key must-authenticate-p previous-id network-ids)
539      "Returns an sm-connection object if it succeeds. Otherwise an error will be
540     - :previous-id : if the client is restarted from a previous session, should     signaled. (its type will depend on the reason of the failure)
541     contain the previous client-id of that previous session. If :previous-id is  
542     specified, but is determined to be invalid by the session manager, we will      :network-ids : if given, must be a list of network-id for the session
543     re-register the client with a previous-id set to NIL. If the client is first     manager. If not given, the value of the SESSION_MANAGER environment variable
544     joining the session :previous-id can be NIL (default) or the empty string.     will be used. An attempt will be made to use the first network-id. If this
545       fails an attempt will be made to use the second one, and so on. Each
546     Any authentication requirements are handled internally by the SM Library.     network-id has the following format:
547     The method by which authentication data is obtained is implementation      - local/<HOST-NAME>:<PATH>
548     dependent. We only use and know the default use of the ICEauthority file.      - tcp/<HOST-NAME>:<PORT-NUMBER>
549     You will need to register your own methods for other authentication methods.      - decnet/<HOST-NAME>::<OBJ>
550     To do so see and use register-ice-authentication-protocol."  
551    (declare (type (or null list) network-ids))      :previous-id : if the client is restarted from a previous session, should
552    (declare (type (or null client-id) previous-id))     contain the previous client-id of that previous session. If :previous-id is
553    (declare (type boolean must-authenticate-p))     specified, but is determined to be invalid by the session manager, we will
554    (unless network-ids     re-register the client with a previous-id set to NIL. If the client is first
555      (setf network-ids (list (get-environment-variable)))     joining the session :previous-id can be NIL (default) or the empty string.
556      (when (null (car network-ids))  
557        (signal-sm-error "SESSION_MANAGER environment variable is undefined.")))     Any authentication requirements are handled internally by the SM Library.
558    (let ((sm-conn (make-instance 'sm-connection)))     The method by which authentication data is obtained is implementation
559      (open-connection     dependent. We only use and know the default use of the ICEauthority file.
560       network-ids :connection sm-conn :must-authenticate-p must-authenticate-p)     You will need to register your own methods for other authentication methods.
561      ;; Send protocol-setup request and wait for protocol-reply,then     To do so see and use register-ice-authentication-protocol."
562      ;; send register-client and wait for register-client-reply.    (declare (type (or null list) network-ids))
563      ;; Authentication will take place behind the scene.    (declare (type (or null client-id) previous-id))
564      (let ((protocols    (declare (type boolean must-authenticate-p))
565             (available-authentication-protocols    (unless network-ids
566              "XSMP" (ice-connection-string sm-conn) (ice-auth-proto-names)))      (setf network-ids (list (get-environment-variable)))
567            (versions (make-default-versions      (when (null (car network-ids))
568                          :major +sm-proto-major+ :minor +sm-proto-minor+)))        (signal-sm-error "SESSION_MANAGER environment variable is undefined.")))
569        (declare (type (simple-array string (*)) protocols))    (let ((sm-conn (make-instance 'sm-connection)))
570        (declare (type versions versions))      (open-connection
571        (post-request :protocol-setup sm-conn       network-ids :connection sm-conn :must-authenticate-p must-authenticate-p)
572          :protocol-name "XSMP"      ;; Send protocol-setup request and wait for protocol-reply,then
573          :protocol-major-opcode +sm-proto-major+      ;; send register-client and wait for register-client-reply.
574          :number-of-versions-offered (length versions)      ;; Authentication will take place behind the scene.
575          :must-authenticate-p must-authenticate-p      (let ((protocols
576          :vendor-name +vendor-name+             (available-authentication-protocols
577          :release-name +release-name+              "XSMP" (ice-connection-string sm-conn) (ice-auth-proto-names)))
578          :authentication-protocol-names protocols            (versions (make-default-versions
579          :version-list versions                          :major +sm-proto-major+ :minor +sm-proto-minor+)))
580          :number-of-authentication-protocol-names-offered (length protocols))        (declare (type (simple-array string (*)) protocols))
581        (with-error-handler (sm-conn #'(lambda (x) x))        (declare (type versions versions))
582          (request-case (sm-conn :timeout nil :place request :ice-flush-p nil)        (post-request :protocol-setup sm-conn
583            (authentication-required ((index authentication-protocol-index))          :protocol-name "XSMP"
584              (let ((handler (get-protocol-handler (aref protocols index))))          :protocol-major-opcode +sm-proto-major+
585                (declare (type function handler))          :number-of-versions-offered (length versions)
586                (funcall handler sm-conn request))          :must-authenticate-p must-authenticate-p
587              (values))          :vendor-name +vendor-name+
588            (protocol-reply (protocol-major-opcode vendor-name release-name)          :release-name +release-name+
589              ;; internally register the protocol.          :authentication-protocol-names protocols
590              (setf *xsmp* protocol-major-opcode)          :version-list versions
591              (register-xsmp-protocol protocol-major-opcode)          :number-of-authentication-protocol-names-offered (length protocols))
592              ;; send the register-client request.        (with-error-handler (sm-conn #'(lambda (x) x))
593              (post-request :register-client sm-conn          (request-case (sm-conn :timeout nil :place request :ice-flush-p nil)
594                :previous-id (or previous-id ""))            (authentication-required ((index authentication-protocol-index))
595              ;; collect some connection infos.              (let ((handler (get-protocol-handler (aref protocols index))))
596              (with-slots (version-index) request                (declare (type function handler))
597                (let ((version (aref versions version-index)))                (funcall handler sm-conn request))
598                  (declare (type version version))              (values))
599                  (setf (sm-protocol-version sm-conn) (aref version 0))            (protocol-reply (protocol-major-opcode vendor-name release-name)
600                  (setf (sm-protocol-revision sm-conn) (aref version 1))))              ;; internally register the protocol.
601              (setf (sm-release sm-conn) release-name)              (setf *xsmp* protocol-major-opcode)
602              (setf (sm-vendor sm-conn) vendor-name)              (register-xsmp-protocol protocol-major-opcode)
603              (values))              ;; send the register-client request.
604            (register-client-reply (client-id)              (post-request :register-client sm-conn
605              (setf (sm-client-id sm-conn) client-id))                :previous-id (or previous-id ""))
606            (request-error ((omo offending-minor-opcode) (mo major-opcode))              ;; collect some connection infos.
607              (let ((offender (decode-ice-minor-opcode omo mo)))              (with-slots (version-index) request
608                (if (and (bad-value-p request) (eq offender :register-client))                (let ((version (aref versions version-index)))
609                    ;; Could not register the client because the previous ID                  (declare (type version version))
610                    ;; was bad. So now we register the client with the                  (setf (sm-protocol-version sm-conn) (aref version 0))
611                    ;; previous ID set to empy string.                  (setf (sm-protocol-revision sm-conn) (aref version 1))))
612                    (post-request :register-client sm-conn :previous-id "")              (setf (sm-release sm-conn) release-name)
613                    ;; signal an error.              (setf (sm-vendor sm-conn) vendor-name)
614                    (request-error-handler request)))              (values))
615              (values))            (register-client-reply (client-id)
616            ;; bad state signal an error.              (setf (sm-client-id sm-conn) client-id))
617            (t (signal-sm-error "bad state during protocol setup: ~a." request))))            (request-error ((omo offending-minor-opcode) (mo major-opcode))
618        sm-conn)))              (let ((offender (decode-ice-minor-opcode omo mo)))
619                  (if (and (bad-value-p request) (eq offender :register-client))
620  (defun close-sm-connection (sm-conn &key reason)                    ;; Could not register the client because the previous ID
621    "Closes a connection with a session manager."                    ;; was bad. So now we register the client with the
622    (declare (type sm-connection sm-conn))                    ;; previous ID set to empy string.
623    (declare (type (or null string) reason))                    (post-request :register-client sm-conn :previous-id "")
624    (ice-lib:post-request :want-to-close sm-conn)                    ;; signal an error.
625    (ice-lib:post-request :connection-closed sm-conn :reason reason)                    (request-error-handler request)))
626    (ice-flush sm-conn)              (values))
627    (setf (sm-release sm-conn) nil)            ;; bad state signal an error.
628    (setf (sm-vendor sm-conn) nil)            (t (signal-sm-error "bad state during protocol setup: ~a." request))))
629    (setf (ice-release sm-conn) nil)        sm-conn)))
630    (setf (ice-vendor sm-conn) nil)  
631    (setf (ice-connection-string sm-conn) nil)  (defun close-sm-connection (sm-conn &key reason)
632    (close (ice-lib:connection-stream sm-conn)))    "Closes a connection with a session manager."
633      (declare (type sm-connection sm-conn))
634      (declare (type (or null string) reason))
635      (ice-lib:post-request :want-to-close sm-conn)
636      (ice-lib:post-request :connection-closed sm-conn :reason reason)
637      (ice-flush sm-conn)
638      (setf (sm-release sm-conn) nil)
639      (setf (sm-vendor sm-conn) nil)
640      (setf (ice-release sm-conn) nil)
641      (setf (ice-vendor sm-conn) nil)
642      (setf (ice-connection-string sm-conn) nil)
643      (close (ice-lib:connection-stream sm-conn)))

Legend:
Removed from v.1.10  
changed lines
  Added in v.1.11

  ViewVC Help
Powered by ViewVC 1.1.5