/[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.6 by ihatchondo, Tue Mar 16 16:56:54 2004 UTC revision 1.7 by ihatchondo, Wed Mar 17 13:38:14 2004 UTC
# Line 550  Line 550 
550      ;; Send protocol-setup request and wait for protocol-reply,then      ;; Send protocol-setup request and wait for protocol-reply,then
551      ;; send register-client and wait for register-client-reply.      ;; send register-client and wait for register-client-reply.
552      ;; Authentication will take place behind the scene.      ;; Authentication will take place behind the scene.
553      (let ((error-handler (ice-error-handler sm-conn))      (let ((protocols
           (protocols  
554             (available-authentication-protocols             (available-authentication-protocols
555              "XSMP" (ice-connection-string sm-conn) (ice-auth-proto-names)))              "XSMP" (ice-connection-string sm-conn) (ice-auth-proto-names)))
556            (versions (make-default-versions            (versions (make-default-versions
# Line 568  Line 567 
567          :authentication-protocol-names protocols          :authentication-protocol-names protocols
568          :version-list versions          :version-list versions
569          :number-of-authentication-protocol-names-offered (length protocols))          :number-of-authentication-protocol-names-offered (length protocols))
570        (setf (ice-error-handler sm-conn) (lambda (x) x))        (with-error-handler (sm-conn #'(lambda (x) x))
571        (request-case (sm-conn :timeout nil :place request :ice-flush-p nil)          (request-case (sm-conn :timeout nil :place request :ice-flush-p nil)
572          (authentication-required ((index authentication-protocol-index))            (authentication-required ((index authentication-protocol-index))
573            (let ((handler (get-protocol-handler (aref protocols index))))              (let ((handler (get-protocol-handler (aref protocols index))))
574              (declare (type function handler))                (declare (type function handler))
575              (funcall handler sm-conn request))                (funcall handler sm-conn request))
576            (values))              (values))
577          (protocol-reply (protocol-major-opcode vendor-name release-name)            (protocol-reply (protocol-major-opcode vendor-name release-name)
578            ;; internally register the protocol.              ;; internally register the protocol.
579            (setf *xsmp* protocol-major-opcode)              (setf *xsmp* protocol-major-opcode)
580            (register-xsmp-protocol protocol-major-opcode)              (register-xsmp-protocol protocol-major-opcode)
581            ;; send the register-client request.              ;; send the register-client request.
582            (post-request :register-client sm-conn :previous-id previous-id)              (post-request :register-client sm-conn :previous-id previous-id)
583            ;; collect some connection infos.              ;; collect some connection infos.
584            (with-slots (version-index) request              (with-slots (version-index) request
585              (let ((version (aref versions version-index)))                (let ((version (aref versions version-index)))
586                (declare (type version version))                  (declare (type version version))
587                (setf (sm-protocol-version sm-conn) (aref version 0))                  (setf (sm-protocol-version sm-conn) (aref version 0))
588                (setf (sm-protocol-revision sm-conn) (aref version 1))))                  (setf (sm-protocol-revision sm-conn) (aref version 1))))
589            (setf (sm-release sm-conn) release-name)              (setf (sm-release sm-conn) release-name)
590            (setf (sm-vendor sm-conn) vendor-name)              (setf (sm-vendor sm-conn) vendor-name)
591            (values))              (values))
592          (register-client-reply (client-id)            (register-client-reply (client-id)
593            (setf (sm-client-id sm-conn) client-id))              (setf (sm-client-id sm-conn) client-id))
594          (request-error ((omo offending-minor-opcode) (mo major-opcode))            (request-error ((omo offending-minor-opcode) (mo major-opcode))
595            (let ((offender (decode-ice-minor-opcode omo mo)))              (let ((offender (decode-ice-minor-opcode omo mo)))
596              (if (and (bad-value-p request) (eq offender :register-client))                (if (and (bad-value-p request) (eq offender :register-client))
597                  ;; Could not register the client because the previous ID                    ;; Could not register the client because the previous ID
598                  ;; was bad. So now we register the client with the                    ;; was bad. So now we register the client with the
599                  ;; previous ID set to empy string.                    ;; previous ID set to empy string.
600                  (post-request :register-client sm-conn :previous-id "")                    (post-request :register-client sm-conn :previous-id "")
601                  (signal-request-error request)))                    ;; signal an error.
602            (values))                    (request-error-handler request)))
603          ;; bad state signal an error.              (values))
604          (t (signal-sm-error "bad state during protocol setup: ~a." request)))            ;; bad state signal an error.
605        ;; Reset the error handler and Returns the sm-connection instance.            (t (signal-sm-error "bad state during protocol setup: ~a." request))))
       (setf (ice-error-handler sm-conn) error-handler)  
606        sm-conn)))        sm-conn)))
607    
608  (defun close-sm-connection (sm-conn &key reason)  (defun close-sm-connection (sm-conn &key reason)

Legend:
Removed from v.1.6  
changed lines
  Added in v.1.7

  ViewVC Help
Powered by ViewVC 1.1.5