branch: externals/xelb commit 878c6110fb6c5b75aa806794d8a0188aaf697344 Author: Chris Feng <chris.w.f...@gmail.com> Commit: Chris Feng <chris.w.f...@gmail.com>
Fix sequence number wrapping issues * xcb.el (xcb:connection-timeout): Reduce timeout to 3. (xcb:connection): Merge slots 'error-sequence' and 'reply-sequence' into 'last-seen-sequence'. (xcb:-sequence-cmp16): Removed. * xcb.el (xcb:-SEQUENCE-SEGMENT-MASK): New constant representing the segment mask of a sequence number. (xcb:-convert-sequence): New method for converting 16-bit sequence number received from the server into that used in the client. (xcb:-connection-filter): Use this method. (xcb:-+request, xcb:-+request-checked, xcb:-+request-unchecked) (xcb:-+reply, xcb:-request-check, xcb:aux:sync): Avoid using 16-bit sequence number. (xcb:-cache-request): Force wrapping sequence numbers. (xcb:-+reqply, xcb:-request-check, xcb:aux:sync): Check sequence number wrapping. * xcb.el (xcb:aux:sync): Discard any reply or error. --- xcb.el | 104 +++++++++++++++++++++++++++++++++------------------------------- 1 file changed, 54 insertions(+), 50 deletions(-) diff --git a/xcb.el b/xcb.el index a0c601a..b4e3474 100644 --- a/xcb.el +++ b/xcb.el @@ -67,7 +67,7 @@ (when xcb:debug-on `(message (concat "[XELB LOG] " ,format-string) ,@args))) -(defvar xcb:connection-timeout 10 "Connection timeout.") +(defvar xcb:connection-timeout 3 "Connection timeout.") ;;;; X connection related @@ -91,24 +91,11 @@ (extension-first-error-alist :initform nil) (extension-first-event-alist :initform nil) (request-sequence :initform 0) - (error-sequence :initform 0) - (reply-sequence :initform 0) + (last-seen-sequence :initform 0) (xid :initform 0) ;last used X resource ID (extra-plist :initform nil)) ;for storing extra data (e.g. by extensions) :documentation "X connection.") -(defsubst xcb:-sequence-cmp16 (sequence1 sequence2) - "Compare 16-bit sequence numbers SEQUENCE1 and SEQUENCE2. - -Return a positive value if SEQUENCE1 is larger than SEQUENCE2, 0 if they are -equal. Otherwise a negative value would be returned." - (if (= sequence1 sequence2) - 0 - (let ((diff (- sequence1 sequence2))) - (if (< #x7FFF (abs diff)) - (- diff) ;overflowed - diff)))) - (defclass xcb:auth-info () ((name :initarg :name :initform "" :type string) (data :initarg :data :initform "" :type string)) @@ -234,6 +221,26 @@ equal. Otherwise a negative value would be returned." (while (not (slot-value obj 'setup-data)) (accept-process-output process 1 nil 1))))) +(defconst xcb:-SEQUENCE-SEGMENT-MASK (lognot #xFFFF)) + +(cl-defmethod xcb:-convert-sequence ((obj xcb:connection) sequence16) + "Convert 16-bit sequence number SEQUENCE16 (read from a packet). + +The result would be 29 or 61 bits, depending on the machine." + (with-slots (request-sequence last-seen-sequence) obj + ;; Assume there are no more than #xFFFF requests sent since the + ;; request corresponding to this packet was made. Because errors + ;; and replies are always read out in the process filter, this + ;; assumption is quite safe. + (let ((sequence (logior (logand request-sequence + xcb:-SEQUENCE-SEGMENT-MASK) + sequence16))) + ;; `xcb:-cache-request' ensures sequence number never wraps. + (when (> sequence request-sequence) + (cl-decf sequence #x10000)) + (setf last-seen-sequence sequence) + sequence))) + (defun xcb:-connection-filter (process message) "Filter function for an X connection. @@ -290,6 +297,7 @@ Concurrency is disabled as it breaks the orders of errors, replies and events." cache 2)) (plist (slot-value connection 'error-plist)) struct) + (setq sequence (xcb:-convert-sequence connection sequence)) (when (plist-member plist sequence) (setq struct (plist-get plist sequence)) (setf (slot-value connection 'error-plist) @@ -297,8 +305,7 @@ Concurrency is disabled as it breaks the orders of errors, replies and events." (push `(,(aref cache 1) . ,(substring cache 0 32)) struct)))) - (setq cache (substring cache 32)) - (setf (slot-value connection 'error-sequence) sequence))) + (setq cache (substring cache 32)))) (1 ;reply (let* ((reply-words (funcall (if xcb:lsb #'xcb:-unpack-u4-lsb #'xcb:-unpack-u4) @@ -310,7 +317,8 @@ Concurrency is disabled as it breaks the orders of errors, replies and events." (xcb:-log "Reply received: %s" (substring cache 0 reply-length)) (setq sequence (funcall (if xcb:lsb #'xcb:-unpack-u2-lsb #'xcb:-unpack-u2) - cache 2)) + cache 2) + sequence (xcb:-convert-sequence connection sequence)) (setq plist (slot-value connection 'reply-plist)) (setq struct (plist-get plist sequence)) (when struct @@ -324,8 +332,7 @@ Concurrency is disabled as it breaks the orders of errors, replies and events." ;; Multiple replies `(,(car struct) ,@(cdr struct) ,(substring cache 0 reply-length)))))) - (setq cache (substring cache reply-length)) - (setf (slot-value connection 'reply-sequence) sequence))) + (setq cache (substring cache reply-length)))) (x ;event (let (synthetic listener event-length) (when (/= 0 (logand x #x80)) ;synthetic event @@ -527,22 +534,26 @@ classes of EVENT (since they have the same event number)." (+ (length msg) (length cache))) ;flush on cache full (xcb:flush obj) (setq cache [])) - (with-slots (request-cache request-sequence) obj + (with-slots (request-cache request-sequence last-seen-sequence) obj + (when (>= request-sequence most-positive-fixnum) + ;; Force wrapping the sequence number. + (xcb:aux:sync obj) + (setf request-sequence 0 + last-seen-sequence 0)) (setf request-cache (vconcat cache msg) request-sequence (1+ request-sequence)) (xcb:-log "Cache request #%d: %s" request-sequence request) request-sequence))) (cl-defmethod xcb:-+request ((obj xcb:connection) request) - (let* ((sequence (xcb:-cache-request obj request)) - (sequence-lsw (logand #xFFFF sequence)) - (class (eieio-object-class request))) + (let ((sequence (xcb:-cache-request obj request)) + (class (eieio-object-class request))) (when (fboundp (xcb:-request-class->reply-class class)) ;; This request has a reply (setf (slot-value obj 'reply-plist) ;require reply - (plist-put (slot-value obj 'reply-plist) sequence-lsw class)) + (plist-put (slot-value obj 'reply-plist) sequence class)) (setf (slot-value obj 'error-plist) ;require error - (plist-put (slot-value obj 'error-plist) sequence-lsw nil))) + (plist-put (slot-value obj 'error-plist) sequence nil))) sequence)) (defmacro xcb:+request (obj request) @@ -557,10 +568,9 @@ Otherwise no error will ever be reported." (when (fboundp (xcb:-request-class->reply-class (eieio-object-class request))) (error "This method shall not be called with request that has a reply")) - (let* ((sequence (xcb:-cache-request obj request)) - (sequence-lsw (logand #xFFFF sequence))) + (let ((sequence (xcb:-cache-request obj request))) (setf (slot-value obj 'error-plist) - (plist-put (slot-value obj 'error-plist) sequence-lsw nil)) + (plist-put (slot-value obj 'error-plist) sequence nil)) sequence)) (defmacro xcb:+request-checked (obj request) @@ -572,11 +582,10 @@ Otherwise no error will ever be reported." (unless (fboundp (xcb:-request-class->reply-class (eieio-object-class request))) (error "This method shall not be called with request that has no reply")) - (let* ((sequence (xcb:-cache-request obj request)) - (sequence-lsw (logand #xFFFF sequence))) + (let ((sequence (xcb:-cache-request obj request))) (setf (slot-value obj 'reply-plist) (plist-put (slot-value obj 'reply-plist) - sequence-lsw (eieio-object-class request))) + sequence (eieio-object-class request))) sequence)) (defmacro xcb:+request-unchecked (obj request) @@ -585,27 +594,20 @@ Otherwise no error will ever be reported." `(xcb:-+request-unchecked ,obj ,request)) (cl-defmethod xcb:-+reply ((obj xcb:connection) sequence &optional multiple) - (setq sequence (logand #xFFFF sequence)) ;only the LSW is used (unless (plist-member (slot-value obj 'reply-plist) sequence) (error "This method is intended for requests with replies")) (xcb:flush obj) ;or we may have to wait forever (if multiple ;; Multiple replies - (when (and (<= 0 (xcb:-sequence-cmp16 sequence - (slot-value obj 'reply-sequence))) - (<= 0 (xcb:-sequence-cmp16 sequence - (slot-value obj 'error-sequence)))) - (xcb:aux:sync obj)) + (xcb:aux:sync obj) ;; Single reply (let ((process (slot-value obj 'process))) ;; Wait until the request processed (cl-incf (slot-value obj 'event-lock)) (with-timeout (xcb:connection-timeout (warn "[XELB] Retrieve reply timeout")) - (while (and (< 0 (xcb:-sequence-cmp16 - sequence (slot-value obj 'reply-sequence))) - (< 0 (xcb:-sequence-cmp16 - sequence (slot-value obj 'error-sequence)))) + (while (and (> sequence (slot-value obj 'last-seen-sequence)) + (<= sequence (slot-value obj 'request-sequence))) (accept-process-output process 1 nil 1))) (cl-decf (slot-value obj 'event-lock)))) (let* ((reply-plist (slot-value obj 'reply-plist)) @@ -649,7 +651,6 @@ MULTIPLE value, or some replies may be lost!" `(xcb:-+reply ,obj ,sequence ,multiple)) (cl-defmethod xcb:-request-check ((obj xcb:connection) sequence) - (setq sequence (logand #xFFFF sequence)) ;only the LSW is used (when (plist-member (slot-value obj 'reply-plist) sequence) (error "This method is intended for requests with no reply")) (xcb:flush obj) ;or we may have to wait forever @@ -657,7 +658,7 @@ MULTIPLE value, or some replies may be lost!" error-obj tmp) (unless (plist-member error-plist sequence) (error "This method shall be called after `xcb:+request-checked'")) - (when (< 0 (xcb:-sequence-cmp16 sequence (slot-value obj 'error-sequence))) + (when (> sequence (slot-value obj 'last-seen-sequence)) (xcb:aux:sync obj)) ;wait until the request is processed (setq error-obj (mapcar (lambda (i) @@ -711,17 +712,20 @@ MULTIPLE value, or some replies may be lost!" "Force sync with X server. Sync by sending a GetInputFocus request and waiting until it's processed." - (let* ((sequence (xcb:-cache-request obj (make-instance 'xcb:GetInputFocus))) - (sequence-lsw (logand #xFFFF sequence)) - (process (slot-value obj 'process))) + (let ((sequence (xcb:-cache-request obj (make-instance 'xcb:GetInputFocus))) + (process (slot-value obj 'process))) (xcb:flush obj) ;; Wait until request processed (cl-incf (slot-value obj 'event-lock)) (with-timeout (xcb:connection-timeout (warn "[XELB] Sync timeout")) - (while (< 0 (xcb:-sequence-cmp16 sequence-lsw - (slot-value obj 'reply-sequence))) + (while (and (> sequence (slot-value obj 'last-seen-sequence)) + ;; In case the sequence number has been wrapped. + (<= sequence (slot-value obj 'request-sequence))) (accept-process-output process 1 nil 1))) - (cl-decf (slot-value obj 'event-lock)))) + (cl-decf (slot-value obj 'event-lock)) + ;; Discard any reply or error. + (cl-remf (slot-value obj 'reply-plist) sequence) + (cl-remf (slot-value obj 'error-plist) sequence))) (cl-defmethod xcb:-error-or-event-class->number ((obj xcb:connection) class) "Return the error/event number of a error/event class CLASS.