/[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 - (show annotations)
Thu Sep 22 12:21:32 2005 UTC (8 years, 6 months ago) by ihatchondo
Branch: MAIN
Changes since 1.10: +643 -632 lines
Doc formating and file encoding type updated.
1 ;;; -*- 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