Location: lg@xxxxxxxxxxxxxx http://arch.xwem.org/2005/
Revision: xlib--main--2.1--patch-4
Archive: lg@xxxxxxxxxxxxxx
Creator: Zajcev Evgeny <lg@xxxxxxxx>
Date: Thu Feb 3 01:11:17 MSK 2005
Standard-date: 2005-02-02 22:11:17 GMT
Modified-files: lisp/xlib-xlib.el lisp/xlib-xr.el
lisp/xlib-xrecord.el
New-patches: dev@xxxxxxxxxxxxxxxx/xlib--dev--2.1--base-0
dev@xxxxxxxxxxxxxxxx/xlib--dev--2.1--patch-1
lg@xxxxxxxxxxxxxx/xlib--main--2.1--patch-4
Summary: 2 serious bug fixes
Keywords: bug, send-read, parse-message, xrecord
* lisp/xlib-xlib.el (xlib-opcodes-alist): [rem] moved to xlib-xr.el
* lisp/xlib-xr.el (xlib-opcodes-alist): [new] moved from xlib-xlib.el
* lisp/xlib-xr.el (X-Dpy-send-read): [BUG fix] Serious BUG fixed. Do
flushing under reading protection, because in some (pretty ofter)
circumstances flushing can execute deffered calls by side effect which
may lead to desyncronisation.
* lisp/xlib-xr.el (X-Dpy-parse-message): [BUG fix] Serious BUG fixed.
Dispatch intermediate event or error only after all reply to request is
fetched. Executing intermediate event or error may cause unexpected
reading by side effect.
* lisp/xlib-xr.el (code): [cleanup] Untabification.
* lisp/xlib-xrecord.el (X-XRecord-parse-guess): [fix] fixes to make it
more resistable for errors.
* lisp/xlib-xrecord.el (code): [cleanup] Untabification.
* added directories
{arch}/xlib/xlib--dev/xlib--dev--2.1
{arch}/xlib/xlib--dev/xlib--dev--2.1/dev@xxxxxxxxxxxxxxxx
{arch}/xlib/xlib--dev/xlib--dev--2.1/dev@xxxxxxxxxxxxxxxx/patch-log
* added files
{arch}/xlib/xlib--dev/xlib--dev--2.1/dev@xxxxxxxxxxxxxxxx/patch-log/base-0
{arch}/xlib/xlib--dev/xlib--dev--2.1/dev@xxxxxxxxxxxxxxxx/patch-log/patch-1
{arch}/xlib/xlib--main/xlib--main--2.1/lg@xxxxxxxxxxxxxx/patch-log/patch-4
* modified files
--- orig/lisp/xlib-xlib.el
+++ mod/lisp/xlib-xlib.el
@@ -32,92 +32,6 @@
(require 'xlib-xr)
-(defvar xlib-opcodes-alist
- '((104 . XBell)
- (1 . XCreateWindow)
- (2 . XChangeWindowAttributes)
- (3 . XGetWindowAttributes)
- (12 . XConfigureWindow)
- (8 . XMapWindow)
- (10 . XUnmapWindow)
- (4 . XDestroyWindow)
- (5 . XDestroySubwindows)
- (15 . XQueryTree)
- (16 . XInternAtom)
- (17 . XGetAtomName)
- (18 . XChangeProperty)
- (20 . XGetWindowProperty)
- (78 . XCreateColormap)
- (79 . XFreeColormap)
- (84 . XAllocColor)
- (85 . XAllocNamedColor)
- (86 . XAllocColorCells)
- (89 . XStoreColors)
- (88 . XFreeColors)
- (91 . XQueryColors)
- (55 . XCreateGC)
- (56 . XChangeGC)
- (58 . XSetDashes)
- (59 . XSetClipRectangles)
- (60 . XFreeGC)
- (61 . XClearArea)
- (62 . XCopyArea)
- (63 . XCopyPlane)
- (64 . XDrawPoints)
- (65 . XDrawLines)
- (69 . XFillPoly)
- (66 . XDrawSegments)
- (67 . XDrawRectangles)
- (70 . XDrawRectangles)
- (68 . XDrawArcs)
- (71 . XDrawArcs)
- (74 . XDrawString)
- (76 . XImageString)
- (72 . XPutImage)
- (73 . XGetImage)
- (22 . XSetSelectionOwner)
- (23 . XGetSelectionOwner)
- (24 . XConvertSelection)
- (41 . XWarpPointer)
- (36 . XGrabServer)
- (37 . XUngrabServer)
- (38 . XQueryPointer)
- (31 . XGrabKeyboard)
- (32 . XUngrabKeyboard)
- (26 . XGrabPointer)
- (27 . XUngrabPointer)
- (28 . XGrabButton)
- (29 . XUngrabButton)
- (33 . XGrabKey)
- (34 . XUngrabKey)
- (43 . XGetInputFocus)
- (42 . XSetInputFocus)
- (7 . XReparentWindow)
- (14 . XGetGeometry)
- (40 . XTranslateCoordinates)
- (6 . XChangeSaveSet)
- (25 . XSendEvent)
- (44 . XQueryKeymap)
- (101 . XGetKeyboardMapping)
- (119 . XGetModifierMapping)
- (45 . XOpenFont)
- (47 . XQueryFont)
- (48 . XQueryTextExtents)
- (53 . XCreatePixmap)
- (54 . XFreePixmap)
- (93 . XCreateCursor)
- (94 . XCreateGlyphCursor)
- (95 . XFreeCursor)
- (96 . XRecolorCursor)
- (30 . XChangeActivePointerGrab)
- (98 . XQueryExtension)
- (107 . XSetScreenSaver)
- (108 . XGetScreenSaver)
- (113 . XKillClient)
- (115 . XForceScreenSaver))
- "Alist of X opcodes in form (OPCODE . FUNCTION).
-This is only informative variable.")
-
(defun XOpenDisplay (name &optional dispnum screen)
"Open an X connection to the display named NAME such as host:0.1.
Optionally you may pass DISPNUM - display number and SCREEN - screen number."
--- orig/lisp/xlib-xr.el
+++ mod/lisp/xlib-xr.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2003 by Free Software Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@xxxxxxxxxxxxxx>
-;; Zajcev Evgeny <zevlg@xxxxxxxxx>
+;; Zajcev Evgeny <zevlg@xxxxxxxxx>
;; Keywords: xlib, xwem
;; X-CVS: $Id: xlib-xr.el,v 1.7 2004/11/29 19:48:20 lg Exp $
@@ -58,11 +58,11 @@
"Take list LST and turn it into a vector.
This makes random access of its fields much faster."
(let ((nv (make-vector (length lst) nil))
- (cnt 0))
+ (cnt 0))
(while lst
(aset nv cnt (if (and (car lst) (listp (car lst)))
- (XVectorizeList (car lst))
- (car lst)))
+ (XVectorizeList (car lst))
+ (car lst)))
(setq cnt (1+ cnt))
(setq lst (cdr lst)))
nv))
@@ -76,20 +76,20 @@
"List of event descriptions.")
(defstruct (X-Event (:predicate X-Event-isevent-p))
- dpy ; display
- type ; type of event
- synth-p ; non-nil if event came from SendEvent
request
- evdata ; binary event represetation
- evinfo ; parsed variant of evdata
+ dpy ; display
+ type ; type of event
+ synth-p ; non-nil if event came from SendEvent
request
+ evdata ; binary event represetation
+ evinfo ; parsed variant of evdata
- list ;for use in X-Generate-message
- properties ; User defined plist
+ list ;for use in X-Generate-message
+ properties ; User defined plist
)
(defsubst X-Event-put-property (xev prop val)
"Put property PROP with value VAL in XEV's properties list."
(setf (X-Event-properties xev)
- (plist-put (X-Event-properties xev) prop val)))
+ (plist-put (X-Event-properties xev) prop val)))
(defsubst X-Event-get-property (xev prop)
"Get property PROP from XEV's properties list."
@@ -103,7 +103,7 @@
"Return non-nil if EV is X-Event."
(let ((isev (X-Event-isevent-p ev)))
(if (and (not isev) sig)
- (signal 'wrong-type-argument (list sig 'X-Event-p ev))
+ (signal 'wrong-type-argument (list sig 'X-Event-p ev))
isev)))
(defsubst X-Event-detail (xev)
@@ -127,7 +127,7 @@
(defun X-Event-make (&rest args)
"Like `make-X-Event', but also fills list field automatically."
(let* ((xev (apply 'make-X-Event args))
- (evspec (aref (X-Event-type xev) X-EventsList)))
+ (evspec (aref (X-Event-type xev) X-EventsList)))
;; TODO: write me ..
))
@@ -138,12 +138,12 @@
(defmacro X-Event-define (type name dnames descr)
"Define new event of TYPE, NAME and description of event DESCR."
(let ((offs 0)
- fsym forms)
+ fsym forms)
(push `(aset X-EventsList ,type ,descr) forms)
(while dnames
(when (car dnames)
- (setq fsym (intern (concat "X-Event-" name "-" (symbol-name (car
dnames)))))
- (push `(defsubst* ,fsym (ev)
+ (setq fsym (intern (concat "X-Event-" name "-" (symbol-name (car
dnames)))))
+ (push `(defsubst* ,fsym (ev)
(nth ,offs (X-Event-evinfo ev)))
forms))
(setq offs (1+ offs))
@@ -154,40 +154,40 @@
"Convert XEV type to symbolic name, return keyword."
(let ((evt (X-Event-type xev)))
(cond ((= evt X-KeyPress) :X-KeyPress)
- ((= evt X-KeyRelease) :X-KeyRelease)
- ((= evt X-ButtonPress) :X-ButtonPress)
- ((= evt X-ButtonRelease) :X-ButtonRelease)
- ((= evt X-MotionNotify) :X-MotionNotify)
- ((= evt X-EnterNotify) :X-EnterNotify)
- ((= evt X-LeaveNotify) :X-LeaveNotify)
- ((= evt X-FocusIn) :X-FocusIn)
- ((= evt X-FocusOut) :X-FocusOut)
- ((= evt X-KeymapNotify) :X-KeymapNotify)
- ((= evt X-Expose) :X-Expose)
- ((= evt X-GraphicsExpose) :X-GraphicsExpose)
- ((= evt X-NoExpose) :X-NoExpose)
- ((= evt X-VisibilityNotify) :X-VisibilityNotify)
- ((= evt X-CreateNotify) :X-CreateNotify)
- ((= evt X-DestroyNotify) :X-DestroyNotify)
- ((= evt X-UnmapNotify) :X-UnmapNotify)
- ((= evt X-MapNotify) :X-MapNotify)
- ((= evt X-MapRequest) :X-MapRequest)
- ((= evt X-ReparentNotify) :X-ReparentNotify)
- ((= evt X-ConfigureRequest) :X-ConfigureRequest)
- ((= evt X-ConfigureNotify) :X-ConfigureNotify)
- ((= evt X-GravityNotify) :X-GravityNotify)
- ((= evt X-ResizeRequest) :X-ResizeRequest)
- ((= evt X-CirculateNotify) :X-CirculateNotify)
- ((= evt X-CirculateRequest) :X-CirculateRequest)
- ((= evt X-PropertyNotify) :X-PropertyNotify)
- ((= evt X-SelectionClear) :X-SelectionClear)
- ((= evt X-SelectionRequest) :X-SelectionRequest)
- ((= evt X-SelectionNotify) :X-SelectionNotify)
- ((= evt X-ColormapNotify) :X-ColormapNotify)
- ((= evt X-ClientMessage) :X-ClientMessage)
- ((= evt X-MappingNotify) :X-MappingNotify)
+ ((= evt X-KeyRelease) :X-KeyRelease)
+ ((= evt X-ButtonPress) :X-ButtonPress)
+ ((= evt X-ButtonRelease) :X-ButtonRelease)
+ ((= evt X-MotionNotify) :X-MotionNotify)
+ ((= evt X-EnterNotify) :X-EnterNotify)
+ ((= evt X-LeaveNotify) :X-LeaveNotify)
+ ((= evt X-FocusIn) :X-FocusIn)
+ ((= evt X-FocusOut) :X-FocusOut)
+ ((= evt X-KeymapNotify) :X-KeymapNotify)
+ ((= evt X-Expose) :X-Expose)
+ ((= evt X-GraphicsExpose) :X-GraphicsExpose)
+ ((= evt X-NoExpose) :X-NoExpose)
+ ((= evt X-VisibilityNotify) :X-VisibilityNotify)
+ ((= evt X-CreateNotify) :X-CreateNotify)
+ ((= evt X-DestroyNotify) :X-DestroyNotify)
+ ((= evt X-UnmapNotify) :X-UnmapNotify)
+ ((= evt X-MapNotify) :X-MapNotify)
+ ((= evt X-MapRequest) :X-MapRequest)
+ ((= evt X-ReparentNotify) :X-ReparentNotify)
+ ((= evt X-ConfigureRequest) :X-ConfigureRequest)
+ ((= evt X-ConfigureNotify) :X-ConfigureNotify)
+ ((= evt X-GravityNotify) :X-GravityNotify)
+ ((= evt X-ResizeRequest) :X-ResizeRequest)
+ ((= evt X-CirculateNotify) :X-CirculateNotify)
+ ((= evt X-CirculateRequest) :X-CirculateRequest)
+ ((= evt X-PropertyNotify) :X-PropertyNotify)
+ ((= evt X-SelectionClear) :X-SelectionClear)
+ ((= evt X-SelectionRequest) :X-SelectionRequest)
+ ((= evt X-SelectionNotify) :X-SelectionNotify)
+ ((= evt X-ColormapNotify) :X-ColormapNotify)
+ ((= evt X-ClientMessage) :X-ClientMessage)
+ ((= evt X-MappingNotify) :X-MappingNotify)
- (t :X-Unknown))))
+ (t :X-Unknown))))
(defmacro X-Event-CASE (xev &rest body)
"Run event case. BODY in form (EVTYPE FORMS) (EVTYPE FORMS) ..
@@ -199,11 +199,11 @@
(defstruct X-EventHandler
priority
- evtypes-list ; list of event types
- handler ; function to call
- (active t) ; Non-nil mean event handler activated
+ evtypes-list ; list of event types
+ handler ; function to call
+ (active t) ; Non-nil mean event handler activated
- plist) ; user defined plist
+ plist) ; user defined plist
;;;###autoload
(defun X-EventHandler-add (evhlist handler &optional priority evtypes-list)
@@ -220,14 +220,14 @@
(setq priority 0))
(let ((xeh (make-X-EventHandler :priority priority
- :evtypes-list evtypes-list
- :handler handler)))
+ :evtypes-list evtypes-list
+ :handler handler)))
;; Insert new event handler and sort event handlers by priority.
(sort (cons xeh evhlist)
- (lambda (xeh1 xeh2)
- (> (X-EventHandler-priority xeh1)
- (X-EventHandler-priority xeh2))))))
+ (lambda (xeh1 xeh2)
+ (> (X-EventHandler-priority xeh1)
+ (X-EventHandler-priority xeh2))))))
;;;###autoload
(defun X-EventHandler-isset (evhlist handler &optional prioritiy evtypes-list)
@@ -237,9 +237,9 @@
(let ((evhs evhlist))
;; Find appopriate handler
(while (and evhs
- (not (and (eq (X-EventHandler-handler (car evhs)) handler)
- (if prioritiy (equal prioritiy
(X-EventHandler-priority (car evhs))) t)
- (if evtypes-list (equal evtypes-list
(X-EventHandler-evtypes-list (car evhs))) t))))
+ (not (and (eq (X-EventHandler-handler (car evhs)) handler)
+ (if prioritiy (equal prioritiy
(X-EventHandler-priority (car evhs))) t)
+ (if evtypes-list (equal evtypes-list
(X-EventHandler-evtypes-list (car evhs))) t))))
(setq evhs (cdr evhs)))
(car evhs)))
@@ -272,15 +272,15 @@
(defun X-EventHandler-runall (evhlist xev)
"Run all event handlers in EVHLIST on XEV.
Signal `X-Events-stop' to stop events processing."
- (let ((evhs evhlist)) ; EVHS should be already sorted
by priority
+ (let ((evhs evhlist)) ; EVHS should be already sorted by
priority
(condition-case nil
- (while evhs
- ;; Check is there appopriate event handler to handle XEV event.
- (when (and (X-EventHandler-active (car evhs))
- (or (null (X-EventHandler-evtypes-list (car evhs)))
- (memq (X-Event-type xev) (X-EventHandler-evtypes-list
(car evhs)))))
+ (while evhs
+ ;; Check is there appopriate event handler to handle XEV event.
+ (when (and (X-EventHandler-active (car evhs))
+ (or (null (X-EventHandler-evtypes-list (car evhs)))
+ (memq (X-Event-type xev) (X-EventHandler-evtypes-list
(car evhs)))))
(funcall (X-EventHandler-handler (car evhs)) (X-Event-dpy xev)
(X-Event-win xev) xev))
- (setq evhs (cdr evhs)))
+ (setq evhs (cdr evhs)))
(X-Events-stop nil))))
;;; X Events description.
@@ -288,393 +288,393 @@
;; TODO:
;; - Should be X-Dpy depended to support extensions derived events
(X-Event-define X-KeyPress "xkey" (keycode nil time root event child root-x
root-y event-x event-y state same-screen)
- [ "KeyPress"
- ( [1 integerp] ; keycode
- [2 integerp] ; sequence
- [4 integerp] ; time
- [4 :X-Win] ; root
- [4 :X-Win] ; event
- [4 :X-Win] ; child
- [2 integerp] ; root_x
- [2 integerp] ; root_y
- [2 integerp] ; event_x
- [2 integerp] ; event_y
- [2 integerp] ; state
- [1 booleanp] ; same_screen
- [1 nil] )
- 4 ])
+ [ "KeyPress"
+ ( [1 integerp] ; keycode
+ [2 integerp] ; sequence
+ [4 integerp] ; time
+ [4 :X-Win] ; root
+ [4 :X-Win] ; event
+ [4 :X-Win] ; child
+ [2 integerp] ; root_x
+ [2 integerp] ; root_y
+ [2 integerp] ; event_x
+ [2 integerp] ; event_y
+ [2 integerp] ; state
+ [1 booleanp] ; same_screen
+ [1 nil] )
+ 4 ])
(X-Event-declare X-KeyRelease
- [ "KeyRelease"
- ( [1 integerp] ; keycode
- [2 integerp] ; sequence
- [4 integerp] ; time
- [4 :X-Win] ; root
- [4 :X-Win] ; event
- [4 :X-Win] ; child
- [2 integerp] ; root_x
- [2 integerp] ; root_y
- [2 integerp] ; event_x
- [2 integerp] ; event_y
- [2 integerp] ; state
- [1 booleanp] ; same_screen
- [1 nil] )
- 4 ])
+ [ "KeyRelease"
+ ( [1 integerp] ; keycode
+ [2 integerp] ; sequence
+ [4 integerp] ; time
+ [4 :X-Win] ; root
+ [4 :X-Win] ; event
+ [4 :X-Win] ; child
+ [2 integerp] ; root_x
+ [2 integerp] ; root_y
+ [2 integerp] ; event_x
+ [2 integerp] ; event_y
+ [2 integerp] ; state
+ [1 booleanp] ; same_screen
+ [1 nil] )
+ 4 ])
(X-Event-define X-ButtonPress "xbutton" (button nil time root event child
root-x root-y event-x event-y state same-screen)
- [ "ButtonPress"
- ( [1 integerp] ; button
- [2 integerp] ; sequence
- [4 integerp] ; time
- [4 :X-Win] ; root
- [4 :X-Win] ; event
- [4 :X-Win] ; child
- [2 integerp] ; root_x
- [2 integerp] ; root_y
- [2 integerp] ; event_x
- [2 integerp] ; event_y
- [2 integerp] ; state
- [1 booleanp] ; same_screen
- [1 nil] )
- 4 ])
+ [ "ButtonPress"
+ ( [1 integerp] ; button
+ [2 integerp] ; sequence
+ [4 integerp] ; time
+ [4 :X-Win] ; root
+ [4 :X-Win] ; event
+ [4 :X-Win] ; child
+ [2 integerp] ; root_x
+ [2 integerp] ; root_y
+ [2 integerp] ; event_x
+ [2 integerp] ; event_y
+ [2 integerp] ; state
+ [1 booleanp] ; same_screen
+ [1 nil] )
+ 4 ])
(X-Event-declare X-ButtonRelease
- [ "ButtonRelease"
- ( [1 integerp] ; button
- [2 integerp] ; sequence
- [4 integerp] ; time
- [4 :X-Win] ; root
- [4 :X-Win] ; event
- [4 :X-Win] ; child
- [2 integerp] ; root_x
- [2 integerp] ; root_y
- [2 integerp] ; event_x
- [2 integerp] ; event_y
- [2 integerp] ; state
- [1 booleanp] ; same_screen
- [1 nil] )
- 4 ])
+ [ "ButtonRelease"
+ ( [1 integerp] ; button
+ [2 integerp] ; sequence
+ [4 integerp] ; time
+ [4 :X-Win] ; root
+ [4 :X-Win] ; event
+ [4 :X-Win] ; child
+ [2 integerp] ; root_x
+ [2 integerp] ; root_y
+ [2 integerp] ; event_x
+ [2 integerp] ; event_y
+ [2 integerp] ; state
+ [1 booleanp] ; same_screen
+ [1 nil] )
+ 4 ])
(X-Event-define X-MotionNotify "xmotion" (nil nil time root event child root-x
root-y event-x event-y state same-screen)
- [ "MotionNotify"
- ( [1 integerp] ; detail
- [2 integerp] ; sequence
- [4 integerp] ; time
- [4 :X-Win] ; root
- [4 :X-Win] ; event
- [4 :X-Win] ; child
- [2 integerp] ; root_x
- [2 integerp] ; root_y
- [2 integerp] ; event_x
- [2 integerp] ; event_y
- [2 integerp] ; state
- [1 booleanp] ; same_screen
- [1 nil] )
- 4 ])
+ [ "MotionNotify"
+ ( [1 integerp] ; detail
+ [2 integerp] ; sequence
+ [4 integerp] ; time
+ [4 :X-Win] ; root
+ [4 :X-Win] ; event
+ [4 :X-Win] ; child
+ [2 integerp] ; root_x
+ [2 integerp] ; root_y
+ [2 integerp] ; event_x
+ [2 integerp] ; event_y
+ [2 integerp] ; state
+ [1 booleanp] ; same_screen
+ [1 nil] )
+ 4 ])
(X-Event-define X-EnterNotify "xcrossing" (nil nil time root event child
root-x root-y event-x event-y state mode same-screen-focus)
- [ "EnterNotify"
- ( [1 integerp] ; detail
- [2 integerp] ; sequence
- [4 integerp] ; time
- [4 :X-Win] ; root
- [4 :X-Win] ; event
- [4 :X-Win] ; child
- [2 integerp] ; root_x
- [2 integerp] ; root_y
- [2 integerp] ; event_x
- [2 integerp] ; event_y
- [2 integerp] ; state
- [1 integerp] ; mode
- [1 integerp]) ; same-screen, focus
- 4 ])
+ [ "EnterNotify"
+ ( [1 integerp] ; detail
+ [2 integerp] ; sequence
+ [4 integerp] ; time
+ [4 :X-Win] ; root
+ [4 :X-Win] ; event
+ [4 :X-Win] ; child
+ [2 integerp] ; root_x
+ [2 integerp] ; root_y
+ [2 integerp] ; event_x
+ [2 integerp] ; event_y
+ [2 integerp] ; state
+ [1 integerp] ; mode
+ [1 integerp]) ; same-screen, focus
+ 4 ])
(X-Event-declare X-LeaveNotify
- [ "LeaveNotify"
- ( [1 integerp] ; detail
- [2 integerp] ; sequence
- [4 integerp] ; time
- [4 :X-Win] ; root
- [4 :X-Win] ; event
- [4 :X-Win] ; child
- [2 integerp] ; root_x
- [2 integerp] ; root_y
- [2 integerp] ; event_x
- [2 integerp] ; event_y
- [2 integerp] ; state
- [1 integerp] ; mode
- [1 integerp] ) ; same-screen, focus
- 4 ])
+ [ "LeaveNotify"
+ ( [1 integerp] ; detail
+ [2 integerp] ; sequence
+ [4 integerp] ; time
+ [4 :X-Win] ; root
+ [4 :X-Win] ; event
+ [4 :X-Win] ; child
+ [2 integerp] ; root_x
+ [2 integerp] ; root_y
+ [2 integerp] ; event_x
+ [2 integerp] ; event_y
+ [2 integerp] ; state
+ [1 integerp] ; mode
+ [1 integerp] ) ; same-screen, focus
+ 4 ])
(X-Event-define X-FocusIn "xfocus" (nil nil event mode)
- [ "FocusIn"
- ( [1 integerp] ; detail
- [2 integerp] ; sequence
- [4 :X-Win] ; event
- [1 integerp] ; mode
- [23 nil] )
- 2 ])
+ [ "FocusIn"
+ ( [1 integerp] ; detail
+ [2 integerp] ; sequence
+ [4 :X-Win] ; event
+ [1 integerp] ; mode
+ [23 nil] )
+ 2 ])
(X-Event-declare X-FocusOut
- [ "FocusOut"
- ( [1 integerp] ; detail
- [2 integerp] ; sequence
- [4 :X-Win] ; event
- [1 integerp] ; mode
- [23 nil] )
- 2 ])
+ [ "FocusOut"
+ ( [1 integerp] ; detail
+ [2 integerp] ; sequence
+ [4 :X-Win] ; event
+ [1 integerp] ; mode
+ [23 nil] )
+ 2 ])
;; TODO: X-KeymapNotify
(X-Event-define X-Expose "xexpose" (nil nil window x y width height count)
- [ "Expose"
- ( [1 integerp] ; detail
- [2 integerp] ; sequence
- [4 :X-Win] ; window
- [2 integerp] ; x
- [2 integerp] ; y
- [2 integerp] ; width
- [2 integerp] ; height
- [2 integerp] ; count
- [14 nil] )
- 2 ])
+ [ "Expose"
+ ( [1 integerp] ; detail
+ [2 integerp] ; sequence
+ [4 :X-Win] ; window
+ [2 integerp] ; x
+ [2 integerp] ; y
+ [2 integerp] ; width
+ [2 integerp] ; height
+ [2 integerp] ; count
+ [14 nil] )
+ 2 ])
(X-Event-define X-GraphicsExpose "xgraphicsexpose" (nil nil drawable x y width
height minor-event count major-event)
- [ "GraphicsExpose"
- ([1 integerp]
- [2 integerp]
- [4 integerp] ; drawable
- [2 integerp] ; x
- [2 integerp] ; y
- [2 integerp] ; width
- [2 integerp] ; height
- [2 integerp] ; minorEvent
- [2 integerp] ; count
- [1 integerp] ; majorEvent
- [11 nil])
- 2 ])
+ [ "GraphicsExpose"
+ ([1 integerp]
+ [2 integerp]
+ [4 integerp] ; drawable
+ [2 integerp] ; x
+ [2 integerp] ; y
+ [2 integerp] ; width
+ [2 integerp] ; height
+ [2 integerp] ; minorEvent
+ [2 integerp] ; count
+ [1 integerp] ; majorEvent
+ [11 nil])
+ 2 ])
(X-Event-define X-NoExpose "xnoexpose" (nil nil drawable minor-event
major-event)
- [ "NoExpose"
- ([1 integerp]
- [2 integerp]
- [4 integerp] ; drawable
- [2 integerp] ; minorEvent
- [1 integerp] ; majorEvent
- [21 nil])
- 2 ])
+ [ "NoExpose"
+ ([1 integerp]
+ [2 integerp]
+ [4 integerp] ; drawable
+ [2 integerp] ; minorEvent
+ [1 integerp] ; majorEvent
+ [21 nil])
+ 2 ])
(X-Event-define X-VisibilityNotify "xvisibility" (nil nil window state)
- [ "VisibilityNotify"
- ([1 integerp]
- [2 integerp]
- [4 :X-Win] ; window
- [1 integerp] ; state
- [23 nil])
- 2 ])
+ [ "VisibilityNotify"
+ ([1 integerp]
+ [2 integerp]
+ [4 :X-Win] ; window
+ [1 integerp] ; state
+ [23 nil])
+ 2 ])
(X-Event-define X-CreateNotify "xcreatewindow" (nil nil parent window x y
width height border-width override)
- [ "CreateNotify"
- ([1 integerp] ; detail
- [2 integerp] ; sequence
- [4 :X-Win] ; parent window
- [4 :X-Win] ; window
- [2 integerp] ; x
- [2 integerp] ; y
- [2 integerp] ; width
- [2 integerp] ; height
- [2 integerp] ; border width
- [1 booleanp] ; override-redirect
- [9 nil])
- 2 ])
+ [ "CreateNotify"
+ ([1 integerp] ; detail
+ [2 integerp] ; sequence
+ [4 :X-Win] ; parent window
+ [4 :X-Win] ; window
+ [2 integerp] ; x
+ [2 integerp] ; y
+ [2 integerp] ; width
+ [2 integerp] ; height
+ [2 integerp] ; border width
+ [1 booleanp] ; override-redirect
+ [9 nil])
+ 2 ])
(X-Event-define X-DestroyNotify "xdestroywindow" (nil nil event window)
- [ "DestroyNotify"
- ( [1 integerp] ; detail
- [2 integerp] ; sequence
- [4 :X-Win] ; event window
- [4 :X-Win] ; window
- [20 nil])
- 3 ])
+ [ "DestroyNotify"
+ ( [1 integerp] ; detail
+ [2 integerp] ; sequence
+ [4 :X-Win] ; event window
+ [4 :X-Win] ; window
+ [20 nil])
+ 3 ])
(X-Event-define X-UnmapNotify "xunmap" (nil nil event window from-configure)
- [ "UnmapNotify"
- ( [1 integerp] ; detail
- [2 integerp] ; sequence
- [4 :X-Win] ; event
- [4 :X-Win] ; window
- [1 booleanp] ; fromconfigure
- [19 nil])
- 2 ])
+ [ "UnmapNotify"
+ ( [1 integerp] ; detail
+ [2 integerp] ; sequence
+ [4 :X-Win] ; event
+ [4 :X-Win] ; window
+ [1 booleanp] ; fromconfigure
+ [19 nil])
+ 2 ])
(X-Event-define X-MapNotify "xmap" (nil nil event window override)
- [ "MapNotify"
- ( [1 integerp] ; detail
- [2 integerp] ; sequence
- [4 :X-Win] ; event window
- [4 :X-Win] ; window
- [1 booleanp] ; override-redirect
- [19 nil])
- 2 ])
+ [ "MapNotify"
+ ( [1 integerp] ; detail
+ [2 integerp] ; sequence
+ [4 :X-Win] ; event window
+ [4 :X-Win] ; window
+ [1 booleanp] ; override-redirect
+ [19 nil])
+ 2 ])
(X-Event-define X-MapRequest "xmaprequest" (nil nil parent window)
- [ "MapRequest"
- ( [1 integerp] ; detail
- [2 integerp] ; sequence
- [4 :X-Win] ; parent window
- [4 :X-Win] ; window
- [20 nil])
- 2 ])
+ [ "MapRequest"
+ ( [1 integerp] ; detail
+ [2 integerp] ; sequence
+ [4 :X-Win] ; parent window
+ [4 :X-Win] ; window
+ [20 nil])
+ 2 ])
(X-Event-define X-ReparentNotify "xreparent" (nil nil event window parent x y
override)
- [ "ReparentNotify"
- ( [1 integerp] ; detail
- [2 integerp] ; sequence
- [4 :X-Win] ; event
- [4 :X-Win] ; window
- [4 :X-Win] ; parent
- [2 integerp] ; x
- [2 integerp] ; y
- [1 integerp] ; override
- [11 nil])
- 2 ])
+ [ "ReparentNotify"
+ ( [1 integerp] ; detail
+ [2 integerp] ; sequence
+ [4 :X-Win] ; event
+ [4 :X-Win] ; window
+ [4 :X-Win] ; parent
+ [2 integerp] ; x
+ [2 integerp] ; y
+ [1 integerp] ; override
+ [11 nil])
+ 2 ])
(X-Event-define X-ConfigureNotify "xconfigure" (nil nil event window
above-sibling x y width height border-width override-redirect)
- [ "ConfigureNotify"
- ( [1 integerp] ; detail
- [2 integerp] ; sequence
- [4 :X-Win] ; event
- [4 :X-Win] ; window
- [4 :X-Win] ; above-sibling
- [2 integerp] ; x
- [2 integerp] ; y
- [2 integerp] ; width
- [2 integerp] ; height
- [2 integerp] ; border-width
- [1 booleanp] ; override-redirect
- [5 nil] )
- 2 ])
+ [ "ConfigureNotify"
+ ( [1 integerp] ; detail
+ [2 integerp] ; sequence
+ [4 :X-Win] ; event
+ [4 :X-Win] ; window
+ [4 :X-Win] ; above-sibling
+ [2 integerp] ; x
+ [2 integerp] ; y
+ [2 integerp] ; width
+ [2 integerp] ; height
+ [2 integerp] ; border-width
+ [1 booleanp] ; override-redirect
+ [5 nil] )
+ 2 ])
(X-Event-define X-ConfigureRequest "xconfigurerequest" (stackmode nil parent
window sibling x y width height border-width value-mask)
- [ "ConfigureRequest"
- ( [1 integerp] ; detail
- [2 integerp] ; sequence
- [4 :X-Win] ; parent window
- [4 :X-Win] ; window
- [4 :X-Win] ; sibling
- [2 integerp] ; x
- [2 integerp] ; y
- [2 integerp] ; width
- [2 integerp] ; height
- [2 integerp] ; border width
- [2 integerp] ; value mask
- [4 nil])
- 2 ])
+ [ "ConfigureRequest"
+ ( [1 integerp] ; detail
+ [2 integerp] ; sequence
+ [4 :X-Win] ; parent window
+ [4 :X-Win] ; window
+ [4 :X-Win] ; sibling
+ [2 integerp] ; x
+ [2 integerp] ; y
+ [2 integerp] ; width
+ [2 integerp] ; height
+ [2 integerp] ; border width
+ [2 integerp] ; value mask
+ [4 nil])
+ 2 ])
(X-Event-define X-GravityNotify "xgravity" (nil nil event window x y)
- [ "GravityNotify"
- ([1 integerp]
- [2 integerp]
- [4 :X-Win] ; event window
- [4 :X-Win] ; window
- [2 integerp] ; x
- [2 integerp] ; y
- [16 nil])
- 2 ])
+ [ "GravityNotify"
+ ([1 integerp]
+ [2 integerp]
+ [4 :X-Win] ; event window
+ [4 :X-Win] ; window
+ [2 integerp] ; x
+ [2 integerp] ; y
+ [16 nil])
+ 2 ])
(X-Event-define X-ResizeRequest "xresizerequest" (nil nil window width height)
- [ "ResizeRequest"
- ( [1 integerp] ; detail
- [2 integerp] ; sequence
- [4 :X-Win] ; window
- [2 integerp] ; width
- [2 integerp] ; height
- [20 nil] )
- 2 ])
+ [ "ResizeRequest"
+ ( [1 integerp] ; detail
+ [2 integerp] ; sequence
+ [4 :X-Win] ; window
+ [2 integerp] ; width
+ [2 integerp] ; height
+ [20 nil] )
+ 2 ])
(X-Event-define X-CirculateNotify "xcirculate" (nil nil event window parent
place)
- [ "CirculateNotify"
- ([1 integerp]
- [2 integerp]
- [4 :X-Win] ; event window
- [4 :X-Win] ; window
- [4 :X-Win] ; parent
- [1 integerp] ; place
- [15 nil])
- 2 ])
+ [ "CirculateNotify"
+ ([1 integerp]
+ [2 integerp]
+ [4 :X-Win] ; event window
+ [4 :X-Win] ; window
+ [4 :X-Win] ; parent
+ [1 integerp] ; place
+ [15 nil])
+ 2 ])
;; The event field in the xcirculate record is really the parent when this
;; is used as a CirculateRequest instead of a CircluateNotify
(X-Event-declare X-CirculateRequest
- [ "CirculateRequest"
- ([1 integerp]
- [2 integerp]
- [4 :X-Win] ; event window
- [4 :X-Win] ; window
- [4 :X-Win] ; parent
- [1 integerp] ; place
- [15 nil])
- 2 ])
+ [ "CirculateRequest"
+ ([1 integerp]
+ [2 integerp]
+ [4 :X-Win] ; event window
+ [4 :X-Win] ; window
+ [4 :X-Win] ; parent
+ [1 integerp] ; place
+ [15 nil])
+ 2 ])
(X-Event-define X-PropertyNotify "xproperty" (nil nil window atom time state)
- [ "PropertyNotify"
- ( [1 integerp]
- [2 integerp]
- [4 :X-Win] ; window
- [4 :X-Atom] ; atom
- [4 integerp] ; time
- [1 integerp] ; state
- [15 nil]
- ) 2 ])
+ [ "PropertyNotify"
+ ( [1 integerp]
+ [2 integerp]
+ [4 :X-Win] ; window
+ [4 :X-Atom] ; atom
+ [4 integerp] ; time
+ [1 integerp] ; state
+ [15 nil]
+ ) 2 ])
(X-Event-define X-SelectionClear "xselectionclear" (nil nil time window atom)
- [ "SelectionClear"
- ([1 integerp]
- [2 integerp]
- [4 integerp] ; time
- [4 :X-Win] ; window
- [4 :X-Atom] ; atom
- [16 nil])
- 3 ])
+ [ "SelectionClear"
+ ([1 integerp]
+ [2 integerp]
+ [4 integerp] ; time
+ [4 :X-Win] ; window
+ [4 :X-Atom] ; atom
+ [16 nil])
+ 3 ])
(X-Event-define X-SelectionRequest "xselectionrequest" (nil nil time owner
requestor selection target property)
- [ "SelectionRequest"
- ([1 integerp]
- [2 integerp]
- [4 integerp] ; time
- [4 :X-Win] ; owner
- [4 :X-Win] ; requestor
- [4 :X-Atom] ; selection atom
- [4 :X-Atom] ; target atom
- [4 :X-Atom] ; property atom
- [4 nil])
- 4 ])
+ [ "SelectionRequest"
+ ([1 integerp]
+ [2 integerp]
+ [4 integerp] ; time
+ [4 :X-Win] ; owner
+ [4 :X-Win] ; requestor
+ [4 :X-Atom] ; selection atom
+ [4 :X-Atom] ; target atom
+ [4 :X-Atom] ; property atom
+ [4 nil])
+ 4 ])
(X-Event-define X-SelectionNotify "xselection" (nil nil time requestor
selection target property)
- [ "SelectionNotify"
- ([1 integerp]
- [2 integerp]
- [4 integerp] ; time
- [4 :X-Win] ; requestor
- [4 :X-Atom] ; selection atom
- [4 :X-Atom] ; target atom
- [4 :X-Atom] ; property atom
- [8 nil])
- 3 ])
+ [ "SelectionNotify"
+ ([1 integerp]
+ [2 integerp]
+ [4 integerp] ; time
+ [4 :X-Win] ; requestor
+ [4 :X-Atom] ; selection atom
+ [4 :X-Atom] ; target atom
+ [4 :X-Atom] ; property atom
+ [8 nil])
+ 3 ])
(X-Event-define X-ColormapNotify "xcolormap" (nil nil window colormap new
state)
- [ "ColormapNotify"
- ([1 integerp] ; detail
- [2 integerp] ; sequence
- [4 :X-Win] ; window
- [4 integerp] ; colormap
- [1 booleanp] ; new
- [1 booleanp] ; state
- [18 nil])
- 2 ])
+ [ "ColormapNotify"
+ ([1 integerp] ; detail
+ [2 integerp] ; sequence
+ [4 :X-Win] ; window
+ [4 integerp] ; colormap
+ [1 booleanp] ; new
+ [1 booleanp] ; state
+ [18 nil])
+ 2 ])
(X-Event-define X-ClientMessage "xclient" (nil window atom msg)
- [ "ClientMessage"
- ([1 length-1] ; format
- [2 integerp] ; sequence number
- [4 :X-Win] ; window
- [4 :X-Atom] ; atom
- ;; This reads in the correct number of integers of a type
- ;; specified by the format which is 8, 16, or 32.
- [(/ 20 (/ length-1 8)) ( [ (/ length-1 8) integerp ] ) ] )
- 1 ])
+ [ "ClientMessage"
+ ([1 length-1] ; format
+ [2 integerp] ; sequence number
+ [4 :X-Win] ; window
+ [4 :X-Atom] ; atom
+ ;; This reads in the correct number of integers of a type
+ ;; specified by the format which is 8, 16, or 32.
+ [(/ 20 (/ length-1 8)) ( [ (/ length-1 8) integerp ] ) ] )
+ 1 ])
(X-Event-define X-MappingNotify "xmapping" (nil nil request first-keycode
count)
- [ "MappingNotify"
- ([1 integerp]
- [2 integerp]
- [1 integerp] ; request
- [1 integerp] ; firstKeyCode
- [1 integerp] ; count
- [25 nil])
- nil ])
+ [ "MappingNotify"
+ ([1 integerp]
+ [2 integerp]
+ [1 integerp] ; request
+ [1 integerp] ; firstKeyCode
+ [1 integerp] ; count
+ [25 nil])
+ nil ])
;; error event
(X-Event-define 0 "xerror" (code nil resourceid min-op maj-op)
- ["XError"
- ([1 integerp] ; err code
- [2 integerp] ; sequence
- [4 integerp] ; id
- [2 integerp] ; minor opcode
- [1 integerp] ; major opcode
- [21 nil])])
-
+ ["XError"
+ ([1 integerp] ; err code
+ [2 integerp] ; sequence
+ [4 integerp] ; id
+ [2 integerp] ; minor opcode
+ [1 integerp] ; major opcode
+ [21 nil])])
+
;;; All receive message types will exclude the first byte which IDs it.
;;
;; a symbol gets 'set, functions such as integerp mean turn it into that,
@@ -685,74 +685,74 @@
(defconst X-connect-response
(list [1 success]
- (list [1 length-1] ; fail message len
- [2 integerp] ; major version
- [2 integerp] ; minor version
- [2 length-2] ; pad length
- [length-1 stringp] ; error conditions
- [(X-mod-4 length-1) nil] ; padding
- )
- (list [1 nil] ; successful list (this is unused)
- [2 integerp] ; major version
- [2 integerp] ; minor version
- [2 length-1] ; len additional data (pad)
- [4 integerp] ; release number
- [4 integerp] ; resource id base
- [4 integerp] ; resource id mask
- [4 integerp] ; motion buffer size
- [2 length-2] ; vendor length
- [2 integerp] ; max request len
- [1 length-4] ; number of screens
- [1 length-3] ; number of formats in pix list
- [1 integerp] ; image byte order
- [1 integerp] ; bitmap byte order
- [1 integerp] ; bitmap format scanline thingy
- [1 integerp] ; bitmap format scanline pad
- [1 integerp] ; min keycode
- [1 integerp] ; max keycode
- [4 nil] ; unused
- [length-2 stringp] ; the vendor
- [(X-mod-4 length-2) nil] ; padding
- [length-3 ; sublist of formats
- ( [1 integerp] ; depth
- [1 integerp] ; bits/pixel
- [1 integerp] ; scanline-pad
- [5 nil] ) ] ; padding
- [length-4
- ( [4 integerp] ; root window
- [4 integerp] ; colormap
- [4 integerp] ; white-pixel
- [4 integerp] ; black-pixel
- [4 integerp] ; event-flags
- [2 integerp] ; screen-width
- [2 integerp] ; screen-height
- [2 integerp] ; milimeters width
- [2 integerp] ; milimeters height
- [2 integerp] ; min-installed-maps
- [2 integerp] ; max installed maps
- [4 integerp] ; visualid
- [1 integerp] ; backingstores
- [1 booleanp] ; save-unders
- [1 integerp] ; root depth
- [1 length-1] ; # depths in depth
- [length-1 ; list of depths
- ( [1 integerp] ; depth
- [1 nil]
- [2 length-1] ; # visual types
- [4 nil]
- [length-1 ; the visuals
- ( [4 integerp] ; visual id
- [1 integerp] ; class
- [1 integerp] ; bits/rgb value
- [2 integerp] ; colormap entities
- [4 integerp] ; red mask
- [4 integerp] ; green mask
- [4 integerp] ; blue mask
- [4 nil])
- ] )
- ] )
- ] )
- )
+ (list [1 length-1] ; fail message len
+ [2 integerp] ; major version
+ [2 integerp] ; minor version
+ [2 length-2] ; pad length
+ [length-1 stringp] ; error conditions
+ [(X-mod-4 length-1) nil] ; padding
+ )
+ (list [1 nil] ; successful list (this is unused)
+ [2 integerp] ; major version
+ [2 integerp] ; minor version
+ [2 length-1] ; len additional data (pad)
+ [4 integerp] ; release number
+ [4 integerp] ; resource id base
+ [4 integerp] ; resource id mask
+ [4 integerp] ; motion buffer size
+ [2 length-2] ; vendor length
+ [2 integerp] ; max request len
+ [1 length-4] ; number of screens
+ [1 length-3] ; number of formats in pix list
+ [1 integerp] ; image byte order
+ [1 integerp] ; bitmap byte order
+ [1 integerp] ; bitmap format scanline thingy
+ [1 integerp] ; bitmap format scanline pad
+ [1 integerp] ; min keycode
+ [1 integerp] ; max keycode
+ [4 nil] ; unused
+ [length-2 stringp] ; the vendor
+ [(X-mod-4 length-2) nil] ; padding
+ [length-3 ; sublist of formats
+ ( [1 integerp] ; depth
+ [1 integerp] ; bits/pixel
+ [1 integerp] ; scanline-pad
+ [5 nil] ) ] ; padding
+ [length-4
+ ( [4 integerp] ; root window
+ [4 integerp] ; colormap
+ [4 integerp] ; white-pixel
+ [4 integerp] ; black-pixel
+ [4 integerp] ; event-flags
+ [2 integerp] ; screen-width
+ [2 integerp] ; screen-height
+ [2 integerp] ; milimeters width
+ [2 integerp] ; milimeters height
+ [2 integerp] ; min-installed-maps
+ [2 integerp] ; max installed maps
+ [4 integerp] ; visualid
+ [1 integerp] ; backingstores
+ [1 booleanp] ; save-unders
+ [1 integerp] ; root depth
+ [1 length-1] ; # depths in depth
+ [length-1 ; list of depths
+ ( [1 integerp] ; depth
+ [1 nil]
+ [2 length-1] ; # visual types
+ [4 nil]
+ [length-1 ; the visuals
+ ( [4 integerp] ; visual id
+ [1 integerp] ; class
+ [1 integerp] ; bits/rgb value
+ [2 integerp] ; colormap entities
+ [4 integerp] ; red mask
+ [4 integerp] ; green mask
+ [4 integerp] ; blue mask
+ [4 nil])
+ ] )
+ ] )
+ ] )
+ )
"Connection response structure.")
(defun X-invalidate-cl-struct (cl-x)
@@ -779,15 +779,12 @@
(defun X-Dpy-send-read (xdpy s rf)
"Send S to display XDPY and receive answer according to receive fields RF."
- ;; Can't read while already reading! --lg
- (when (zerop (X-Dpy-readings xdpy))
- (let ((reqid (X-Dpy-rseq-id xdpy))) ; Remember request id
+ (let ((reqid (X-Dpy-rseq-id xdpy))) ; Remember request id
+ (X-Dpy-read-excursion xdpy
;; Flush output buffer
(X-Dpy-send xdpy s)
(X-Dpy-send-flush xdpy)
-
- (X-Dpy-read-excursion xdpy
- (X-Dpy-parse-message rf reqid xdpy)))))
+ (X-Dpy-parse-message rf reqid xdpy))))
;;;###autoload
(defvar X-default-timeout 60
@@ -802,14 +799,14 @@
(while (< (length (X-Dpy-message-buffer xdpy)) num)
(when (null (accept-process-output (X-Dpy-proc xdpy)
(or to-secs X-default-timeout) (or
to-msecs 0)))
- ;; Timeouted
- (error "X: Timeout while reading from server.")))
+ ;; Timeouted
+ (error "X: Timeout while reading from server.")))
(setq rstr (substring (X-Dpy-message-buffer xdpy) 0 num)) ; save bytes to
string
;; Update message-buffer
(setf (X-Dpy-message-buffer xdpy)
- (substring (X-Dpy-message-buffer xdpy) num))
+ (substring (X-Dpy-message-buffer xdpy) num))
rstr))
;; These are defined so we can use them recursivly below
@@ -855,184 +852,270 @@
(let ((inhibit-quit t) ; so C-g will not desync
(rlist nil)
- (reverse-me t)
- (length-1 (if (boundp 'length-1) length-1 nil))
- (length-2 (if (boundp 'length-2) length-2 nil))
- (length-3 (if (boundp 'length-3) length-3 nil))
- (length-4 (if (boundp 'length-4) length-4 nil)) )
+ (reverse-me t)
+ (length-1 (if (boundp 'length-1) length-1 nil))
+ (length-2 (if (boundp 'length-2) length-2 nil))
+ (length-3 (if (boundp 'length-3) length-3 nil))
+ (length-4 (if (boundp 'length-4) length-4 nil)) )
(while (and message-s (listp message-s))
(let* ((tvec (car message-s))
- (tlen (aref tvec 0))
- (tval1 (aref tvec 1))
- (tval (if (and (listp tval1)
- (member (car tval1) '(or if cond))) ;XXX
- (eval tval1)
- tval1))
- (result (unless (and tval (listp tval))
- ;; Do not grab bytes for sub-lists
- (if (or (symbolp tlen) (listp tlen))
- (X-Dpy-grab-bytes xdpy (eval tlen))
- (X-Dpy-grab-bytes xdpy tlen)))))
-
- ;; We need to put in code to represent sizes sometimes,
- ;; this will get that size.
- (when (or (listp tlen) (symbolp tlen))
- (setq tlen (eval tlen)))
-
- ;; Check for use of an argument.
- (when (equal tval 'arg)
- (setq tval (car arglist))
- (setq arglist (cdr arglist)))
-
- ;; If the val is a list, and it is an if statement, then
- ;; we want to evaluate it to get the real tval type.
- (when (and (listp tval)
- (member (car tval) '(if or make-list)))
- (setq tval (eval tval)))
-
- (cond
- ;; boolean success stories.
- ((equal tval 'success)
- (let ((sublst
- (cond ((= (aref result 0) 1)
- ;; success condition
- (setq result t)
- (X-Dpy-parse-message (car (cdr (cdr message-s))) req-id
xdpy arglist))
-
- (t
- ;; Here is event or error arrived, process
- ;; errors in time or store event in events
- ;; queue.
- (let ((need-processing t)
+ (tlen (aref tvec 0))
+ (tval1 (aref tvec 1))
+ (tval (if (and (listp tval1)
+ (member (car tval1) '(or if cond))) ;XXX
+ (eval tval1)
+ tval1))
+ (result (unless (and tval (listp tval))
+ ;; Do not grab bytes for sub-lists
+ (if (or (symbolp tlen) (listp tlen))
+ (X-Dpy-grab-bytes xdpy (eval tlen))
+ (X-Dpy-grab-bytes xdpy tlen)))))
+
+ ;; We need to put in code to represent sizes sometimes,
+ ;; this will get that size.
+ (when (or (listp tlen) (symbolp tlen))
+ (setq tlen (eval tlen)))
+
+ ;; Check for use of an argument.
+ (when (equal tval 'arg)
+ (setq tval (car arglist))
+ (setq arglist (cdr arglist)))
+
+ ;; If the val is a list, and it is an if statement, then
+ ;; we want to evaluate it to get the real tval type.
+ (when (and (listp tval)
+ (member (car tval) '(if or make-list)))
+ (setq tval (eval tval)))
+
+ (cond
+ ;; boolean success stories.
+ ((equal tval 'success)
+ (let ((sublst
+ (cond ((= (aref result 0) 1)
+ ;; success condition
+ (setq result t)
+ (X-Dpy-parse-message (car (cdr (cdr message-s)))
+ req-id xdpy arglist))
+
+ (t
+ ;; Here is event or error arrived, process
+ ;; errors in time or store event in events
+ ;; queue.
+ (X-Dpy-log xdpy 'x-event "!!: Evaluating event ..")
+ (let ((xev (X-Dpy-parse-event
+ xdpy (Xforcenum (aref result 0))))
pmsg)
- (X-Dpy-log xdpy 'x-error "!::: %d bytes pending ..
need to process %S request"
- '(length (X-Dpy-message-buffer xdpy))
'message-s)
- (condition-case xerr
- (X-Dpy-parse-event xdpy (Xforcenum (aref result
0)))
- (X-Error
- ;; Here is if error's sequence numbers matches
- ;; with last request sequence, then end response
- ;; evaluating.
- (X-Dpy-log xdpy 'x-error "Get ERROR seq: %d,
rseq-id: %d"
- '(X-Event-seq (cadr xerr)) 'req-id)
- (X-Dpy-log xdpy 'x-error "%d bytes pending ..
need to process %S request"
- '(length (X-Dpy-message-buffer xdpy))
'message-s)
- (when (= (X-Event-seq (cadr xerr)) (logand req-id
65535))
- (setq result nil
- need-processing nil)))
- (t (apply 'error (car xerr) (cdr xerr))))
-
- ;; Repeat processing XXX excluding t or nil
- (if (not need-processing)
- (setq result nil)
- (setq pmsg (X-Dpy-parse-message message-s req-id
xdpy arglist)
- result (car pmsg))
- (cdr pmsg))))
- )))
- (setq rlist (cons result sublst)))
-
- (setq message-s nil)
- (setq reverse-me nil))
-
- ;; numberp means natural number, not safe!
- ((eq tval 'numberp)
- (setq rlist (cons (funcall (if (<= tlen 2)
- 'string2->number
- 'string4->number) result)
- rlist)))
-
- ;; integerp means tac onto end of list as an int
- ((eq tval 'integerp)
- (if (<= tlen 2)
- (setq rlist (cons (string->int result) rlist))
- (setq rlist (cons (string4->int result) rlist))))
-
- ;; stringp means tac onto end of list as string (verbatim)
- ((eq tval 'stringp)
- (setq rlist (cons result rlist)))
-
- ;; booleans don't really exist, but turn a 0 into nil, and 1 into t
- ((eq tval 'booleanp)
- (setq rlist (cons (if (= 0 (string->int result)) nil t) rlist)))
-
- ;; TODO: maybe add card8, card16, card32, int8, int16, int32,
- ;; string8, string16, etc?
-
- ;; Special forms
- ((eq tval :X-Rect)
- (setq tlen (/ tlen 8))
- (while (> tlen 0)
- (setq rlist (cons (make-X-Rect :x (string->int (substring result 0
2))
- :y (string->int (substring result 2
4))
- :width (string->int (substring
result 4 6))
- :height (string->int (substring
result 6 8)))
- rlist))
- (setq result (substring result 8))
- (setq tlen (1- tlen))))
-
- ((eq tval :X-Win)
- (setq tlen (/ tlen 4))
- (while (> tlen 0)
- (setq rlist (cons (X-Win-find-or-make xdpy (string4->int result))
- rlist))
- (setq result (substring result 4))
- (setq tlen (1- tlen))))
-
- ((eq tval :X-Atom)
- (setq tlen (/ tlen 4))
- (while (> tlen 0)
- (setq rlist (cons (X-Atom-find-or-make xdpy (string4->int result))
- rlist))
- (setq result (substring result 4))
- (setq tlen (1- tlen))))
-
- ;; if it is a list, then we need to recursivly call ourselvs X
- ;; times on it.
- ((and tval (listp tval))
- ;; WARNING: subparts cannot use args. ;(
- (let ((sublst nil))
- (while (> tlen 0)
- (setq sublst (cons (X-Dpy-parse-message tval req-id xdpy arglist)
sublst))
- (setq tlen (1- tlen)))
- ;; The sub-list of items is backwards: fix
- (setq rlist (cons (nreverse sublst) rlist))))
-
- ;; not a type, but some other symbol, then put it there!
- ;; if it is one of the lengththings, intify it.
- ((and tval (symbolp tval) (not (keywordp tval)))
- (if (string-match "length" (symbol-name tval))
- (set tval (string->int result))
- (set tval result)))
-
- ;; do nothing
- ((equal tval nil))
-
- ;; error case.
- (t
- (error "Error parsing X response!!!"))))
+ (prog1
+ (if (and (= (X-Event-type xev) 0)
+ (= (X-Event-seq xev)
+ (logand req-id 65535)))
+ ;; Error of current request
+ (setq result nil)
+
+ ;; Repeat processing XXX excluding t or nil
+ (X-Dpy-log xdpy 'x-event "!!: Reprocessing: %d
bytes pending\n"
+ '(length (X-Dpy-message-buffer
xdpy)))
+ (setq pmsg (X-Dpy-parse-message
+ message-s req-id xdpy arglist)
+ result (car pmsg))
+ (X-Dpy-log xdpy 'x-event "!!: Reprocessing
done .")
+ (cdr pmsg))
+ (X-Dpy-dispatch-event xev)))))))
+ (setq rlist (cons result sublst)))
+
+ (setq message-s nil)
+ (setq reverse-me nil))
+
+ ;; numberp means natural number, not safe!
+ ((eq tval 'numberp)
+ (setq rlist (cons (funcall (if (<= tlen 2)
+ 'string2->number
+ 'string4->number) result)
+ rlist)))
+
+ ;; integerp means tac onto end of list as an int
+ ((eq tval 'integerp)
+ (if (<= tlen 2)
+ (setq rlist (cons (string->int result) rlist))
+ (setq rlist (cons (string4->int result) rlist))))
+
+ ;; stringp means tac onto end of list as string (verbatim)
+ ((eq tval 'stringp)
+ (setq rlist (cons result rlist)))
+
+ ;; booleans don't really exist, but turn a 0 into nil, and 1 into t
+ ((eq tval 'booleanp)
+ (setq rlist (cons (if (= 0 (string->int result)) nil t) rlist)))
+
+ ;; TODO: maybe add card8, card16, card32, int8, int16, int32,
+ ;; string8, string16, etc?
+
+ ;; Special forms
+ ((eq tval :X-Rect)
+ (setq tlen (/ tlen 8))
+ (while (> tlen 0)
+ (setq rlist (cons (make-X-Rect :x (string->int (substring result 0
2))
+ :y (string->int (substring result 2
4))
+ :width (string->int (substring
result 4 6))
+ :height (string->int (substring
result 6 8)))
+ rlist))
+ (setq result (substring result 8))
+ (setq tlen (1- tlen))))
+
+ ((eq tval :X-Win)
+ (setq tlen (/ tlen 4))
+ (while (> tlen 0)
+ (setq rlist (cons (X-Win-find-or-make xdpy (string4->int result))
+ rlist))
+ (setq result (substring result 4))
+ (setq tlen (1- tlen))))
+
+ ((eq tval :X-Atom)
+ (setq tlen (/ tlen 4))
+ (while (> tlen 0)
+ (setq rlist (cons (X-Atom-find-or-make xdpy (string4->int result))
+ rlist))
+ (setq result (substring result 4))
+ (setq tlen (1- tlen))))
+
+ ;; if it is a list, then we need to recursivly call ourselvs X
+ ;; times on it.
+ ((and tval (listp tval))
+ ;; WARNING: subparts cannot use args. ;(
+ (let ((sublst nil))
+ (while (> tlen 0)
+ (setq sublst (cons (X-Dpy-parse-message tval req-id xdpy
arglist) sublst))
+ (setq tlen (1- tlen)))
+ ;; The sub-list of items is backwards: fix
+ (setq rlist (cons (nreverse sublst) rlist))))
+
+ ;; not a type, but some other symbol, then put it there!
+ ;; if it is one of the lengththings, intify it.
+ ((and tval (symbolp tval) (not (keywordp tval)))
+ (if (string-match "length" (symbol-name tval))
+ (set tval (string->int result))
+ (set tval result)))
+
+ ;; do nothing
+ ((equal tval nil))
+
+ ;; error case.
+ (t
+ (error "Error parsing X response!!!"))))
(setq message-s (cdr message-s)))
;; Now that that is over, conditionally reverse the list.
(if reverse-me
- (nreverse rlist)
+ (nreverse rlist)
rlist)))
(defun X-Dpy-eval-error-or-event (xdpy)
"There data on XDPY, it is error or event."
(X-Dpy-read-excursion xdpy
(let* ((result (X-Dpy-grab-bytes xdpy 1))
- (evetype (Xforcenum (aref result 0))))
+ (evetype (Xforcenum (aref result 0))))
- (cond ((= evetype 1) ; reply, should not happen
- (X-Dpy-log xdpy 'x-error "Got unknown reply, while expecting
XEvent! CRITICAL!")
+ (cond ((= evetype 1) ; reply, should not happen
+ (X-Dpy-log xdpy 'x-error "Got unknown reply, while expecting
XEvent! CRITICAL!")
(error "Got unknown reply, while expecting XEvent!"))
- ((>= evetype X-MaxEvent)
- (X-Dpy-log xdpy 'x-error "Got XEvent id greater than X-MaxEvent!
CRITICAL!")
- (error (format "Got X Event id(%d) greater than X-MaxEvent!"
evetype)))
- (t (X-Dpy-parse-event xdpy evetype))) ; error or event
+ ;; Below code is not quite correct. Because X exntensions
+ ;; that generates events may use values greater then
+ ;; X-MaxEvent.
+; ((>= evetype X-MaxEvent)
+; (X-Dpy-log xdpy 'x-error "Got XEvent id(%d) greater than
X-MaxEvent! CRITICAL!"
+; 'evetype)
+; (error (format "Got X Event id(%d) greater than X-MaxEvent!"
evetype)))
+ (t (X-Dpy-dispatch-event
+ (X-Dpy-parse-event xdpy evetype)))) ; error or event
)))
;; Events/Errors dispatchers
+(defvar xlib-opcodes-alist
+ '((104 . XBell)
+ (1 . XCreateWindow)
+ (2 . XChangeWindowAttributes)
+ (3 . XGetWindowAttributes)
+ (12 . XConfigureWindow)
+ (8 . XMapWindow)
+ (10 . XUnmapWindow)
+ (4 . XDestroyWindow)
+ (5 . XDestroySubwindows)
+ (15 . XQueryTree)
+ (16 . XInternAtom)
+ (17 . XGetAtomName)
+ (18 . XChangeProperty)
+ (20 . XGetWindowProperty)
+ (78 . XCreateColormap)
+ (79 . XFreeColormap)
+ (84 . XAllocColor)
+ (85 . XAllocNamedColor)
+ (86 . XAllocColorCells)
+ (89 . XStoreColors)
+ (88 . XFreeColors)
+ (91 . XQueryColors)
+ (55 . XCreateGC)
+ (56 . XChangeGC)
+ (58 . XSetDashes)
+ (59 . XSetClipRectangles)
+ (60 . XFreeGC)
+ (61 . XClearArea)
+ (62 . XCopyArea)
+ (63 . XCopyPlane)
+ (64 . XDrawPoints)
+ (65 . XDrawLines)
+ (69 . XFillPoly)
+ (66 . XDrawSegments)
+ (67 . XDrawRectangles)
+ (70 . XDrawRectangles)
+ (68 . XDrawArcs)
+ (71 . XDrawArcs)
+ (74 . XDrawString)
+ (76 . XImageString)
+ (72 . XPutImage)
+ (73 . XGetImage)
+ (22 . XSetSelectionOwner)
+ (23 . XGetSelectionOwner)
+ (24 . XConvertSelection)
+ (41 . XWarpPointer)
+ (36 . XGrabServer)
+ (37 . XUngrabServer)
+ (38 . XQueryPointer)
+ (31 . XGrabKeyboard)
+ (32 . XUngrabKeyboard)
+ (26 . XGrabPointer)
+ (27 . XUngrabPointer)
+ (28 . XGrabButton)
+ (29 . XUngrabButton)
+ (33 . XGrabKey)
+ (34 . XUngrabKey)
+ (43 . XGetInputFocus)
+ (42 . XSetInputFocus)
+ (7 . XReparentWindow)
+ (14 . XGetGeometry)
+ (40 . XTranslateCoordinates)
+ (6 . XChangeSaveSet)
+ (25 . XSendEvent)
+ (44 . XQueryKeymap)
+ (101 . XGetKeyboardMapping)
+ (119 . XGetModifierMapping)
+ (45 . XOpenFont)
+ (47 . XQueryFont)
+ (48 . XQueryTextExtents)
+ (53 . XCreatePixmap)
+ (54 . XFreePixmap)
+ (93 . XCreateCursor)
+ (94 . XCreateGlyphCursor)
+ (95 . XFreeCursor)
+ (96 . XRecolorCursor)
+ (30 . XChangeActivePointerGrab)
+ (98 . XQueryExtension)
+ (107 . XSetScreenSaver)
+ (108 . XGetScreenSaver)
+ (113 . XKillClient)
+ (115 . XForceScreenSaver))
+ "Alist of X opcodes in form (OPCODE . FUNCTION).
+This is only informative variable.")
+
(defun X-Dpy-run-error-hooks (xdpy xev)
"Run XDPY's error hooks."
(when (X-Dpy-error-hooks xdpy)
@@ -1042,51 +1125,43 @@
(defun X-Dpy-error-dispatch (xev)
"Dispatch error event XEV."
- (let ((xdpy (X-Event-dpy xev)))
- (cond ((= (X-Event-xerror-code xev) 2)
- (X-Dpy-log xdpy 'x-error "Bad value %s sequence %d ops %d %d"
- '(Xmask-string (X-Event-xerror-resourceid xev))
- '(X-Event-seq xev)
- '(X-Event-xerror-maj-op xev)
- '(X-Event-xerror-min-op xev)))
-
- ((= (X-Event-xerror-code xev) 3)
- (X-Dpy-log xdpy 'x-error "Bad window %.0f sequence %d ops %d %d"
- '(X-Event-xerror-resourceid xev)
- '(X-Event-seq xev)
- '(X-Event-xerror-maj-op xev)
- '(X-Event-xerror-min-op xev)))
- ((= (X-Event-xerror-code xev) 9)
- (X-Dpy-log xdpy 'x-error "Bad Drawable %.0f sequence %d ops %d %d"
- '(X-Event-xerror-resourceid xev)
- '(X-Event-seq xev)
- '(X-Event-xerror-maj-op xev)
- '(X-Event-xerror-min-op xev)))
-
- ((= (X-Event-xerror-code xev) 11)
- (X-Dpy-log xdpy 'x-error "Alloc failure id=%.0f"
'(X-Event-xerror-resourceid xev)))
-
- ((= (X-Event-xerror-code xev) 14)
- (X-Dpy-log xdpy 'x-error "Bad id %s sequence %d ops %d %d"
- '(Xmask-string (X-Event-xerror-resourceid xev))
- '(X-Event-seq xev)
- '(X-Event-xerror-maj-op xev)
- '(X-Event-xerror-min-op xev)))
-
- ((= (X-Event-xerror-code xev) 16)
- (X-Dpy-log xdpy 'x-error "Length error! sequence %d ops %d %d"
- '(X-Event-seq xev)
- '(X-Event-xerror-maj-op xev)
- '(X-Event-xerror-min-op xev)))
-
- (t
- (X-Dpy-log xdpy 'x-error "Got error event %d!!!"
'(X-Event-xerror-code xev))))
+ (let* ((xdpy (X-Event-dpy xev))
+ (err (X-Event-xerror-code xev))
+ (badth (X-Event-xerror-resourceid xev))
+ (seq (X-Event-seq xev))
+ (maj (X-Event-xerror-maj-op xev))
+ (opfun (cdr (assq maj xlib-opcodes-alist)))
+ (min (X-Event-xerror-min-op xev))
+ (bstr (cond ((= err 1) "Request")
+ ((= err 2) "Value")
+ ((= err 3) "Window")
+ ((= err 4) "Pixmap")
+ ((= err 5) "Atom")
+ ((= err 6) "Cursor")
+ ((= err 7) "Font")
+ ((= err 8) "Match")
+ ((= err 9) "Drawable")
+ ((= err 10) "Access")
+ ((= err 11) "Alloc")
+ ((= err 12) "Color")
+ ((= err 13) "GC")
+ ((= err 14) "IDChoice")
+ ((= err 15) "Name")
+ ((= err 16) "Length")
+ ((= err 17) "Implementation")
+ ((= err 128) "FirstExtension")
+ ((= err 255) "LastExtension")
+ (t "Unknown"))))
+ (declare (special bstr))
+ (declare (special min))
+ (declare (special opfun))
+ (declare (special seq))
+ (declare (special badth))
+ (X-Dpy-log xdpy 'x-error "X-Error: Bad %s %f seq=%f:%d ops=%d:%d/%S"
+ 'bstr 'badth 'seq '(X-Dpy-rseq-id xdpy) 'maj 'min 'opfun)
;; Now run hooks if any
- (X-Dpy-run-error-hooks xdpy xev)
-
- ;; Finnally signal an error.
- (error 'X-Error xev)))
+ (X-Dpy-run-error-hooks xdpy xev)))
;;; Some usefull macroses (NOT USED)
(defmacro X-Generic-enqueue (obj queue)
@@ -1109,21 +1184,27 @@
(defun X-Dpy-event-dispatch (xev)
"Dispatch event XEV."
(let ((win (X-Event-win xev))
- (xdpy (X-Event-dpy xev)))
+ (xdpy (X-Event-dpy xev)))
(X-Dpy-log xdpy 'x-event "Ready to dispatch event: %S for win %S"
- '(X-Event-name xev) '(if (X-Win-p (X-Event-win xev))
- (X-Win-id (X-Event-win xev))
- (X-Event-win xev)))
+ '(X-Event-name xev) '(if (X-Win-p (X-Event-win xev))
+ (X-Win-id (X-Event-win xev))
+ (X-Event-win xev)))
(when (X-Dpy-events-dispatcher xdpy)
(funcall (X-Dpy-events-dispatcher xdpy) xdpy win xev))
))
-(defsubst X-Dpy-event-enqueue (xdpy event)
+(defsubst X-Dpy-event-enqueue (event)
"Enqueue EVENT in XDPY's events queue."
(enqueue-eval-event 'X-Dpy-event-dispatch event))
+(defun X-Dpy-dispatch-event (xev)
+ "Dispatch X Event or error XEV."
+ (if (= (X-Event-type xev) 0)
+ (X-Dpy-error-dispatch xev)
+ (X-Dpy-event-enqueue xev)))
+
(defun X-Dpy-parse-event (xdpy evtype)
"On XDPY construct and enqueue event of EVTYPE type."
(X-Dpy-log xdpy 'x-event "XLIB: Getting event ....")
@@ -1133,27 +1214,12 @@
;; :evdata (concat (char-to-string (XCharacter type)) evdata)
(X-Dpy-read-excursion xdpy
(let* ((type evtype)
- (synth (= (logand X-SyntheticMask type) X-SyntheticMask))
- (type (if synth (- type X-SyntheticMask) type))
- (xev (make-X-Event :dpy xdpy :type type :synth-p synth))
- (evspec (aref X-EventsList type))
- (evin (X-Dpy-parse-message (or (and evspec (aref evspec 1)) (list
[31 nil])) 0 xdpy)))
+ (synth (= (logand X-SyntheticMask type) X-SyntheticMask))
+ (type (if synth (- type X-SyntheticMask) type))
+ (xev (make-X-Event :dpy xdpy :type type :synth-p synth))
+ (evspec (aref X-EventsList type))
+ (evin (X-Dpy-parse-message (or (and evspec (aref evspec 1)) (list
[31 nil])) 0 xdpy)))
(setf (X-Event-evinfo xev) evin)
-
-;;; Commented out, because causes some problems
-;; ;; Here is special case of DestroyNotify event. We dont want to
-;; ;; keep X-Win structure in xdpy's windows list, because there
-;; ;; will be no other way remove it, and someday XDPY's windows
-;; ;; list will became huge.
-;; (when (= (X-Event-type xev) X-DestroyNotify)
-;; (X-Dpy-log xdpy 'x-event "XDPY Removing window from XDPY: %S"
-;; '(X-Win-id (X-Event-xdestroywindow-window xev)))
-;; (X-Win-invalidate xdpy (X-Event-xdestroywindow-window xev)))
-
- (if (= (X-Event-type xev) 0)
- ;; Dispatch this error
- (X-Dpy-error-dispatch xev)
- (X-Dpy-event-enqueue xdpy xev))
xev)))
;;; Function to call when there data in XDPY, but noone reading it.
--- orig/lisp/xlib-xrecord.el
+++ mod/lisp/xlib-xrecord.el
@@ -74,54 +74,54 @@
(defstruct (X-RecordContext (:predicate X-RecordContext-isrc-p))
dpy id
- props) ; User defined plist
+ props) ; User defined plist
(defstruct (X-RecordExtrange (:predicate X-RecordExtrange-isrer-p))
- major ; X-RecordRange8
- minor ; X-RecordRange16
+ major ; X-RecordRange8
+ minor ; X-RecordRange16
;; List of extractors
(list '(((lambda (re)
- (X-RecordRange8-message (X-RecordExtrange-major re))) . 2)
- ((lambda (re)
- (X-RecordRange16-message (X-RecordExtrange-minor re))) . 4)))
+ (X-RecordRange8-message (X-RecordExtrange-major re))) . 2)
+ ((lambda (re)
+ (X-RecordRange16-message (X-RecordExtrange-minor re))) . 4)))
)
(defstruct (X-RecordRange (:predicate X-RecordRange-isrr-p))
- core-requests ; X-RecordRange8
- core-replies ; X-RecordRange8
- ext-requests ; X-RecordExtrange
- ext-replies ; X-RecordExtrange
- delivered-events ; X-RecordRange8
- device-events ; X-RecordRange8
- errors ; X-RecordRange8
- client-started ; BOOL
- client-died ; BOOL
+ core-requests ; X-RecordRange8
+ core-replies ; X-RecordRange8
+ ext-requests ; X-RecordExtrange
+ ext-replies ; X-RecordExtrange
+ delivered-events ; X-RecordRange8
+ device-events ; X-RecordRange8
+ errors ; X-RecordRange8
+ client-started ; BOOL
+ client-died ; BOOL
;; List of extractors
(list '(((lambda (rr)
- (X-RecordRange8-message (X-RecordRange-core-requests rr))) . 2)
- ((lambda (rr)
- (X-RecordRange8-message (X-RecordRange-core-replies rr))) . 2)
- ((lambda (rr)
- (X-RecordExtrange-message (X-RecordRange-ext-requests rr))) . 6)
- ((lambda (rr)
- (X-RecordExtrange-message (X-RecordRange-ext-replies rr))) . 6)
- ((lambda (rr)
- (X-RecordRange8-message (X-RecordRange-delivered-events rr))) . 2)
- ((lambda (rr)
- (X-RecordRange8-message (X-RecordRange-device-events rr))) . 2)
- ((lambda (rr)
- (X-RecordRange8-message (X-RecordRange-errors rr))) . 2)
- (X-RecordRange-client-started . 1)
- (X-RecordRange-client-died . 1))))
+ (X-RecordRange8-message (X-RecordRange-core-requests rr))) . 2)
+ ((lambda (rr)
+ (X-RecordRange8-message (X-RecordRange-core-replies rr))) . 2)
+ ((lambda (rr)
+ (X-RecordExtrange-message (X-RecordRange-ext-requests rr))) . 6)
+ ((lambda (rr)
+ (X-RecordExtrange-message (X-RecordRange-ext-replies rr))) . 6)
+ ((lambda (rr)
+ (X-RecordRange8-message (X-RecordRange-delivered-events rr))) . 2)
+ ((lambda (rr)
+ (X-RecordRange8-message (X-RecordRange-device-events rr))) . 2)
+ ((lambda (rr)
+ (X-RecordRange8-message (X-RecordRange-errors rr))) . 2)
+ (X-RecordRange-client-started . 1)
+ (X-RecordRange-client-died . 1))))
(defstruct (X-RecordClientInfo (:predicate X-RecordClientInfo-isrci-p))
- client-spec ; X-RecordClientSpec
- ranges) ; list of X-RecordRange
+ client-spec ; X-RecordClientSpec
+ ranges) ; list of X-RecordRange
(defstruct X-RecordState
- enabled ; BOOL
- datum-flags ; int
- client-infos ; list of X-RecordClientInfo
+ enabled ; BOOL
+ datum-flags ; int
+ client-infos ; list of X-RecordClientInfo
)
@@ -181,23 +181,23 @@
(X-Dpy-p xdpy 'X-XRecordQueryVersion)
(let* ((xrec-ext (X-Dpy-get-extension xdpy "RECORD"))
- (ListOfFields
- (list (vector 1 (nth 4 xrec-ext)) ; opcode
- [1 X-XRecord-op-QueryVersion]
- [2 2] ;length
-
- [2 (or major X-XRecord-major)]
- [2 (or minor X-XRecord-minor)]))
- (msg (X-Create-message ListOfFields))
- (ReceiveFields
- (list [1 success] ;success field
- nil
- (list [1 nil] ;not used
- [2 integerp] ;sequence number
- [4 nil] ;length
- [2 integerp] ;major version
- [2 integerp] ;minor version
- [20 nil])))) ;pad
+ (ListOfFields
+ (list (vector 1 (nth 4 xrec-ext)) ; opcode
+ [1 X-XRecord-op-QueryVersion]
+ [2 2] ;length
+
+ [2 (or major X-XRecord-major)]
+ [2 (or minor X-XRecord-minor)]))
+ (msg (X-Create-message ListOfFields))
+ (ReceiveFields
+ (list [1 success] ;success field
+ nil
+ (list [1 nil] ;not used
+ [2 integerp] ;sequence number
+ [4 nil] ;length
+ [2 integerp] ;major version
+ [2 integerp] ;minor version
+ [20 nil])))) ;pad
(and (car xrec-ext)
(X-Dpy-send-read xdpy msg ReceiveFields))))
@@ -211,19 +211,19 @@
(X-Dpy-p xdpy 'X-XRecordCreateContext)
(let* ((xrec-ext (X-Dpy-get-extension xdpy "RECORD" 'X-XRecordCreateContext))
- (ListOfFields
- (list (vector 1 (nth 4 xrec-ext)) ;opcode
- [1 X-XRecord-op-CreateContext]
- [2 (+ 5 (length clspecs) (* 6 (length ranges)))] ;length
-
- [4 (X-RecordContext-id rc)] ; context
- [1 elhead]
- [3 nil] ; not used
- [4 (length clspecs)]
- [4 (length ranges)]))
- (msg (concat (X-Create-message ListOfFields)
- (X-Generate-message-for-list clspecs
'X-RecordClientSpec-message)
- (X-Generate-message-for-list ranges
'X-RecordRange-message))))
+ (ListOfFields
+ (list (vector 1 (nth 4 xrec-ext)) ;opcode
+ [1 X-XRecord-op-CreateContext]
+ [2 (+ 5 (length clspecs) (* 6 (length ranges)))] ;length
+
+ [4 (X-RecordContext-id rc)] ; context
+ [1 elhead]
+ [3 nil] ; not used
+ [4 (length clspecs)]
+ [4 (length ranges)]))
+ (msg (concat (X-Create-message ListOfFields)
+ (X-Generate-message-for-list clspecs
'X-RecordClientSpec-message)
+ (X-Generate-message-for-list ranges
'X-RecordRange-message))))
(X-Dpy-send xdpy msg)
rc))
@@ -233,18 +233,18 @@
(X-RecordContext-p rc 'X-XRecordRegisterClients)
(let* ((xrec-ext (X-Dpy-get-extension xdpy "RECORD"
'X-XRecordRegisterClients))
- (ListOfFields
- (list (vector 1 (nth 4 xrec-ext)) ; opcode
- [1 X-XRecord-op-RegisterClients]
- [2 (+ 5 (length clspecs) (* 6 (length ranges)))] ; length
- [4 (X-RecordContext-id rc)]
- [1 elhead]
- [3 nil] ; not used
- [4 (length clspecs)]
- [4 (length ranges)]))
- (msg (concat (X-Create-message ListOfFields)
- (X-Generate-message-for-list clspecs
'X-RecordClientSpec-message)
- (X-Generate-message-for-list ranges
'X-RecordRange-message))))
+ (ListOfFields
+ (list (vector 1 (nth 4 xrec-ext)) ; opcode
+ [1 X-XRecord-op-RegisterClients]
+ [2 (+ 5 (length clspecs) (* 6 (length ranges)))] ; length
+ [4 (X-RecordContext-id rc)]
+ [1 elhead]
+ [3 nil] ; not used
+ [4 (length clspecs)]
+ [4 (length ranges)]))
+ (msg (concat (X-Create-message ListOfFields)
+ (X-Generate-message-for-list clspecs
'X-RecordClientSpec-message)
+ (X-Generate-message-for-list ranges
'X-RecordRange-message))))
(X-Dpy-send xdpy msg)))
(defun X-XRecordUnregisterClients (xdpy rc clspecs)
@@ -253,14 +253,14 @@
(X-RecordContext-p rc 'X-XRecordRegisterClients)
(let* ((xrec-ext (X-Dpy-get-extension xdpy "RECORD"
'X-XRecordRegisterClients))
- (ListOfFields
- (list (vector 1 (nth 4 xrec-ext)) ; opcode
- [1 X-XRecord-op-UnregisterClients]
- [2 (+ 3 (length clspecs))] ; length
- [4 (X-RecordContext-id rc)]
- [4 (length clspecs)]))
- (msg (concat (X-Create-message ListOfFields)
- (X-Generate-message-for-list clspecs
'X-RecordClientSpec-message))))
+ (ListOfFields
+ (list (vector 1 (nth 4 xrec-ext)) ; opcode
+ [1 X-XRecord-op-UnregisterClients]
+ [2 (+ 3 (length clspecs))] ; length
+ [4 (X-RecordContext-id rc)]
+ [4 (length clspecs)]))
+ (msg (concat (X-Create-message ListOfFields)
+ (X-Generate-message-for-list clspecs
'X-RecordClientSpec-message))))
(X-Dpy-send xdpy msg)))
(defun X-XRecordGetContext (xdpy rc)
@@ -269,52 +269,52 @@
(X-RecordContext-p rc 'X-XRecordRegisterClients)
(let* ((xrec-ext (X-Dpy-get-extension xdpy "RECORD" 'X-XRecordGetContext))
- (ListOfFields
- (list (vector 1 (nth 4 xrec-ext)) ; opcode
- [1 X-XRecord-op-GetContext]
- [2 2] ; length
- [4 (X-RecordContext-id rc)])) ; context
- (msg (concat (X-Create-message ListOfFields)))
- (ReceiveFields
- (list [1 success] ;success field
- nil
- (list [1 integerp] ;enabled
- [2 integerp] ;sequence number
- [4 length-1] ;length
- [1 integerp] ;elhead
- [3 nil] ;not used
- [4 length-2] ;n, number of intercepted-clients
- [16 nil] ;not used
- [length-2 ([4 integerp]
- [4 length-3]
- [length-3
- ([1 integerp]
- [1 integerp]
-
- [1 integerp]
- [1 integerp]
-
- [1 integerp]
- [1 integerp]
- [2 integerp]
- [2 integerp]
-
- [1 integerp]
- [1 integerp]
- [2 integerp]
- [2 integerp]
-
- [1 integerp]
- [1 integerp]
-
- [1 integerp]
- [1 integerp]
-
- [1 integerp]
- [1 integerp]
-
- [1 booleanp]
- [1 booleanp])])]))))
+ (ListOfFields
+ (list (vector 1 (nth 4 xrec-ext)) ; opcode
+ [1 X-XRecord-op-GetContext]
+ [2 2] ; length
+ [4 (X-RecordContext-id rc)])) ; context
+ (msg (concat (X-Create-message ListOfFields)))
+ (ReceiveFields
+ (list [1 success] ;success field
+ nil
+ (list [1 integerp] ;enabled
+ [2 integerp] ;sequence number
+ [4 length-1] ;length
+ [1 integerp] ;elhead
+ [3 nil] ;not used
+ [4 length-2] ;n, number of intercepted-clients
+ [16 nil] ;not used
+ [length-2 ([4 integerp]
+ [4 length-3]
+ [length-3
+ ([1 integerp]
+ [1 integerp]
+
+ [1 integerp]
+ [1 integerp]
+
+ [1 integerp]
+ [1 integerp]
+ [2 integerp]
+ [2 integerp]
+
+ [1 integerp]
+ [1 integerp]
+ [2 integerp]
+ [2 integerp]
+
+ [1 integerp]
+ [1 integerp]
+
+ [1 integerp]
+ [1 integerp]
+
+ [1 integerp]
+ [1 integerp]
+
+ [1 booleanp]
+ [1 booleanp])])]))))
(X-Dpy-send-read xdpy msg ReceiveFields)))
; (X-log dpy "Get X-XRecordGetContext replay: %s\n" 'resp)
@@ -330,31 +330,31 @@
(X-Dpy-p xdpy 'X-XRecordEnableContext)
(let* ((xrec-ext (X-Dpy-get-extension xdpy "RECORD" 'X-XRecordEnableContext))
- (ListOfFields
- (list (vector 1 (nth 4 xrec-ext)) ;opcode
- [1 X-XRecord-op-EnableContext]
- [2 2] ;length
- [4 (X-RecordContext-id rc)]))
- (msg (concat (X-Create-message ListOfFields)))
- (ReceiveFields
- (list [1 success] ;success field
- nil
- (list [1 integerp] ;category
- [2 integerp] ;sequence number
- [4 length-1] ;length
- [1 integerp] ;elhead
- [1 integerp] ;client-swapped
- [2 nil] ;not used
- [4 integerp] ;id-baes
- [4 integerp] ;server-time
- [4 integerp] ;recorded sequence number
- [8 nil] ;not used
- [(* length-1 4) stringp])))
- (rep (X-Dpy-send-read xdpy msg ReceiveFields)))
+ (ListOfFields
+ (list (vector 1 (nth 4 xrec-ext)) ;opcode
+ [1 X-XRecord-op-EnableContext]
+ [2 2] ;length
+ [4 (X-RecordContext-id rc)]))
+ (msg (concat (X-Create-message ListOfFields)))
+ (ReceiveFields
+ (list [1 success] ;success field
+ nil
+ (list [1 integerp] ;category
+ [2 integerp] ;sequence number
+ [4 length-1] ;length
+ [1 integerp] ;elhead
+ [1 integerp] ;client-swapped
+ [2 nil] ;not used
+ [4 integerp] ;id-baes
+ [4 integerp] ;server-time
+ [4 integerp] ;recorded sequence number
+ [8 nil] ;not used
+ [(* length-1 4) stringp])))
+ (rep (X-Dpy-send-read xdpy msg ReceiveFields)))
(X-Dpy-log xdpy 'x-record "X-XRecordEnableContext: rep=%S" 'rep)
(when (and (car rep)
- (= (nth 1 rep) X-XRecordStartOfData))
+ (= (nth 1 rep) X-XRecordStartOfData))
;; Set events guess parser and events dispatcher
(setf (X-Dpy-parse-guess-dispatcher xdpy) 'X-XRecord-parse-guess)
(setf (X-Dpy-events-dispatcher xdpy) 'X-XRecord-event-dispatcher))
@@ -366,13 +366,14 @@
(X-RecordContext-p rc 'X-XRecordRegisterClients)
(let* ((xrec-ext (X-Dpy-get-extension xdpy "RECORD" 'X-XRecordGetContext))
- (ListOfFields
- (list (vector 1 (nth 4 xrec-ext)) ; opcode
- [1 X-XRecord-op-DisplayContext]
- [2 2] ; length
- [4 (X-RecordContext-id rc)])) ; context
- (msg (X-Create-message ListOfFields)))
- (X-Dpy-send xdpy msg)))
+ (ListOfFields
+ (list (vector 1 (nth 4 xrec-ext)) ; opcode
+ [1 X-XRecord-op-DisplayContext]
+ [2 2] ; length
+ [4 (X-RecordContext-id rc)])) ; context
+ (msg (X-Create-message ListOfFields)))
+ (X-Dpy-send xdpy msg))
+ (X-Dpy-log xdpy 'x-record "X-XRecordDisableContext: rc=%S"
'(X-RecordContext-id rc)))
(defun X-XRecordFreeContext (xdpy rc)
"On display XDPY free record context RC."
@@ -380,12 +381,12 @@
(X-RecordContext-p rc 'X-XRecordRegisterClients)
(let* ((xrec-ext (X-Dpy-get-extension xdpy "RECORD" 'X-XRecordGetContext))
- (ListOfFields
- (list (vector 1 (nth 4 xrec-ext)) ; opcode
- [1 X-XRecord-op-FreeContext]
- [2 2] ; length
- [4 (X-RecordContext-id rc)])) ; context
- (msg (X-Create-message ListOfFields)))
+ (ListOfFields
+ (list (vector 1 (nth 4 xrec-ext)) ; opcode
+ [1 X-XRecord-op-FreeContext]
+ [2 2] ; length
+ [4 (X-RecordContext-id rc)])) ; context
+ (msg (X-Create-message ListOfFields)))
(X-Dpy-send xdpy msg)))
@@ -398,73 +399,79 @@
"Parse message received in data connection."
(X-Dpy-p xdpy 'X-XRecord-parse-guess)
- (when (zerop (X-Dpy-readings xdpy))
- (X-Dpy-read-excursion
- xdpy
- (while (> (length (X-Dpy-message-buffer xdpy)) 0)
- (let* ((msg (X-Dpy-parse-message (list [1 integerp] ; reply
- [1 integerp] ;category
- [2 integerp] ;sequence number
- [4 integerp] ;length
- [1 integerp] ;elhead
- [1 integerp] ;client-swapped
- [2 nil] ;not used
- [4 integerp] ;id-baes
- [4 integerp] ;server-time
- [4 integerp] ;recorded sequence
number
- [8 nil]) ;not used
- 0 xdpy))
- (mcategory (nth 1 msg)) ; message categery
- (len (nth 3 msg))
- (elh (nth 4 msg))
- elh-value
- result)
-
- (while (> len 0)
- ;; There data
- (setq elh-value nil)
- (when (> elh 0)
- ;; there elhead
- (setq elh-value (X-Dpy-grab-bytes xdpy 4))
- (setq len (- len 4)))
-
- (setq result (Xforcenum (aref (X-Dpy-grab-bytes xdpy 1) 0)))
- (setq len (- len 1))
-
- (cond ((= mcategory X-XRecordFromServer)
- ;; Error, Event or Reply
- (cond ((= result 0)
- ;; Error, TODO
- (setq len 0)
- )
- ((= result 1)
- ;; Reply, TODO
- (setq len 0)
- )
-
- ;; Event
- (t ;(< result X-MaxEvent)
- ;; Valid event
- (let ((xev (X-Dpy-parse-event xdpy result)))
- ;; Put some interception info
- (X-Event-put-property xev 'XRecord-Category (nth 1
msg))
- (X-Event-put-property xev 'XRecord-Sequence (nth 2
msg))
- (X-Event-put-property xev 'XRecord-Elhead (nth 4
msg))
- (X-Event-put-property xev 'XRecord-Elhead-value
elh-value)
- (X-Event-put-property xev 'XRecord-Swaped (nth 5
msg))
- (X-Event-put-property xev 'XRecord-Idbase (nth 6
msg))
- (X-Event-put-property xev 'XRecord-Servertime (nth 7
msg))
- (X-Event-put-property xev 'XRecord-RecSeq (nth 8
msg))
-
- (X-Dpy-log (X-Event-dpy xev) 'x-record "XRECORD
EXTENSION: Get Event: %S, win=%S"
- '(X-Event-name xev) '(X-Win-id
(X-Event-win xev)))
-
- (setq len (- len 31))))))
-
- ;; TODO: what about other categeries?
- ))
- )))
- ))
+ (while (and (zerop (X-Dpy-readings xdpy))
+ (> (length (X-Dpy-message-buffer xdpy)) 31))
+ (X-Dpy-read-excursion xdpy
+ (let* ((msg (X-Dpy-parse-message
+ (list [1 integerp] ; reply
+ [1 integerp] ;category
+ [2 integerp] ;sequence number
+ [4 integerp] ;length
+ [1 integerp] ;elhead
+ [1 integerp] ;client-swapped
+ [2 nil] ;not used
+ [4 integerp] ;id-baes
+ [4 integerp] ;server-time
+ [4 integerp] ;recorded sequence number
+ [8 nil]) ;not used
+ 0 xdpy))
+ (mcategory (nth 1 msg)) ; message categery
+ (len (* 4 (nth 3 msg)))
+ (elh (nth 4 msg))
+ elh-value
+ result)
+
+ (while (> len 0)
+ ;; There data
+ (setq elh-value nil)
+ (when (> elh 0)
+ ;; there elhead
+ (setq elh-value
+ (X-Dpy-parse-message (list [4 integerp]) 0 xdpy))
+ (setq len (- len 4)))
+
+ (setq result (Xforcenum (aref (X-Dpy-grab-bytes xdpy 1) 0)))
+ (setq len (- len 1))
+
+ (cond ((= mcategory X-XRecordFromServer)
+ ;; Error, Event or Reply
+ (cond ((or (= result 0)
+ (= result 1))
+ ;; Error or Reply .. just flush the data
+ (X-Dpy-grab-bytes xdpy len)
+ (setq len 0))
+
+ ;; Event
+ (t ;(< result X-MaxEvent)
+ ;; Valid event
+ (let ((xev (X-Dpy-parse-event xdpy result)))
+ (setq len (- len 31))
+
+ ;; Put some interception info
+ (X-Event-put-property xev 'XRecord-Category (nth 1
msg))
+ (X-Event-put-property xev 'XRecord-Sequence (nth 2
msg))
+ (X-Event-put-property xev 'XRecord-Elhead (nth 4
msg))
+ (X-Event-put-property xev 'XRecord-Elhead-value
elh-value)
+ (X-Event-put-property xev 'XRecord-Swaped (nth 5
msg))
+ (X-Event-put-property xev 'XRecord-Idbase (nth 6
msg))
+ (X-Event-put-property xev 'XRecord-Servertime (nth 7
msg))
+ (X-Event-put-property xev 'XRecord-RecSeq (nth 8
msg))
+
+ (X-Dpy-log (X-Event-dpy xev) 'x-record "XRECORD
EXTENSION: Get Event: %S(%S[%S]), win=%S"
+ '(X-Event-name xev) '(X-Event-detail xev)
+ '(int-to-char (truncate (car
(xwem-kbd-xkcode->xksym (X-Event-detail xev)))))
+ '(X-Win-id (X-Event-win xev)))
+
+ ;; Add event to event queue
+ (setf (X-Dpy-evq xdpy)
+ (append (X-Dpy-evq xdpy) (list xev)))))))
+
+ (t
+ ;; Unsupported category
+ (X-Dpy-grab-bytes xdpy len)
+ (setq len 0)))
+ )))
+ ))
;;; Testing section:
|