/[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.10 - (show annotations)
Fri Mar 25 14:43:52 2005 UTC (9 years ago) by ihatchondo
Branch: MAIN
Changes since 1.9: +59 -40 lines
Fix on wrong pad indication in xsmp impl.
Cosmetic changes for the rest.
1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SM-LIB; -*-
2 ;;; $Id: sm.lisp,v 1.10 2005/03/25 14:43:52 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 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.
260 If the client didn't supply a previous-id field to the register-client
261 message, the SM must send a save-yourself message with
262 type = :local, shutdown-p = NIL, interact-style = :none, and fast-p = NIL
263 immediately after the register-client-reply. The client should respond to
264 this like any other save-yourself message."))
265
266 (declare-request save-yourself (request)
267 ((major-opcode :initform *xsmp* :type card8)
268 (minor-opcode :type card8 :pad-size 2)
269 (length :type card32 :initform 0)
270 (type :type save-type)
271 (shutdown-p :type boolean)
272 (interact-style :type interact-style)
273 (fast-p :type boolean :pad-size 4))
274 (:documentation "The SM sends this message to a client to ask it to save its
275 state. The client writes a state file, if necessary, and, if necessary, uses
276 set-properties to inform the SM of how to restart it and how to discard the
277 saved state. During this process it can, if allowed by interact-style,
278 request permission to interact with the user by sending an interact-request
279 message. After the state has been saved, or if it cannot be successfully
280 saved, and the properties are appropriately set, the client sends a
281 save-yourself-done message.
282 If the client wants to save additional information after all the other
283 clients have finished changing their own state, the client should send
284 save-yourself-phase2-request instead of SaveYourselfDone. The client must
285 then freeze interaction with the user and wait until it receives a
286 save-complete, die, or a shutdown-cancelled message.
287 If interact-style is :none, the client must not interact with the user while
288 saving state. If the interact-style is :errors, the client may interact with
289 the user only if an error condition arises.
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
292 send an Interact message to each client that sent an interact-request.
293
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
296 save-yourself-done and may then begin responding as appropriate
297 to the newly received save-yourself.
298
299 The type slot specifies the type of information that should be saved:
300 :local indicates that the application must update the properties to
301 reflect its current state, send a save-yourself-done and continue.
302 Specifically it should save enough information to restore the state
303 as seen by the user of this client. It should not affect the state
304 as seen by other users.
305 :global indicates that the user wants the client to commit all of its data
306 to permanent, globally-accessible storage.
307 :both indicates that the client should do both of these. In this case,
308 the client should first commit the data to permanent storage before
309 updating its SM properties.
310
311 The shutdown-p slot specifies whether the system is being shut down.
312
313 The fast slot specifies whether or not the client should save its state as
314 quickly as possible. For example, if the SM knows that power is about to
315 fail, it should set the fast field to True."))
316
317 (declare-request save-yourself-request (request)
318 ((major-opcode :initform *xsmp* :type card8)
319 (minor-opcode :type card8 :pad-size 2)
320 (length :type card32 :initform 0)
321 (type :type save-type)
322 (shutdown-p :type boolean)
323 (interact-style :type interact-style)
324 (fast-p :type boolean)
325 (global-p :type boolean :pad-size 3))
326 (:documentation "An application sends this to the SM to request a checkpoint.
327 When the SM receives this request it may generate a save-yourself message in
328 response and it may leave the slots intact.
329 If global-p is set True, then the resulting save-yourself should be sent to
330 all applications.
331 If global-p is NIL, then the resulting save-yourself should be sent to the
332 application that sent the save-yourself-request."))
333
334 (declare-request interact-request (request)
335 ((major-opcode :initform *xsmp* :type card8)
336 (minor-opcode :type card8)
337 (dialog-type :type dialog-type :pad-size 1)
338 (length :type card32 :initform 0))
339 (:documentation "During a checkpoint or session-save operation, only one
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
342 some later time if the shutdown is not cancelled by another client first.
343 The dialog-type slot is one of :error :normal, indicating that the client
344 wants to start an error dialog or normal, meaning the client wishes to start
345 a non-error dialog."))
346
347 (declare-request interact (request)
348 ((major-opcode :initform *xsmp* :type card8)
349 (minor-opcode :type card8 :pad-size 2)
350 (length :type card32 :initform 0))
351 (:documentation "This message grants the client the privilege of interacting
352 with the user. When the client is done interacting with the user it must send
353 an interact-done message to the SM unless a shutdown cancel is received."))
354
355 (declare-request interact-done (request)
356 ((major-opcode :initform *xsmp* :type card8)
357 (minor-opcode :type card8)
358 (cancel-shutdown-p :type boolean :pad-size 1)
359 (length :type card32 :initform 0))
360 (:documentation "This message is used by a client to notify the SM that it is
361 done interacting. Setting the cancel-shutdown-p to True indicates that the
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
364 the shutdown-p slot and :any or :errors in the interact-style slot.
365 Otherwise, cancel-shutdown-p must be NIL."))
366
367 (declare-request save-yourself-done (request)
368 ((major-opcode :initform *xsmp* :type card8)
369 (minor-opcode :type card8)
370 (success-p :type boolean :pad-size 1)
371 (length :type card32 :initform 0))
372 (:documentation "This message is sent by a client to indicate that all of the
373 properties representing its state have been updated. After sending
374 save-yourself-done the client must wait for a save-complete,
375 shutdown-cancelled, or die message before changing its state. If the
376 save-yourself operation was successful, then the client should set the
377 success-p slot to T; otherwise the client should set it to NIL."))
378
379 (declare-request die (request)
380 ((major-opcode :initform *xsmp* :type card8)
381 (minor-opcode :type card8 :pad-size 2)
382 (length :type card32 :initform 0))
383 (:documentation "When the SM wants a client to die it sends a Die message.
384 Before the client dies it responds by sending a connection-closed message
385 and may then close its connection to the SM at any time."))
386
387 (declare-request shutdown-cancelled (request)
388 ((major-opcode :initform *xsmp* :type card8)
389 (minor-opcode :type card8 :pad-size 2)
390 (length :type card32 :initform 0))
391 (:documentation "The shutdown currently in process has been aborted. The
392 client can now continue as if the shutdown had never happened. If the client
393 has not sent save-yourself-done yet, the client can either abort the save and
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
396 set to reflect the outcome of the save."))
397
398 (declare-request connection-closed (request)
399 ((major-opcode :initform *xsmp* :type card8)
400 (minor-opcode :type card8 :pad-size 2)
401 (length :type card32 :initform 0)
402 (reason :type strings))
403 (:documentation "Specifies that the client has decided to terminate. It
404 should be immediately followed by closing the connection.
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
407 user, there will typically be a NIL or a null string here. But if the client
408 encountered an unexpected fatal error, the error message (which might
409 otherwise be printed on *standard-error*) should be forwarded to the SM here,
410 one string per line of the message. It is the responsibility of the SM to
411 display this reason to the user.
412 After sending this message, the client must not send any additional XSMP
413 messages to the SM."))
414
415 (declare-request set-properties (request)
416 ((major-opcode :initform *xsmp* :type card8)
417 (minor-opcode :type card8 :pad-size 2)
418 (length :type card32 :initform 0)
419 (properties :type properties))
420 (:documentation "Sets the specified properties to the specified values.
421 Existing properties not specified in the SetProperties message are
422 unaffected. Some properties have predefined semantics. See section 11,
423 ``Predefined Properties.'' The protocol specification recommends that
424 property names used for properties not defined by the standard should begin
425 with an underscore. To prevent conflicts among organizations, additional
426 prefixes should be chosen. The organizational prefixes should be registered
427 with the X Registry. The XSMP reserves all property names not beginning with
428 an underscore for future use."))
429
430 (declare-request delete-properties (request)
431 ((major-opcode :initform *xsmp* :type card8)
432 (minor-opcode :type card8 :pad-size 2)
433 (length :type card32 :initform 0)
434 (properties :type strings))
435 (:documentation "Removes the named properties."))
436
437 (declare-request get-properties (request)
438 ((major-opcode :initform *xsmp* :type card8)
439 (minor-opcode :type card8 :pad-size 2)
440 (length :type card32 :initform 0))
441 (:documentation "Requests that the SM respond with the values of all the
442 properties for this client."))
443
444 (declare-request get-properties-reply (request)
445 ((major-opcode :initform *xsmp* :type card8)
446 (minor-opcode :type card8 :pad-size 2)
447 (length :type card32 :initform 0)
448 (properties :type properties))
449 (:documentation "This message is sent in reply to a get-properties message
450 and includes the values of all the properties."))
451
452 (declare-request save-yourself-phase2-request (request)
453 ((major-opcode :initform *xsmp* :type card8)
454 (minor-opcode :type card8 :pad-size 2)
455 (length :type card32 :initform 0))
456 (:documentation "This message is sent by a client to indicate that it needs
457 to be informed when all the other clients are quiescent, so it can continue
458 its state."))
459
460 (declare-request save-yourself-phase2 (request)
461 ((major-opcode :initform *xsmp* :type card8)
462 (minor-opcode :type card8 :pad-size 2)
463 (length :type card32 :initform 0))
464 (:documentation "The SM sends this message to a client that has previously
465 sent a save-yourself-phase2-request message. This message informs the client
466 that all other clients are in a fixed state and this client can save state
467 that is associated with other clients.
468 The client writes a state file, if necessary, and, if necessary, uses
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
471 the user by sending an interact-request message. This should only be done if
472 an error occurs that requires user interaction to resolve. After the state
473 has been saved, or if it cannot be successfully saved, and the properties
474 are appropriately set, the client sends a save-yourself-done message."))
475
476 (declare-request save-complete (request)
477 ((major-opcode :initform *xsmp* :type card8)
478 (minor-opcode :type card8 :pad-size 2)
479 (length :type card32 :initform 0))
480 (:documentation "When the SM is done with a checkpoint, it will send each
481 of the clients a save-complete message. The client is then free to change
482 its state."))
483
484 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
485 ;;;; ;;;;
486 ;;;; SM Library ;;;;
487 ;;;; ;;;;
488 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
489
490 (defclass sm-connection (ice-connection)
491 ((client-id
492 :initarg :client-id :type client-id
493 :accessor sm-client-id)
494 (sm-release
495 :initarg :sm-release :type string
496 :accessor sm-release)
497 (sm-vendor
498 :initarg :sm-vendor :type string
499 :accessor sm-vendor)
500 (sm-protocol-version
501 :initarg :sm-protocol-version :type card16
502 :accessor sm-protocol-version)
503 (sm-protocol-revision
504 :initarg :sm-protocol-revision :type card16
505 :accessor sm-protocol-revision)))
506
507 (defun register-xsmp-protocol (opcode)
508 (register-protocol opcode
509 '#(:request-error :register-client :register-client-reply :save-yourself
510 :save-yourself-request :interact-request :interact :interact-done
511 :save-yourself-done :die :shutdown-cancelled :connection-closed
512 :set-properties :delete-properties :get-properties :get-properties-reply
513 :save-yourself-phase2-request :save-yourself-phase2 :save-complete)))
514
515 (define-condition session-manager-unavailable (error)
516 ((reason
517 :initarg :reason :type string
518 :reader session-manager-unavailable-reason))
519 (:report (lambda (condition stream)
520 (format stream
521 "SM-lib: Unable to connect to session manager: ~a~%"
522 (session-manager-unavailable-reason condition)))))
523
524 (defmacro signal-sm-error (string &rest args)
525 `(error 'session-manager-unavailable :reason (format nil ,string ,@args)))
526
527 (defun open-sm-connection (&key must-authenticate-p previous-id network-ids)
528 "Returns an sm-connection object if it succeeds. Otherwise an error will be
529 signaled. (its type will depend on the reason of the failure)
530
531 - :network-ids : if given, must be a list of network-id for the session
532 manager. If not given, the value of the SESSION_MANAGER environment variable
533 will be used. An attempt will be made to use the first network-id. If this
534 fails an attempt will be made to use the second one, and so on. Each
535 network-id has the following format:
536 local/<HOST-NAME>:<PATH>
537 tcp/<HOST-NAME>:<PORT-NUMBER>
538 decnet/<HOST-NAME>::<OBJ>
539
540 - :previous-id : if the client is restarted from a previous session, should
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
543 re-register the client with a previous-id set to NIL. If the client is first
544 joining the session :previous-id can be NIL (default) or the empty string.
545
546 Any authentication requirements are handled internally by the SM Library.
547 The method by which authentication data is obtained is implementation
548 dependent. We only use and know the default use of the ICEauthority file.
549 You will need to register your own methods for other authentication methods.
550 To do so see and use register-ice-authentication-protocol."
551 (declare (type (or null list) network-ids))
552 (declare (type (or null client-id) previous-id))
553 (declare (type boolean must-authenticate-p))
554 (unless network-ids
555 (setf network-ids (list (get-environment-variable)))
556 (when (null (car network-ids))
557 (signal-sm-error "SESSION_MANAGER environment variable is undefined.")))
558 (let ((sm-conn (make-instance 'sm-connection)))
559 (open-connection
560 network-ids :connection sm-conn :must-authenticate-p must-authenticate-p)
561 ;; Send protocol-setup request and wait for protocol-reply,then
562 ;; send register-client and wait for register-client-reply.
563 ;; Authentication will take place behind the scene.
564 (let ((protocols
565 (available-authentication-protocols
566 "XSMP" (ice-connection-string sm-conn) (ice-auth-proto-names)))
567 (versions (make-default-versions
568 :major +sm-proto-major+ :minor +sm-proto-minor+)))
569 (declare (type (simple-array string (*)) protocols))
570 (declare (type versions versions))
571 (post-request :protocol-setup sm-conn
572 :protocol-name "XSMP"
573 :protocol-major-opcode +sm-proto-major+
574 :number-of-versions-offered (length versions)
575 :must-authenticate-p must-authenticate-p
576 :vendor-name +vendor-name+
577 :release-name +release-name+
578 :authentication-protocol-names protocols
579 :version-list versions
580 :number-of-authentication-protocol-names-offered (length protocols))
581 (with-error-handler (sm-conn #'(lambda (x) x))
582 (request-case (sm-conn :timeout nil :place request :ice-flush-p nil)
583 (authentication-required ((index authentication-protocol-index))
584 (let ((handler (get-protocol-handler (aref protocols index))))
585 (declare (type function handler))
586 (funcall handler sm-conn request))
587 (values))
588 (protocol-reply (protocol-major-opcode vendor-name release-name)
589 ;; internally register the protocol.
590 (setf *xsmp* protocol-major-opcode)
591 (register-xsmp-protocol protocol-major-opcode)
592 ;; send the register-client request.
593 (post-request :register-client sm-conn
594 :previous-id (or previous-id ""))
595 ;; collect some connection infos.
596 (with-slots (version-index) request
597 (let ((version (aref versions version-index)))
598 (declare (type version version))
599 (setf (sm-protocol-version sm-conn) (aref version 0))
600 (setf (sm-protocol-revision sm-conn) (aref version 1))))
601 (setf (sm-release sm-conn) release-name)
602 (setf (sm-vendor sm-conn) vendor-name)
603 (values))
604 (register-client-reply (client-id)
605 (setf (sm-client-id sm-conn) client-id))
606 (request-error ((omo offending-minor-opcode) (mo major-opcode))
607 (let ((offender (decode-ice-minor-opcode omo mo)))
608 (if (and (bad-value-p request) (eq offender :register-client))
609 ;; Could not register the client because the previous ID
610 ;; was bad. So now we register the client with the
611 ;; previous ID set to empy string.
612 (post-request :register-client sm-conn :previous-id "")
613 ;; signal an error.
614 (request-error-handler request)))
615 (values))
616 ;; bad state signal an error.
617 (t (signal-sm-error "bad state during protocol setup: ~a." request))))
618 sm-conn)))
619
620 (defun close-sm-connection (sm-conn &key reason)
621 "Closes a connection with a session manager."
622 (declare (type sm-connection sm-conn))
623 (declare (type (or null string) reason))
624 (ice-lib:post-request :want-to-close sm-conn)
625 (ice-lib:post-request :connection-closed sm-conn :reason reason)
626 (ice-flush sm-conn)
627 (setf (sm-release sm-conn) nil)
628 (setf (sm-vendor sm-conn) nil)
629 (setf (ice-release sm-conn) nil)
630 (setf (ice-vendor sm-conn) nil)
631 (setf (ice-connection-string sm-conn) nil)
632 (close (ice-lib:connection-stream sm-conn)))

  ViewVC Help
Powered by ViewVC 1.1.5