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

Contents of /eclipse/lib/sm/sm.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5