[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[elpa] externals/xelb 878c611 1/2: Fix sequence number wrapping issues
From: |
Chris Feng |
Subject: |
[elpa] externals/xelb 878c611 1/2: Fix sequence number wrapping issues |
Date: |
Thu, 11 Aug 2016 12:19:43 +0000 (UTC) |
branch: externals/xelb
commit 878c6110fb6c5b75aa806794d8a0188aaf697344
Author: Chris Feng <address@hidden>
Commit: Chris Feng <address@hidden>
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.