cgit.sxemacs.org Git - packages/blob - xemacs-packages/xlib/lisp/xlib-xr.el

   1 ;;; xlib-xr.el --- X receive part.
   2
   3 ;; Copyright (C) 2003-2005 by XWEM Org.
   4
   5 ;; Author: Eric M. Ludlam <zappo@gnu.ai.mit.edu>
   6 ;;         Zajcev Evgeny <zevlg@yandex.ru>
   7 ;; Keywords: xlib, xwem
   8 ;; X-CVS: $Id: xlib-xr.el,v 1.10 2005-04-04 19:55:30 lg Exp $
   9
  10 ;; This file is part of XWEM.
  11
  12 ;; XWEM is free software; you can redistribute it and/or modify it
  13 ;; under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; XWEM is distributed in the hope that it will be useful, but WITHOUT
  18 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  19 ;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
  20 ;; License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  24 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  25 ;; 02111-1307, USA.
  26
  27 ;;; Synched up with: Not in FSF
  28
  29 ;;; Commentary:
  30
  31 ;;
  32
  33 ;;; Code:
  34 \f
  35 (require 'xlib-math)
  36 (require 'xlib-const)
  37 (require 'xlib-xwin)
  38
  39 ;; GNU Emacs compatibility
  40 (unless (fboundp 'define-error)
  41   (defun define-error (err-sym doc-string &optional inherits-from)
  42     "Define a new error, denoted by ERR-SYM."
  43     (put err-sym 'error-message doc-string)
  44     (unless inherits-from
  45       (setq inherits-from 'error))
  46     (let ((conds (get inherits-from 'error-conditions)))
  47       (or conds (signal 'error (list "Not an error symbol" err-sym)))
  48       (put err-sym 'error-conditions (cons err-sym conds)))))
  49
  50 (define-error 'X-Error
  51   "X Server error.")
  52
  53 (define-error 'X-Events-stop
  54   "Error used to stop X events processing.")
  55
  56 ;;; X Events section.
  57 (defun XVectorizeList (lst)
  58   "Take list LST and turn it into a vector.
  59 This makes random access of its fields much faster."
  60   (let ((nv (make-vector (length lst) nil))
  61         (cnt 0))
  62     (while lst
  63       (aset nv cnt (if (and (car lst) (listp (car lst)))
  64                        (XVectorizeList (car lst))
  65                      (car lst)))
  66       (setq cnt (1+ cnt))
  67       (setq lst (cdr lst)))
  68     nv))
  69
  70 (defvar X-Event-LASTEvent 128
  71   "Any event must be less then this one.
  72 NOTE: * Core event are less than 35, but extensions may generate greater.
  73       * Eight bit is syntetic bit.")
  74
  75 (defvar X-EventsList (make-vector X-Event-LASTEvent ["Unknown" nil 0 0])
  76   "List of event descriptions.")
  77
  78 (defstruct (X-Event (:predicate X-Event-isevent-p))
  79   dpy                                   ; display
  80   type                                  ; type of event
  81   synth-p                               ; non-nil if event came from SendEvent request
  82   evdata                                ; binary event represetation
  83   evinfo                                ; parsed variant of evdata
  84
  85   list                                  ;for use in X-Generate-message
  86   properties                            ; User defined plist
  87   )
  88
  89 (defsubst X-Event-put-property (xev prop val)
  90   "Put property PROP with value VAL in XEV's properties list."
  91   (setf (X-Event-properties xev)
  92         (plist-put (X-Event-properties xev) prop val)))
  93
  94 (defsubst X-Event-get-property (xev prop)
  95   "Get property PROP from XEV's properties list."
  96   (plist-get (X-Event-properties xev) prop))
  97
  98 (defsubst X-Event-rem-property (xev prop)
  99   "Remove property PROP from XEV's properties list."
 100   (setf (X-Event-properties xev) (plist-remprop (X-Event-properties xev) prop)))
 101
 102 (defun X-Event-p (ev &optional sig)
 103   "Return non-nil if EV is X-Event."
 104   (let ((isev (X-Event-isevent-p ev)))
 105     (if (and (not isev) sig)
 106         (signal 'wrong-type-argument (list sig 'X-Event-p ev))
 107       isev)))
 108
 109 (defsubst X-Event-detail (xev)
 110   "Return detail info stored in XEV."
 111   (nth 0 (X-Event-evinfo xev)))
 112
 113 (defsubst X-Event-seq (xev)
 114   "Return sequence number of XEvent XEV."
 115   (nth 1 (X-Event-evinfo xev)))
 116
 117 (defsubst X-Event-win (xev)
 118   "Return window which is the subject of the XEV.
 119 Return nil if there no such window."
 120   (let ((evd (aref (aref X-EventsList (X-Event-type xev)) 2)))
 121     (and (numberp evd) (nth evd (X-Event-evinfo xev)))))
 122
 123 (defsubst X-Event-win-event (xev)
 124   "Return window for which XEV is generated.
 125 Return nil if there is no such window."
 126   (let ((evd (aref (aref X-EventsList (X-Event-type xev)) 3)))
 127     (and (numberp evd) (nth evd (X-Event-evinfo xev)))))
 128
 129 (defsubst X-Event-name (xev)
 130   "Return symbolic XEV name."
 131   (aref (aref X-EventsList (X-Event-type xev)) 0))
 132
 133 (defun X-Event-make (&rest args)
 134   "Like `make-X-Event', but also fills list field automatically."
 135   (let* ((xev (apply 'make-X-Event args))
 136          (evspec (aref (X-Event-type xev) X-EventsList)))
 137     ;; TODO: write me ..
 138     ))
 139
 140 (defmacro X-Event-declare (type ev-name ev-msg &optional win-idx event-win-idx)
 141   "Only declare event of TYPE with DESCR in `X-EventsList'."
 142   `(aset X-EventsList ,type
 143         (vector ,ev-name (quote ,ev-msg) ,win-idx (or ,event-win-idx ,win-idx))))
 144
 145 (defmacro X-Event-define (type name dnames ev-name ev-msg &optional win-idx event-win-idx)
 146   "Define new event of TYPE, NAME and description of event DESCR."
 147   (let ((offs 0)
 148         fsym forms)
 149     (push `(aset X-EventsList ,type
 150                  (vector ,ev-name (quote ,ev-msg) ,win-idx (or ,event-win-idx ,win-idx)))
 151           forms)
 152     (while dnames
 153       (when (car dnames)
 154         (setq fsym (intern (concat "X-Event-" name "-" (symbol-name (car dnames)))))
 155         (push `(defsubst* ,fsym (ev)
 156                  (nth ,offs (X-Event-evinfo ev)))
 157               forms))
 158       (setq offs (1+ offs))
 159       (setq dnames (cdr dnames)))
 160     `(progn ,@forms)))
 161
 162 (defun X-Event->symbolkey (xev)
 163   "Convert XEV type to symbolic name, return keyword."
 164   (let ((evt (X-Event-type xev)))
 165     (cond ((= evt X-KeyPress) :X-KeyPress)
 166           ((= evt X-KeyRelease) :X-KeyRelease)
 167           ((= evt X-ButtonPress) :X-ButtonPress)
 168           ((= evt X-ButtonRelease) :X-ButtonRelease)
 169           ((= evt X-MotionNotify) :X-MotionNotify)
 170           ((= evt X-EnterNotify) :X-EnterNotify)
 171           ((= evt X-LeaveNotify) :X-LeaveNotify)
 172           ((= evt X-FocusIn) :X-FocusIn)
 173           ((= evt X-FocusOut) :X-FocusOut)
 174           ((= evt X-KeymapNotify) :X-KeymapNotify)
 175           ((= evt X-Expose) :X-Expose)
 176           ((= evt X-GraphicsExpose) :X-GraphicsExpose)
 177           ((= evt X-NoExpose) :X-NoExpose)
 178           ((= evt X-VisibilityNotify) :X-VisibilityNotify)
 179           ((= evt X-CreateNotify) :X-CreateNotify)
 180           ((= evt X-DestroyNotify) :X-DestroyNotify)
 181           ((= evt X-UnmapNotify) :X-UnmapNotify)
 182           ((= evt X-MapNotify) :X-MapNotify)
 183           ((= evt X-MapRequest) :X-MapRequest)
 184           ((= evt X-ReparentNotify) :X-ReparentNotify)
 185           ((= evt X-ConfigureRequest) :X-ConfigureRequest)
 186           ((= evt X-ConfigureNotify) :X-ConfigureNotify)
 187           ((= evt X-GravityNotify) :X-GravityNotify)
 188           ((= evt X-ResizeRequest) :X-ResizeRequest)
 189           ((= evt X-CirculateNotify) :X-CirculateNotify)
 190           ((= evt X-CirculateRequest) :X-CirculateRequest)
 191           ((= evt X-PropertyNotify) :X-PropertyNotify)
 192           ((= evt X-SelectionClear) :X-SelectionClear)
 193           ((= evt X-SelectionRequest) :X-SelectionRequest)
 194           ((= evt X-SelectionNotify) :X-SelectionNotify)
 195           ((= evt X-ColormapNotify) :X-ColormapNotify)
 196           ((= evt X-ClientMessage) :X-ClientMessage)
 197           ((= evt X-MappingNotify) :X-MappingNotify)
 198
 199           (t :X-Unknown))))
 200
 201 (defmacro X-Event-CASE (xev &rest body)
 202   "Run event case. BODY in form (EVTYPE FORMS) (EVTYPE FORMS) ..
 203 EVTYPE is one of :X-KeyPress, :X-KeyRelease etc."
 204   `(case (X-Event->symbolkey ,xev)
 205      ,@body))
 206
 207 (put 'X-Event-CASE 'lisp-indent-function 1)
 208
 209 (defstruct X-EventHandler
 210   priority
 211   evtypes-list                          ; list of event types
 212   handler                               ; function to call
 213   (active t)                            ; Non-nil mean event handler activated
 214
 215   plist)                                ; user defined plist
 216
 217 ;;;###autoload
 218 (defun X-EventHandler-add (evhlist handler &optional priority evtypes-list)
 219   "To event handlers list EVHLIST add event HANDLER.
 220
 221 HANDLER is function which should accept three arguments - xdpy(X-Dpy),
 222 xwin(X-Win) and xev(X-Event).  Only events with type that in
 223 EVTYPES-LIST are passed to HANDLER. By default all events passed.
 224 PRIORITY is place in events handler list, i.e. when HANDLER will be
 225 called. Higher priorities runs first.
 226
 227 Return new list, use it like `(setq lst (X-EventHandler-add lst 'handler))'."
 228   (unless priority
 229     (setq priority 0))
 230
 231   (let ((xeh (make-X-EventHandler :priority priority
 232                                   :evtypes-list evtypes-list
 233                                   :handler handler)))
 234
 235     ;; Insert new event handler and sort event handlers by priority.
 236     (sort (cons xeh evhlist)
 237           #'(lambda (xeh1 xeh2)
 238               (> (X-EventHandler-priority xeh1)
 239                  (X-EventHandler-priority xeh2))))))
 240
 241 ;;;###autoload
 242 (defun X-EventHandler-isset (evhlist handler &optional prioritiy evtypes-list)
 243   "Examine EVHLIST and return X-EventHandler with HANDLER, PRIORITY and EVTYPES-LIST.
 244 If you does not specify PRIORITY and EVTYPES-LIST, only matching with HANDLER occurs.
 245 If event handler not found - nil will be returned."
 246   (let ((evhs evhlist))
 247     ;; Find appopriate handler
 248     (while (and evhs
 249                 (not (and (eq (X-EventHandler-handler (car evhs)) handler)
 250                           (if prioritiy (equal prioritiy (X-EventHandler-priority (car evhs))) t)
 251                           (if evtypes-list (equal evtypes-list (X-EventHandler-evtypes-list (car evhs))) t))))
 252       (setq evhs (cdr evhs)))
 253
 254     (car evhs)))
 255
 256 ;;;###autoload
 257 (defun X-EventHandler-rem (evhlist handler &optional prioritiy evtypes-list)
 258   "From EVHLIST remove event HANDLER with PRIORITY and EVTYPES-LIST.
 259 If you does not specify PRIORITY and EVTYPES-LIST, only matching with HANDLER occurs.
 260 Return new list, use it like `(setq lst (X-EventHandler-rem lst 'handler))'."
 261   (let ((xeh (X-EventHandler-isset evhlist handler prioritiy evtypes-list)))
 262     (when xeh
 263       (setq evhlist (delete xeh evhlist)))
 264     evhlist))
 265
 266 ;;;###autoload
 267 (defun X-EventHandler-enable (evhlist handler &optional prioritiy evtypes-list)
 268   "In event handlers list EVHLIST mark HANDLER with PRIORITY and EVTYPES-LIST as active."
 269   (let ((xeh (X-EventHandler-isset evhlist handler prioritiy evtypes-list)))
 270     (when xeh
 271       (setf (X-EventHandler-active xeh) t))))
 272
 273 ;;;###autoload
 274 (defun X-EventHandler-disable (evhlist handler &optional prioritiy evtypes-list)
 275   "In event handlers list EVHLIST mark HANDLER with PRIORITY and EVTYPES-LIST as inactive."
 276   (let ((xeh (X-EventHandler-isset evhlist handler prioritiy evtypes-list)))
 277     (when xeh
 278       (setf (X-EventHandler-active xeh) nil))))
 279
 280 ;;;###autoload
 281 (defun X-EventHandler-runall (evhlist xev)
 282   "Run all event handlers in EVHLIST on XEV.
 283 Signal `X-Events-stop' to stop events processing."
 284   (let ((evhs evhlist))                 ; EVHS should be already sorted by priority
 285     (condition-case nil
 286         (while evhs
 287           ;; Check is there appopriate event handler to handle XEV event.
 288           (when (and (X-EventHandler-active (car evhs))
 289                      (or (null (X-EventHandler-evtypes-list (car evhs)))
 290                          (memq (X-Event-type xev) (X-EventHandler-evtypes-list (car evhs)))))
 291             (funcall (X-EventHandler-handler (car evhs)) (X-Event-dpy xev) (X-Event-win xev) xev))
 292           (setq evhs (cdr evhs)))
 293       (X-Events-stop nil))))
 294
 295 ;;; X Events description.
 296
 297 ;; TODO:
 298 ;;   - Should be X-Dpy depended to support extensions derived events
 299 (X-Event-define X-KeyPress "xkey" (keycode nil time root event child root-x root-y event-x event-y state same-screen)
 300                 "KeyPress"
 301                ([1 integerp]           ; keycode
 302                 [2 integerp]           ; sequence
 303                 [4 integerp]           ; time
 304                 [4 :X-Win]             ; root
 305                 [4 :X-Win]             ; event  (WIN-EVENT)
 306                 [4 :X-Win]             ; child
 307                 [2 integerp]           ; root_x
 308                 [2 integerp]           ; root_y
 309                 [2 integerp]           ; event_x
 310                 [2 integerp]           ; event_y
 311                 [2 integerp]           ; state
 312                 [1 booleanp]           ; same_screen
 313                 [1 nil])
 314                4)
 315 (X-Event-declare X-KeyRelease
 316                  "KeyRelease"
 317                 ([1 integerp]          ; keycode
 318                  [2 integerp]          ; sequence
 319                  [4 integerp]          ; time
 320                  [4 :X-Win]            ; root
 321                  [4 :X-Win]            ; event
 322                  [4 :X-Win]            ; child
 323                  [2 integerp]          ; root_x
 324                  [2 integerp]          ; root_y
 325                  [2 integerp]          ; event_x
 326                  [2 integerp]          ; event_y
 327                  [2 integerp]          ; state
 328                  [1 booleanp]          ; same_screen
 329                  [1 nil])
 330                 4)
 331 (X-Event-define X-ButtonPress "xbutton" (button nil time root event child root-x root-y event-x event-y state same-screen)
 332                 "ButtonPress"
 333                ( [1 integerp]          ; button
 334                  [2 integerp]          ; sequence
 335                  [4 integerp]          ; time
 336                  [4 :X-Win]            ; root
 337                  [4 :X-Win]            ; event
 338                  [4 :X-Win]            ; child
 339                  [2 integerp]          ; root_x
 340                  [2 integerp]          ; root_y
 341                  [2 integerp]          ; event_x
 342                  [2 integerp]          ; event_y
 343                  [2 integerp]          ; state
 344                  [1 booleanp]          ; same_screen
 345                  [1 nil] )
 346                4)
 347 (X-Event-declare X-ButtonRelease
 348                  "ButtonRelease"
 349                 ( [1 integerp]         ; button
 350                   [2 integerp]         ; sequence
 351                   [4 integerp]         ; time
 352                   [4 :X-Win]           ; root
 353                   [4 :X-Win]           ; event
 354                   [4 :X-Win]           ; child
 355                   [2 integerp]         ; root_x
 356                   [2 integerp]         ; root_y
 357                   [2 integerp]         ; event_x
 358                   [2 integerp]         ; event_y
 359                   [2 integerp]         ; state
 360                   [1 booleanp]         ; same_screen
 361                   [1 nil] )
 362                 4)
 363 (X-Event-define X-MotionNotify "xmotion" (nil nil time root event child root-x root-y event-x event-y state same-screen)
 364                 "MotionNotify"
 365                ( [1 integerp]          ; detail
 366                  [2 integerp]          ; sequence
 367                  [4 integerp]          ; time
 368                  [4 :X-Win]            ; root
 369                  [4 :X-Win]            ; event
 370                  [4 :X-Win]            ; child
 371                  [2 integerp]          ; root_x
 372                  [2 integerp]          ; root_y
 373                  [2 integerp]          ; event_x
 374                  [2 integerp]          ; event_y
 375                  [2 integerp]          ; state
 376                  [1 booleanp]          ; same_screen
 377                  [1 nil] )
 378                4)
 379 (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)
 380                 "EnterNotify"
 381                ( [1 integerp]          ; detail
 382                  [2 integerp]          ; sequence
 383                  [4 integerp]          ; time
 384                  [4 :X-Win]            ; root
 385                  [4 :X-Win]            ; event
 386                  [4 :X-Win]            ; child
 387                  [2 integerp]          ; root_x
 388                  [2 integerp]          ; root_y
 389                  [2 integerp]          ; event_x
 390                  [2 integerp]          ; event_y
 391                  [2 integerp]          ; state
 392                  [1 integerp]          ; mode
 393                  [1 integerp])         ; same-screen, focus
 394                4)
 395 (X-Event-declare X-LeaveNotify
 396                  "LeaveNotify"
 397                 ( [1 integerp]         ; detail
 398                   [2 integerp]         ; sequence
 399                   [4 integerp]         ; time
 400                   [4 :X-Win]           ; root
 401                   [4 :X-Win]           ; event
 402                   [4 :X-Win]           ; child
 403                   [2 integerp]         ; root_x
 404                   [2 integerp]         ; root_y
 405                   [2 integerp]         ; event_x
 406                   [2 integerp]         ; event_y
 407                   [2 integerp]         ; state
 408                   [1 integerp]         ; mode
 409                   [1 integerp] )       ; same-screen, focus
 410                 4)
 411 (X-Event-define X-FocusIn "xfocus" (nil nil event mode)
 412                 "FocusIn"
 413                ( [1 integerp]          ; detail
 414                  [2 integerp]          ; sequence
 415                  [4 :X-Win]            ; event
 416                  [1 integerp]          ; mode
 417                  [23 nil] )
 418                2)
 419 (X-Event-declare X-FocusOut
 420                  "FocusOut"
 421                 ( [1 integerp]         ; detail
 422                   [2 integerp]         ; sequence
 423                   [4 :X-Win]           ; event
 424                   [1 integerp]         ; mode
 425                   [23 nil] )
 426                 2)
 427
 428 ;; TODO: X-KeymapNotify
 429
 430 (X-Event-define X-Expose "xexpose" (nil nil window x y width height count)
 431                 "Expose"
 432                ( [1 integerp]          ; detail
 433                  [2 integerp]          ; sequence
 434                  [4 :X-Win]            ; window
 435                  [2 integerp]          ; x
 436                  [2 integerp]          ; y
 437                  [2 integerp]          ; width
 438                  [2 integerp]          ; height
 439                  [2 integerp]          ; count
 440                  [14 nil] )
 441                2)
 442 (X-Event-define X-GraphicsExpose "xgraphicsexpose" (nil nil drawable x y width height minor-event count major-event)
 443                 "GraphicsExpose"
 444                ([1 integerp]
 445                 [2 integerp]
 446                 [4 integerp]           ; drawable
 447                 [2 integerp]           ; x
 448                 [2 integerp]           ; y
 449                 [2 integerp]           ; width
 450                 [2 integerp]           ; height
 451                 [2 integerp]           ; minorEvent
 452                 [2 integerp]           ; count
 453                 [1 integerp]           ; majorEvent
 454                 [11 nil])
 455                2)
 456 (X-Event-define X-NoExpose "xnoexpose" (nil nil drawable minor-event major-event)
 457                 "NoExpose"
 458                ([1 integerp]
 459                 [2 integerp]
 460                 [4 integerp]           ; drawable
 461                 [2 integerp]           ; minorEvent
 462                 [1 integerp]           ; majorEvent
 463                 [21 nil])
 464                2)
 465 (X-Event-define X-VisibilityNotify "xvisibility" (nil nil window state)
 466                 "VisibilityNotify"
 467                ([1 integerp]
 468                 [2 integerp]
 469                 [4 :X-Win]             ; window
 470                 [1 integerp]           ; state
 471                 [23 nil])
 472                2)
 473 (X-Event-define X-CreateNotify "xcreatewindow" (nil nil parent window x y width height border-width override)
 474                 "CreateNotify"
 475                ([1 integerp]           ; detail
 476                 [2 integerp]           ; sequence
 477                 [4 :X-Win]             ; parent window
 478                 [4 :X-Win]             ; window
 479                 [2 integerp]           ; x
 480                 [2 integerp]           ; y
 481                 [2 integerp]           ; width
 482                 [2 integerp]           ; height
 483                 [2 integerp]           ; border width
 484                 [1 booleanp]           ; override-redirect
 485                 [9 nil])
 486                2)
 487 (X-Event-define X-DestroyNotify "xdestroywindow" (nil nil event window)
 488                 "DestroyNotify"
 489                ( [1 integerp]          ; detail
 490                  [2 integerp]          ; sequence
 491                  [4 :X-Win]            ; event window
 492                  [4 :X-Win]            ; window
 493                  [20 nil])
 494                3 2)
 495 (X-Event-define X-UnmapNotify "xunmap" (nil nil event window from-configure)
 496                 "UnmapNotify"
 497                ( [1 integerp]          ; detail
 498                  [2 integerp]          ; sequence
 499                  [4 :X-Win]            ; event
 500                  [4 :X-Win]            ; window
 501                  [1 booleanp]          ; fromconfigure
 502                  [19 nil])
 503                3  2)
 504 (X-Event-define X-MapNotify "xmap" (nil nil event window override)
 505                 "MapNotify"
 506                ( [1 integerp]          ; detail
 507                  [2 integerp]          ; sequence
 508                  [4 :X-Win]            ; event window
 509                  [4 :X-Win]            ; window
 510                  [1 booleanp]          ; override-redirect
 511                  [19 nil])
 512                3 2)
 513 (X-Event-define X-MapRequest "xmaprequest" (nil nil parent window)
 514                 "MapRequest"
 515                ( [1 integerp]          ; detail
 516                  [2 integerp]          ; sequence
 517                  [4 :X-Win]            ; parent window
 518                  [4 :X-Win]            ; window
 519                  [20 nil])
 520                3 2)
 521 (X-Event-define X-ReparentNotify "xreparent" (nil nil event window parent x y override)
 522                 "ReparentNotify"
 523                ( [1 integerp]          ; detail
 524                  [2 integerp]          ; sequence
 525                  [4 :X-Win]            ; event
 526                  [4 :X-Win]            ; window
 527                  [4 :X-Win]            ; parent
 528                  [2 integerp]          ; x
 529                  [2 integerp]          ; y
 530                  [1 integerp]          ; override
 531                  [11 nil])
 532                3 2)
 533 (X-Event-define X-ConfigureNotify "xconfigure" (nil nil event window above-sibling x y width height border-width override-redirect)
 534                 "ConfigureNotify"
 535                ( [1 integerp]          ; detail
 536                  [2 integerp]          ; sequence
 537                  [4 :X-Win]            ; event
 538                  [4 :X-Win]            ; window
 539                  [4 :X-Win]            ; above-sibling
 540                  [2 integerp]          ; x
 541                  [2 integerp]          ; y
 542                  [2 integerp]          ; width
 543                  [2 integerp]          ; height
 544                  [2 integerp]          ; border-width
 545                  [1 booleanp]          ; override-redirect
 546                  [5 nil] )
 547                3 2)
 548 (X-Event-define X-ConfigureRequest "xconfigurerequest" (stackmode nil parent window sibling x y width height border-width value-mask)
 549                 "ConfigureRequest"
 550                ( [1 integerp]          ; detail
 551                  [2 integerp]          ; sequence
 552                  [4 :X-Win]            ; parent window
 553                  [4 :X-Win]            ; window
 554                  [4 :X-Win]            ; sibling
 555                  [2 integerp]          ; x
 556                  [2 integerp]          ; y
 557                  [2 integerp]          ; width
 558                  [2 integerp]          ; height
 559                  [2 integerp]          ; border width
 560                  [2 integerp]          ; value mask
 561                  [4 nil])
 562                3 2)
 563 (X-Event-define X-GravityNotify "xgravity" (nil nil event window x y)
 564                 "GravityNotify"
 565                ([1 integerp]
 566                 [2 integerp]
 567                 [4 :X-Win]             ; event window
 568                 [4 :X-Win]             ; window
 569                 [2 integerp]           ; x
 570                 [2 integerp]           ; y
 571                 [16 nil])
 572                3 2)
 573 (X-Event-define X-ResizeRequest "xresizerequest" (nil nil window width height)
 574                 "ResizeRequest"
 575                ( [1 integerp]          ; detail
 576                  [2 integerp]          ; sequence
 577                  [4 :X-Win]            ; window
 578                  [2 integerp]          ; width
 579                  [2 integerp]          ; height
 580                  [20 nil] )
 581                2)
 582 (X-Event-define X-CirculateNotify "xcirculate" (nil nil event window parent place)
 583                 "CirculateNotify"
 584                ([1 integerp]
 585                 [2 integerp]
 586                 [4 :X-Win]             ; event window
 587                 [4 :X-Win]             ; window
 588                 [4 :X-Win]             ; parent
 589                 [1 integerp]           ; place
 590                 [15 nil])
 591                3 2)
 592 ;; The event field in the xcirculate record is really the parent when this
 593 ;; is used as a CirculateRequest instead of a CircluateNotify
 594 (X-Event-declare X-CirculateRequest
 595                  "CirculateRequest"
 596                 ([1 integerp]
 597                  [2 integerp]
 598                  [4 :X-Win]            ; event window
 599                  [4 :X-Win]            ; window
 600                  [4 :X-Win]            ; parent
 601                  [1 integerp]          ; place
 602                  [15 nil])
 603                 3 2)
 604
 605 (X-Event-define X-PropertyNotify "xproperty" (nil nil window atom time state)
 606                 "PropertyNotify"
 607                ( [1 integerp]
 608                  [2 integerp]
 609                  [4 :X-Win]            ; window
 610                  [4 :X-Atom]           ; atom
 611                  [4 integerp]          ; time
 612                  [1 integerp]          ; state
 613                  [15 nil])
 614                2)
 615 (X-Event-define X-SelectionClear "xselectionclear" (nil nil time window atom)
 616                 "SelectionClear"
 617                ([1 integerp]
 618                 [2 integerp]
 619                 [4 integerp]           ; time
 620                 [4 :X-Win]             ; window
 621                 [4 :X-Atom]            ; atom
 622                 [16 nil])
 623                3)
 624 (X-Event-define X-SelectionRequest "xselectionrequest" (nil nil time owner requestor selection target property)
 625                 "SelectionRequest"
 626                ([1 integerp]
 627                 [2 integerp]
 628                 [4 integerp]           ; time
 629                 [4 :X-Win]             ; owner
 630                 [4 :X-Win]             ; requestor
 631                 [4 :X-Atom]            ; selection atom
 632                 [4 :X-Atom]            ; target atom
 633                 [4 :X-Atom]            ; property atom
 634                 [4 nil])
 635                4)
 636 (X-Event-define X-SelectionNotify "xselection" (nil nil time requestor selection target property)
 637                 "SelectionNotify"
 638                ([1 integerp]
 639                 [2 integerp]
 640                 [4 integerp]           ; time
 641                 [4 :X-Win]             ; requestor
 642                 [4 :X-Atom]            ; selection atom
 643                 [4 :X-Atom]            ; target atom
 644                 [4 :X-Atom]            ; property atom
 645                 [8 nil])
 646                3)
 647 (X-Event-define X-ColormapNotify "xcolormap" (nil nil window colormap new state)
 648                 "ColormapNotify"
 649                ([1 integerp]           ; detail
 650                 [2 integerp]           ; sequence
 651                 [4 :X-Win]             ; window
 652                 [4 integerp]           ; colormap
 653                 [1 booleanp]           ; new
 654                 [1 booleanp]           ; state
 655                 [18 nil])
 656                2)
 657 (X-Event-define X-ClientMessage "xclient" (nil window atom msg)
 658                 "ClientMessage"
 659                ([1 length-1]           ; format
 660                 [2 integerp]           ; sequence number
 661                 [4 :X-Win]             ; window
 662                 [4 :X-Atom]            ; atom
 663                 ;; This reads in the correct number of integers of a type
 664                 ;; specified by the format which is 8, 16, or 32.
 665                 [(/ 20 (/ length-1 8)) ( [ (/ length-1 8) integerp ] ) ] )
 666                1)
 667 (X-Event-define X-MappingNotify "xmapping" (nil nil request first-keycode count)
 668                 "MappingNotify"
 669                ([1 integerp]
 670                 [2 integerp]
 671                 [1 integerp]           ; request
 672                 [1 integerp]           ; firstKeyCode
 673                 [1 integerp]           ; count
 674                 [25 nil]))
 675
 676 ;; error event
 677 (X-Event-define 0 "xerror" (code nil resourceid min-op maj-op)
 678                 "XError"
 679                ([1 integerp]           ; err code
 680                 [2 integerp]           ; sequence
 681                 [4 integerp]           ; id
 682                 [2 integerp]           ; minor opcode
 683                 [1 integerp]           ; major opcode
 684                 [21 nil]))
 685
 686 ;;; All receive message types will exclude the first byte which IDs it.
 687 ;;
 688 ;; a symbol gets 'set, functions such as integerp mean turn it into that,
 689 ;; and put it into the return list. 'arg means use next arg as this value.
 690 (defun X-mod-4 (len)
 691   "Return a the number LEN moded to 4."
 692   (if (= (% len 4) 0) 0 (- 4 (% len 4))))
 693
 694 (defconst X-connect-response
 695   (list [1 success]
 696         (list [1 length-1]              ; fail message len
 697               [2 integerp]              ; major version
 698               [2 integerp]              ; minor version
 699               [2 length-2]              ; pad length
 700               [length-1 stringp]        ; error conditions
 701               [(X-mod-4 length-1) nil]  ; padding
 702               )
 703         (list [1 nil]                   ; successful list (this is unused)
 704               [2 integerp]              ; major version
 705               [2 integerp]              ; minor version
 706               [2 length-1]              ; len additional data (pad)
 707               [4 integerp]              ; release number
 708               [4 integerp]              ; resource id base
 709               [4 integerp]              ; resource id mask
 710               [4 integerp]              ; motion buffer size
 711               [2 length-2]              ; vendor length
 712               [2 integerp]              ; max request len
 713               [1 length-4]              ; number of screens
 714               [1 length-3]              ; number of formats in pix list
 715               [1 integerp]              ; image byte order
 716               [1 integerp]              ; bitmap byte order
 717               [1 integerp]              ; bitmap format scanline thingy
 718               [1 integerp]              ; bitmap format scanline pad
 719               [1 integerp]              ; min keycode
 720               [1 integerp]              ; max keycode
 721               [4 nil]                   ; unused
 722               [length-2 stringp]        ; the vendor
 723               [(X-mod-4 length-2) nil]  ; padding
 724               [length-3                 ; sublist of formats
 725                ( [1 integerp]           ; depth
 726                  [1 integerp]           ; bits/pixel
 727                  [1 integerp]           ; scanline-pad
 728                  [5 nil] ) ]            ; padding
 729               [length-4
 730                ( [4 integerp]           ; root window
 731                  [4 integerp]           ; colormap
 732                  [4 integerp]           ; white-pixel
 733                  [4 integerp]           ; black-pixel
 734                  [4 integerp]           ; event-flags
 735                  [2 integerp]           ; screen-width
 736                  [2 integerp]           ; screen-height
 737                  [2 integerp]           ; milimeters width
 738                  [2 integerp]           ; milimeters height
 739                  [2 integerp]           ; min-installed-maps
 740                  [2 integerp]           ; max installed maps
 741                  [4 integerp]           ; visualid
 742                  [1 integerp]           ; backingstores
 743                  [1 booleanp]           ; save-unders
 744                  [1 integerp]           ; root depth
 745                  [1 length-1]           ; # depths in depth
 746                  [length-1              ; list of depths
 747                   ( [1 integerp]        ; depth
 748                     [1 nil]
 749                     [2 length-1]        ; # visual types
 750                     [4 nil]
 751                     [length-1           ; the visuals
 752                      ( [4 integerp]     ; visual id
 753                        [1 integerp]     ; class
 754                        [1 integerp]     ; bits/rgb value
 755                        [2 integerp]     ; colormap entities
 756                        [4 integerp]     ; red mask
 757                        [4 integerp]     ; green mask
 758                        [4 integerp]     ; blue mask
 759                        [4 nil])
 760                      ] )
 761                   ] )
 762                ] )
 763         )
 764   "Connection response structure.")
 765
 766 (defun X-invalidate-cl-struct (cl-x)
 767   "Invalidate CL-X, after `X-invalidate-cl-struct' it won't be cl struct anymore.
 768 NOTE: works only if CL-X is vector."
 769   (if (vectorp cl-x)
 770       (let ((i (length cl-x)))
 771         (while (>= (setq i (1- i)) 0)
 772           (aset cl-x i nil))
 773         t)))
 774
 775 ;;; Protecting macros
 776 (defmacro X-Dpy-read-excursion (xdpy &rest forms)
 777   "Execute FORMS in reading mode."
 778   `(let ((gc-cons-threshold most-positive-fixnum)) ; inhibit GC'ing
 779      (incf (X-Dpy-readings ,xdpy))
 780      (prog1
 781          (condition-case err
 782              (progn ,@forms)
 783            (t (decf (X-Dpy-readings ,xdpy))
 784               (apply 'error (car err) (cdr err))))
 785        (decf (X-Dpy-readings ,xdpy)))))
 786 (put 'X-Dpy-read-excursion 'lisp-indent-function 1)
 787
 788 (defun X-Dpy-send-read (xdpy s rf)
 789   "Send S to display XDPY and receive answer according to receive fields RF."
 790   (let ((reqid (X-Dpy-rseq-id xdpy)))   ; Remember request id
 791     (X-Dpy-read-excursion xdpy
 792       ;; Flush output buffer
 793       (X-Dpy-send xdpy s)
 794       (X-Dpy-send-flush xdpy)
 795       (X-Dpy-parse-message rf reqid xdpy))))
 796
 797 ;;;###autoload
 798 (defvar X-default-timeout 60
 799   "This should be big enought, larger than any XEmacs blocking.")
 800
 801 ;;; Reading and parsing
 802 (defun X-Dpy-grab-bytes (xdpy num &optional to-secs to-msecs)
 803   "On display XDPY, wait for at least NUM bytes and return string."
 804   (X-Dpy-p xdpy 'X-Dpy-grab-bytes)
 805
 806   (let (rstr)
 807     (while (< (length (X-Dpy-message-buffer xdpy)) num)
 808       (when (null (accept-process-output (X-Dpy-proc xdpy)
 809                                          (or to-secs X-default-timeout) (or to-msecs 0)))
 810         ;; Timeouted
 811         (error "X: Timeout while reading from server.")))
 812
 813     (setq rstr (substring (X-Dpy-message-buffer xdpy) 0 num)) ; save bytes to string
 814
 815     ;; Update message-buffer
 816     (setf (X-Dpy-message-buffer xdpy)
 817           (substring (X-Dpy-message-buffer xdpy) num))
 818     rstr))
 819
 820 ;; These are defined so we can use them recursivly below
 821 (defvar length-1 nil)
 822 (defvar length-2 nil)
 823 (defvar length-3 nil)
 824 (defvar length-4 nil)
 825
 826 (defun X-Dpy-parse-message (message-s req-id xdpy &rest arglist)
 827   "Receive (via filter and waiting) a response from  the X server.
 828 Parses MESSAGE-S structure.  When MAY-GUESS is t then if 1st el is not 1 or 0,
 829 we must process as an event instead.  Then keep looping on guess until we get
 830 a 0 or 1.  If not, then we are processing sub-lists.  Processing is done for
 831 XDPY.  ARGLIST is some list of arguments.
 832
 833 When FROM-X-PARSE-MESSAGE is non-nil than we are called from `X-Dpy-parse-message'.
 834
 835 MESSAGE-S is made of size vectors `X-Dpy-create-message':
 836
 837   [SIZE ENCODING]
 838
 839   SIZE is how many bytes it occupies in the message.
 840   ENCODING is how to interpret it.
 841
 842   If encoding is 'success, then the following vectors are two lists.
 843 The first is the Failure case.  nil is a generic failure.
 844 The second is the Success case.
 845
 846   Encoding can also be one of the following:
 847   nil      -- Not used
 848   integerp -- Format integer
 849   stringp  -- Formatted string
 850   length-# -- Number stored in variable `length-#' where # is 0-4.
 851
 852 The length-# variables are used to read a length from one section
 853 of a message, and use it as the size field of a later occuring field.
 854 A variable-length string can occur like this:
 855
 856   [2 length-0]       ; length of string, does not appear in the list
 857   [length-0 stringp] ; name"
 858
 859   (X-Dpy-p xdpy 'X-Dpy-parse-message)
 860
 861   (let ((inhibit-quit t)                ; so C-g will not desync
 862         (rlist nil)
 863         (reverse-me t)
 864         (length-1 (if (boundp 'length-1) length-1 nil))
 865         (length-2 (if (boundp 'length-2) length-2 nil))
 866         (length-3 (if (boundp 'length-3) length-3 nil))
 867         (length-4 (if (boundp 'length-4) length-4 nil)) )
 868     (while (and message-s (listp message-s))
 869       (let* ((tvec (car message-s))
 870              (tlen (aref tvec 0))
 871              (tval1 (aref tvec 1))
 872              (tval (if (and (listp tval1)
 873                             (member (car tval1) '(or if cond))) ;XXX
 874                        (eval tval1)
 875                      tval1))
 876              (result (unless (and tval (listp tval))
 877                        ;; Do not grab bytes for sub-lists
 878                        (if (or (symbolp tlen) (listp tlen))
 879                            (X-Dpy-grab-bytes xdpy (eval tlen))
 880                          (X-Dpy-grab-bytes xdpy tlen)))))
 881
 882         ;; We need to put in code to represent sizes sometimes,
 883         ;; this will get that size.
 884         (when (or (listp tlen) (symbolp tlen))
 885           (setq tlen (eval tlen)))
 886
 887         ;; Check for use of an argument.
 888         (when (equal tval 'arg)
 889           (setq tval (car arglist))
 890           (setq arglist (cdr arglist)))
 891
 892         ;; If the val is a list, and it is an if statement, then
 893         ;; we want to evaluate it to get the real tval type.
 894         (when (and (listp tval)
 895                    (member (car tval) '(if or make-list)))
 896           (setq tval (eval tval)))
 897
 898         (cond
 899          ;; boolean success stories.
 900          ((equal tval 'success)
 901           (let ((sublst
 902                  (cond ((= (aref result 0) 1)
 903                         ;; success condition
 904                         (setq result t)
 905                         (X-Dpy-parse-message (car (cdr (cdr message-s)))
 906                                              req-id xdpy arglist))
 907
 908                        (t
 909                         ;; Here is event or error arrived, process
 910                         ;; errors in time or store event in events
 911                         ;; queue.
 912                         (X-Dpy-log xdpy 'x-event "!!: Inter Evaluating event ..")
 913                         (let ((xev (X-Dpy-parse-event
 914                                     xdpy (Xforcenum (aref result 0))))
 915                               pmsg)
 916                           (prog1
 917                               (if (and (= (X-Event-type xev) 0)
 918                                        (= (X-Event-seq xev)
 919                                           (logand req-id 65535)))
 920                                   ;; Error of current request
 921                                   (setq result nil)
 922
 923                                 ;; Repeat processing XXX excluding t or nil
 924                                 (X-Dpy-log xdpy 'x-event "!!: Reprocessing: %d bytes pending, msg=%S"
 925                                            '(length (X-Dpy-message-buffer xdpy)) 'message-s)
 926                                 (setq pmsg (X-Dpy-parse-message
 927                                             message-s req-id xdpy arglist)
 928                                       result (car pmsg))
 929                                 (X-Dpy-log xdpy 'x-event "!!: Reprocessing done %d bytes pending."
 930                                            '(length (X-Dpy-message-buffer xdpy)))
 931                                 (cdr pmsg))
 932                             (X-Dpy-dispatch-event xev)))))))
 933             (setq rlist (cons result sublst)))
 934
 935           (setq message-s nil)
 936           (setq reverse-me nil))
 937
 938          ;; numberp means natural number, not safe!
 939          ((eq tval 'numberp)
 940           (setq rlist (cons (funcall (if (<= tlen 2)
 941                                          'string2->number
 942                                        'string4->number) result)
 943                             rlist)))
 944
 945          ;; integerp means tac onto end of list as an int
 946          ((eq tval 'integerp)
 947           (if (<= tlen 2)
 948               (setq rlist (cons (string->int result) rlist))
 949             (setq rlist (cons (string4->int result) rlist))))
 950
 951          ;; stringp means tac onto end of list as string (verbatim)
 952          ((eq tval 'stringp)
 953           (setq rlist (cons result rlist)))
 954
 955          ;; booleans don't really exist, but turn a 0 into nil, and 1 into t
 956          ((eq tval 'booleanp)
 957           (setq rlist (cons (if (= 0 (string->int result)) nil t) rlist)))
 958
 959          ;; TODO: maybe add card8, card16, card32, int8, int16, int32,
 960          ;; string8, string16, etc?
 961
 962          ;; Special forms
 963          ((eq tval :X-Rect)
 964           (setq tlen (/ tlen 8))
 965           (while (> tlen 0)
 966             (setq rlist (cons (make-X-Rect :x (string->int (substring result 0 2))
 967                                            :y (string->int (substring result 2 4))
 968                                            :width (string->int (substring result 4 6))
 969                                            :height (string->int (substring result 6 8)))
 970                               rlist))
 971             (setq result (substring result 8))
 972             (setq tlen (1- tlen))))
 973
 974          ((eq tval :X-Win)
 975           (setq tlen (/ tlen 4))
 976           (while (> tlen 0)
 977             (setq rlist (cons (X-Win-find-or-make xdpy (string4->int result))
 978                               rlist))
 979             (setq result (substring result 4))
 980             (setq tlen (1- tlen))))
 981
 982          ((eq tval :X-Atom)
 983           (setq tlen (/ tlen 4))
 984           (while (> tlen 0)
 985             (setq rlist (cons (X-Atom-find-or-make xdpy (string4->int result))
 986                               rlist))
 987             (setq result (substring result 4))
 988             (setq tlen (1- tlen))))
 989
 990          ;; if it is a list, then we need to recursivly call ourselvs X
 991          ;; times on it.
 992          ((and tval (listp tval))
 993           ;; WARNING: subparts cannot use args. ;(
 994           (let ((sublst nil))
 995             (while (> tlen 0)
 996               (setq sublst (cons (X-Dpy-parse-message tval req-id xdpy arglist) sublst))
 997               (setq tlen (1- tlen)))
 998             ;; The sub-list of items is backwards: fix
 999             (setq rlist (cons (nreverse sublst) rlist))))
1000
1001          ;; not a type, but some other symbol, then put it there!
1002          ;; if it is one of the lengththings, intify it.
1003          ((and tval (symbolp tval) (not (keywordp tval)))
1004           (if (string-match "length" (symbol-name tval))
1005               (set tval (string->int result))
1006             (set tval result)))
1007
1008          ;; do nothing
1009          ((equal tval nil))
1010
1011          ;; error case.
1012          (t
1013           (error "Error parsing X response!!!"))))
1014       (setq message-s (cdr message-s)))
1015
1016     ;; Now that that is over, conditionally reverse the list.
1017     (if reverse-me
1018         (nreverse rlist)
1019       rlist)))
1020
1021 (defun X-Dpy-eval-error-or-event (xdpy)
1022   "There data on XDPY, it is error or event."
1023   (X-Dpy-read-excursion xdpy
1024     (let* ((result (X-Dpy-grab-bytes xdpy 1))
1025            (evetype (Xforcenum (aref result 0))))
1026
1027       (cond ((= evetype 1)              ; reply, should not happen
1028              (X-Dpy-log xdpy 'x-error "Got unknown reply, while expecting XEvent! CRITICAL!")
1029              (error "Got unknown reply, while expecting XEvent!"))
1030             ;; Below code is not quite correct.  Because X exntensions
1031             ;; that generates events may use values greater then
1032             ;; X-MaxEvent.
1033 ;            ((>= evetype X-MaxEvent)
1034 ;            (X-Dpy-log xdpy 'x-error "Got XEvent id(%d) greater than X-MaxEvent! CRITICAL!"
1035 ;                       'evetype)
1036 ;             (error (format "Got X Event id(%d) greater than X-MaxEvent!" evetype)))
1037             (t (X-Dpy-dispatch-event
1038                 (X-Dpy-parse-event xdpy evetype)))) ; error or event
1039       )))
1040
1041 ;; Events/Errors dispatchers
1042 (defvar xlib-opcodes-alist
1043   '((104 . XBell)
1044     (1 . XCreateWindow)
1045     (2 . XChangeWindowAttributes)
1046     (3 . XGetWindowAttributes)
1047     (12 . XConfigureWindow)
1048     (8 . XMapWindow)
1049     (10 . XUnmapWindow)
1050     (4 . XDestroyWindow)
1051     (5 . XDestroySubwindows)
1052     (15 . XQueryTree)
1053     (16 . XInternAtom)
1054     (17 . XGetAtomName)
1055     (18 . XChangeProperty)
1056     (20 . XGetWindowProperty)
1057     (78 . XCreateColormap)
1058     (79 . XFreeColormap)
1059     (84 . XAllocColor)
1060     (85 . XAllocNamedColor)
1061     (86 . XAllocColorCells)
1062     (89 . XStoreColors)
1063     (88 . XFreeColors)
1064     (91 . XQueryColors)
1065     (55 . XCreateGC)
1066     (56 . XChangeGC)
1067     (58 . XSetDashes)
1068     (59 . XSetClipRectangles)
1069     (60 . XFreeGC)
1070     (61 . XClearArea)
1071     (62 . XCopyArea)
1072     (63 . XCopyPlane)
1073     (64 . XDrawPoints)
1074     (65 . XDrawLines)
1075     (69 . XFillPoly)
1076     (66 . XDrawSegments)
1077     (67 . XDrawRectangles)
1078     (70 . XDrawRectangles)
1079     (68 . XDrawArcs)
1080     (71 . XDrawArcs)
1081     (74 . XDrawString)
1082     (76 . XImageString)
1083     (72 . XPutImage)
1084     (73 . XGetImage)
1085     (22 . XSetSelectionOwner)
1086     (23 . XGetSelectionOwner)
1087     (24 . XConvertSelection)
1088     (41 . XWarpPointer)
1089     (36 . XGrabServer)
1090     (37 . XUngrabServer)
1091     (38 . XQueryPointer)
1092     (31 . XGrabKeyboard)
1093     (32 . XUngrabKeyboard)
1094     (26 . XGrabPointer)
1095     (27 . XUngrabPointer)
1096     (28 . XGrabButton)
1097     (29 . XUngrabButton)
1098     (33 . XGrabKey)
1099     (34 . XUngrabKey)
1100     (43 . XGetInputFocus)
1101     (42 . XSetInputFocus)
1102     (7 . XReparentWindow)
1103     (14 . XGetGeometry)
1104     (40 . XTranslateCoordinates)
1105     (6 . XChangeSaveSet)
1106     (25 . XSendEvent)
1107     (44 . XQueryKeymap)
1108     (101 . XGetKeyboardMapping)
1109     (119 . XGetModifierMapping)
1110     (45 . XOpenFont)
1111     (47 . XQueryFont)
1112     (48 . XQueryTextExtents)
1113     (53 . XCreatePixmap)
1114     (54 . XFreePixmap)
1115     (93 . XCreateCursor)
1116     (94 . XCreateGlyphCursor)
1117     (95 . XFreeCursor)
1118     (96 . XRecolorCursor)
1119     (30 . XChangeActivePointerGrab)
1120     (98 . XQueryExtension)
1121     (107 . XSetScreenSaver)
1122     (108 . XGetScreenSaver)
1123     (113 . XKillClient)
1124     (115 . XForceScreenSaver))
1125   "Alist of X opcodes in form (OPCODE . FUNCTION).
1126 This is only informative variable.")
1127
1128 (defun X-Dpy-run-error-hooks (xdpy xev)
1129   "Run XDPY's error hooks."
1130   (when (X-Dpy-error-hooks xdpy)
1131     (mapcar #'(lambda (fun)
1132                 (funcall fun xdpy xev))
1133             (X-Dpy-error-hooks xdpy))))
1134
1135 (defun X-Dpy-error-dispatch (xev)
1136   "Dispatch error event XEV."
1137   (let* ((xdpy (X-Event-dpy xev))
1138          (err (X-Event-xerror-code xev))
1139          (badth (X-Event-xerror-resourceid xev))
1140          (seq (X-Event-seq xev))
1141          (maj (X-Event-xerror-maj-op xev))
1142          (opfun (cdr (assq maj xlib-opcodes-alist)))
1143          (min (X-Event-xerror-min-op xev))
1144          (bstr (cond ((= err 1) "Request")
1145                      ((= err 2) "Value")
1146                      ((= err 3) "Window")
1147                      ((= err 4) "Pixmap")
1148                      ((= err 5) "Atom")
1149                      ((= err 6) "Cursor")
1150                      ((= err 7) "Font")
1151                      ((= err 8) "Match")
1152                      ((= err 9) "Drawable")
1153                      ((= err 10) "Access")
1154                      ((= err 11) "Alloc")
1155                      ((= err 12) "Color")
1156                      ((= err 13) "GC")
1157                      ((= err 14) "IDChoice")
1158                      ((= err 15) "Name")
1159                      ((= err 16) "Length")
1160                      ((= err 17) "Implementation")
1161                      ((= err 128) "FirstExtension")
1162                      ((= err 255) "LastExtension")
1163                      (t "Unknown"))))
1164     (declare (special bstr))
1165     (declare (special min))
1166     (declare (special opfun))
1167     (declare (special seq))
1168     (declare (special badth))
1169     (X-Dpy-log xdpy 'x-error "X-Error: Bad %s %f seq=%f:%d ops=%d:%d/%S"
1170                'bstr 'badth 'seq '(X-Dpy-rseq-id xdpy) 'maj 'min 'opfun)
1171
1172     ;; Now run hooks if any
1173     (X-Dpy-run-error-hooks xdpy xev)))
1174
1175 ;;; Some usefull macroses (NOT USED)
1176 (defmacro X-Generic-enqueue (obj queue)
1177   "Enqueue object QBJ into setf'able QUEUE."
1178   `(if (null ,queue)
1179        (setf ,queue (list ,obj))
1180      (setcdr (last ,queue) (list ,obj))))
1181
1182 (defmacro X-Generic-prequeue (obj queue)
1183   "Prepend object OBJ into setf'able QUEUE."
1184   `(setf ,queue (cons ,obj ,queue)))
1185
1186 (defmacro X-Generic-dequeue (queue)
1187   "Dequeue first object from setf'able QUEUE."
1188   `(let ((obj (car ,queue)))
1189      (setf ,queue (cdr ,queue))
1190      obj))
1191
1192 ;;; Events queue support
1193 (defun X-Dpy-default-events-dispatcher (xdpy xev)
1194   "Default events  dispatcher."
1195   (let ((win-ev (X-Event-win-event xev)))
1196     (when (X-Win-p win-ev)
1197       ;; First run display handlers
1198       (when (X-Dpy-event-handlers xdpy)
1199        (X-Dpy-EventHandler-runall xdpy xev))
1200
1201       ;; Then run WIN specific handlers
1202       (when (X-Win-event-handlers win-ev)
1203        ;; WIN has its own event handlers
1204        (X-Win-EventHandler-runall win-ev xev)))))
1205
1206 (defun X-Dpy-event-dispatch (xev)
1207   "Dispatch event XEV."
1208   (let ((xdpy (X-Event-dpy xev)))
1209     (X-Dpy-log xdpy 'x-event "Got X event: %S for win %S / %S"
1210                '(X-Event-name xev)
1211               '(if (X-Win-p (X-Event-win-event xev))
1212                    (X-Win-id (X-Event-win-event xev))
1213                  (X-Event-win-event xev))
1214               '(if (X-Win-p (X-Event-win xev))
1215                    (X-Win-id (X-Event-win xev))
1216                  (X-Event-win xev)))
1217
1218     (when (X-Dpy-events-dispatcher xdpy)
1219       (funcall (X-Dpy-events-dispatcher xdpy) xdpy xev))))
1220
1221 (defsubst X-Dpy-event-enqueue (event)
1222   "Enqueue EVENT in XDPY's events queue."
1223   (enqueue-eval-event 'X-Dpy-event-dispatch event))
1224
1225 (defun X-Dpy-dispatch-event (xev)
1226   "Dispatch X Event or error XEV."
1227   (if (= (X-Event-type xev) 0)
1228       (X-Dpy-error-dispatch xev)
1229     (X-Dpy-event-enqueue xev)))
1230
1231 (defun X-Dpy-parse-event (xdpy evtype)
1232   "On XDPY construct and enqueue event of EVTYPE type."
1233   ;; TODO: what about X-Event-evdata?
1234   ;;   (evdata (substring (X-Dpy-message-buffer xdpy) 0 31))
1235   ;;   :evdata (concat (char-to-string (XCharacter type)) evdata)
1236   (X-Dpy-read-excursion xdpy
1237     (let* ((type evtype)
1238            (synth (= (logand X-SyntheticMask type) X-SyntheticMask))
1239            (type (if synth (- type X-SyntheticMask) type))
1240            (xev (make-X-Event :dpy xdpy :type type :synth-p synth))
1241            (evspec (aref X-EventsList type))
1242            (evin (X-Dpy-parse-message (or (and evspec (aref evspec 1)) (list [31 nil])) 0 xdpy)))
1243       (setf (X-Event-evinfo xev) evin)
1244
1245       (X-Dpy-log xdpy 'x-event "XLIB: Get new event %d(%s) win=%S ...."
1246                  '(X-Event-type xev) '(X-Event-name xev)
1247                  '(and (X-Win-p (X-Event-win xev))
1248                        (X-Win-id (X-Event-win xev))))
1249
1250       xev)))
1251
1252 ;;; Function to call when there data in XDPY, but noone reading it.
1253 (defun X-Dpy-parse-message-guess (xdpy)
1254   "There is data waiting on XDPY, but no-one is reading it.
1255 Try to guess what it is."
1256   (X-Dpy-p xdpy 'X-Dpy-parse-message-guess)
1257
1258   ;; If no-one reading now, mean than error or event arrived.
1259   (while (and (zerop (X-Dpy-readings xdpy))
1260               (> (length (X-Dpy-message-buffer xdpy)) 0))
1261     (X-Dpy-eval-error-or-event xdpy)))
1262
1263 \f
1264 (provide 'xlib-xr)
1265
1266 ;;; xlib-xr.el ends here