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

   1 ;;; xlib-xrecord.el --- RECORD extension for xlib.
   2
   3 ;; Copyright (C) 2003-2005 by XWEM Org.
   4
   5 ;; Author: Zajcev Evgeny <zevlg@yandex.ru>
   6 ;; Created: 18 October 2003
   7 ;; Keywords: xlib, xwem
   8 ;; X-CVS: $Id: xlib-xrecord.el,v 1.8 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 ;; We need to open two connections to X server to use RECORD
  32 ;; extension, one for RC controling and second for data transfer,
  33 ;; `X-XRecordEnableContext' should be issued on data connection.
  34
  35 ;; Range8, Range16 is cons cells in form (FIRST . LAST)
  36 ;;
  37 ;; ExtRange is cons cell in form (MAJOR-Range8 . MINOR-Range16)
  38
  39 ;;; Code:
  40 \f
  41 (eval-when-compile
  42   (require 'cl))
  43
  44 (require 'xlib-xlib)
  45
  46 (defconst X-XRecord-major 1)
  47 (defconst X-XRecord-minor 13)
  48
  49 (defconst X-XRecord-op-QueryVersion 0)
  50 (defconst X-XRecord-op-CreateContext 1)
  51 (defconst X-XRecord-op-RegisterClients 2)
  52 (defconst X-XRecord-op-UnregisterClients 3)
  53 (defconst X-XRecord-op-GetContext 4)
  54 (defconst X-XRecord-op-EnableContext 5)
  55 (defconst X-XRecord-op-DisplayContext 6)
  56 (defconst X-XRecord-op-FreeContext 7)
  57
  58 ;; element-header
  59 (defconst X-XRecordFromServerTime (Xmask 0))
  60 (defconst X-XRecordFromClientTime (Xmask 1))
  61 (defconst X-XRecordFromClientSequence (Xmask 2))
  62
  63 (defconst X-XRecordCurrentClients 1)
  64 (defconst X-XRecordFutureClients 2)
  65 (defconst X-XRecordAllClients 3)
  66
  67 (defconst X-XRecordFromServer 0)
  68 (defconst X-XRecordFromClient 1)
  69 (defconst X-XRecordClientStarted 2)
  70 (defconst X-XRecordClientDied 3)
  71 (defconst X-XRecordStartOfData 4)
  72 (defconst X-XRecordEndOfData 5)
  73
  74 \f
  75 ;; Message generators
  76 (defsubst X-RecordRange8-message (xrr8)
  77   "Return a string representing the record range8 XRR8."
  78   (if (null xrr8)
  79       (make-string 2 ?\x00)
  80     (concat (int->string1 (car xrr8)) (int->string1 (cdr xrr8)))))
  81
  82 (defsubst X-RecordRange16-message (xrr16)
  83   "Return a string representing the record range16 XRR16."
  84   (if (null xrr16)
  85       (make-string 4 ?\x00)
  86     (concat (int->string2 (car xrr16)) (int->string2 (cdr xrr16)))))
  87
  88 (defsubst X-RecordExtrange-message (xer)
  89   "Return a string representing the extrange XER."
  90   (if (null xer)
  91       (make-string 12 ?\x00)
  92     (concat (X-RecordRange8-message (car xer)) (X-RecordRange16-message (cdr xer)))))
  93
  94 (defsubst X-RecordRange-message (xrr)
  95   "Return a string representing the record range XRR."
  96   (X-Generate-simple-message 'X-RecordRange xrr))
  97
  98 (defsubst X-RecordClientSpec-message (xrcs)
  99   "Return a string representing the client spec XRCS."
 100   (int->string4 xrcs))
 101
 102 (defstruct (X-RecordContext (:predicate X-RecordContext-isrc-p))
 103   dpy id
 104   props)                                ; User defined plist
 105
 106 (defstruct (X-RecordExtrange (:predicate X-RecordExtrange-isrer-p))
 107   major                                 ; X-RecordRange8
 108   minor                                 ; X-RecordRange16
 109   ;; List of extractors
 110   (list '(((lambda (re)
 111              (X-RecordRange8-message (X-RecordExtrange-major re))) . 2)
 112           ((lambda (re)
 113              (X-RecordRange16-message (X-RecordExtrange-minor re))) . 4)))
 114   )
 115
 116 (defstruct (X-RecordRange (:predicate X-RecordRange-isrr-p))
 117   core-requests                         ; X-RecordRange8
 118   core-replies                          ; X-RecordRange8
 119   ext-requests                          ; X-RecordExtrange
 120   ext-replies                           ; X-RecordExtrange
 121   delivered-events                      ; X-RecordRange8
 122   device-events                         ; X-RecordRange8
 123   errors                                ; X-RecordRange8
 124   client-started                        ; BOOL
 125   client-died                           ; BOOL
 126   ;; List of extractors
 127   (list (list
 128          (cons #'(lambda (rr)
 129                    (X-RecordRange8-message (X-RecordRange-core-requests rr)))
 130                2)
 131          (cons #'(lambda (rr)
 132                    (X-RecordRange8-message (X-RecordRange-core-replies rr)))
 133                2)
 134          (cons #'(lambda (rr)
 135                    (X-RecordExtrange-message (X-RecordRange-ext-requests rr)))
 136                6)
 137          (cons #'(lambda (rr)
 138                    (X-RecordExtrange-message (X-RecordRange-ext-replies rr)))
 139                6)
 140          (cons #'(lambda (rr)
 141                    (X-RecordRange8-message (X-RecordRange-delivered-events rr)))
 142                2)
 143          (cons #'(lambda (rr)
 144                    (X-RecordRange8-message (X-RecordRange-device-events rr)))
 145                2)
 146          (cons #'(lambda (rr)
 147                    (X-RecordRange8-message (X-RecordRange-errors rr)))
 148                2)
 149          (cons 'X-RecordRange-client-started 1)
 150          (cons 'X-RecordRange-client-died 1))))
 151
 152 (defstruct (X-RecordClientInfo (:predicate X-RecordClientInfo-isrci-p))
 153   client-spec                           ; X-RecordClientSpec
 154   ranges)                               ; list of X-RecordRange
 155
 156 (defstruct X-RecordState
 157   enabled                               ; BOOL
 158   datum-flags                           ; int
 159   client-infos                          ; list of X-RecordClientInfo
 160   )
 161
 162 \f
 163 ;; Predicates
 164 (defsubst X-RecordContext-p (xrc &optional sig)
 165   (X-Generic-p 'X-RecordContext 'X-RecordContext-isrc-p xrc sig))
 166
 167 (defsubst X-RecordRange8-p (xrr8 &optional sig)
 168   (or (null xrr8) (consp xrr8)))
 169
 170 (defsubst X-RecordRange16-p (xrr16 &optional sig)
 171   (or (null xrr16) (consp xrr16)))
 172
 173 (defsubst X-RecordExtrange-p (xrer &optional sig)
 174   (or (null xrer) (and (consp xrer) (X-RecordRange8-p (car xrer)) (X-RecordRange16-p (cdr xrer)))))
 175
 176 (defsubst X-RecordRange-p (xrr &optional sig)
 177   (X-Generic-p 'X-RecordRange 'X-RecordRange-isrr-p xrr sig))
 178
 179 (defsubst X-RecordClientSpec-p (xrcs &optional sig)
 180   (floatp xrcs))
 181
 182 (defsubst X-RecordClientInfo-p (xrci &optional sig)
 183   (X-Generic-p 'X-RecordClientInfo 'X-RecordClientInfo-isrci-p xrci sig))
 184
 185 \f
 186 ;;; Functions
 187 (defun X-XRecordQueryVersion (xdpy &optional major minor)
 188   "On display XDPY query for version of record extension."
 189   (X-Dpy-p xdpy 'X-XRecordQueryVersion)
 190
 191   (let* ((xrec-ext (X-Dpy-get-extension xdpy "RECORD"))
 192          (ListOfFields
 193           (list (vector 1 (nth 4 xrec-ext)) ; opcode
 194                 [1 X-XRecord-op-QueryVersion]
 195                 [2 2]                   ;length
 196
 197                 [2 (or major X-XRecord-major)]
 198                 [2 (or minor X-XRecord-minor)]))
 199          (msg (X-Create-message ListOfFields))
 200          (ReceiveFields
 201           (list [1 success]             ;success field
 202                 nil
 203                 (list [1 nil]           ;not used
 204                       [2 integerp]      ;sequence number
 205                       [4 nil]           ;length
 206                       [2 integerp]      ;major version
 207                       [2 integerp]      ;minor version
 208                       [20 nil]))))      ;pad
 209     (and (car xrec-ext)
 210          (X-Dpy-send-read xdpy msg ReceiveFields))))
 211
 212 (defun X-XRecordCreateContext (xdpy rc elhead clspecs ranges)
 213   "ELHEAD is contructed using `Xmask-or' and values
 214 `X-XRecordFromServerTime', `X-XRecordFromClient' and
 215 `X-XRecordFromClientSequence'.
 216
 217 CLSPECS is list of X-RecordClientSpec
 218 RANGES is list of X-RecordRange."
 219   (X-Dpy-p xdpy 'X-XRecordCreateContext)
 220
 221   (let* ((xrec-ext (X-Dpy-get-extension xdpy "RECORD" 'X-XRecordCreateContext))
 222          (ListOfFields
 223           (list (vector 1 (nth 4 xrec-ext)) ;opcode
 224                 [1 X-XRecord-op-CreateContext]
 225                 [2 (+ 5 (length clspecs) (* 6 (length ranges)))] ;length
 226
 227                 [4 (X-RecordContext-id rc)] ; context
 228                 [1 elhead]
 229                 [3 nil]                 ; not used
 230                 [4 (length clspecs)]
 231                 [4 (length ranges)]))
 232          (msg (concat (X-Create-message ListOfFields)
 233                       (X-Generate-message-for-list clspecs 'X-RecordClientSpec-message)
 234                       (X-Generate-message-for-list ranges 'X-RecordRange-message))))
 235     (X-Dpy-send xdpy msg)
 236     rc))
 237
 238 (defun X-XRecordRegisterClients (xdpy rc elhead clspecs ranges)
 239   "On display XDPY, register CLSPECS for intercepting in record context RC."
 240   (X-Dpy-p xdpy 'X-XRecordRegisterClients)
 241   (X-RecordContext-p rc 'X-XRecordRegisterClients)
 242
 243   (let* ((xrec-ext (X-Dpy-get-extension xdpy "RECORD" 'X-XRecordRegisterClients))
 244          (ListOfFields
 245           (list (vector 1 (nth 4 xrec-ext)) ; opcode
 246                 [1 X-XRecord-op-RegisterClients]
 247                 [2 (+ 5 (length clspecs) (* 6 (length ranges)))] ; length
 248                 [4 (X-RecordContext-id rc)]
 249                 [1 elhead]
 250                 [3 nil]                 ; not used
 251                 [4 (length clspecs)]
 252                 [4 (length ranges)]))
 253          (msg (concat (X-Create-message ListOfFields)
 254                       (X-Generate-message-for-list clspecs 'X-RecordClientSpec-message)
 255                       (X-Generate-message-for-list ranges 'X-RecordRange-message))))
 256     (X-Dpy-send xdpy msg)))
 257
 258 (defun X-XRecordUnregisterClients (xdpy rc clspecs)
 259   "On display XDPY in record context RC unregister clients in CLSPECS."
 260   (X-Dpy-p xdpy 'X-XRecordRegisterClients)
 261   (X-RecordContext-p rc 'X-XRecordRegisterClients)
 262
 263   (let* ((xrec-ext (X-Dpy-get-extension xdpy "RECORD" 'X-XRecordRegisterClients))
 264          (ListOfFields
 265           (list (vector 1 (nth 4 xrec-ext)) ; opcode
 266                 [1 X-XRecord-op-UnregisterClients]
 267                 [2 (+ 3 (length clspecs))] ; length
 268                 [4 (X-RecordContext-id rc)]
 269                 [4 (length clspecs)]))
 270          (msg (concat (X-Create-message ListOfFields)
 271                       (X-Generate-message-for-list clspecs 'X-RecordClientSpec-message))))
 272     (X-Dpy-send xdpy msg)))
 273
 274 (defun X-XRecordGetContext (xdpy rc)
 275   "On display XDPY get context for RC."
 276   (X-Dpy-p xdpy 'X-XRecordGetContext)
 277   (X-RecordContext-p rc 'X-XRecordRegisterClients)
 278
 279   (let* ((xrec-ext (X-Dpy-get-extension xdpy "RECORD" 'X-XRecordGetContext))
 280          (ListOfFields
 281           (list (vector 1 (nth 4 xrec-ext)) ; opcode
 282                 [1 X-XRecord-op-GetContext]
 283                 [2 2]                   ; length
 284                 [4 (X-RecordContext-id rc)])) ; context
 285          (msg (concat (X-Create-message ListOfFields)))
 286          (ReceiveFields
 287           (list [1 success]             ;success field
 288                 nil
 289                 (list [1 integerp]      ;enabled
 290                       [2 integerp]      ;sequence number
 291                       [4 length-1]      ;length
 292                       [1 integerp]      ;elhead
 293                       [3 nil]           ;not used
 294                       [4 length-2]      ;n, number of intercepted-clients
 295                       [16 nil]          ;not used
 296                       [length-2 ([4 integerp]
 297                                  [4 length-3]
 298                                  [length-3
 299                                   ([1 integerp]
 300                                    [1 integerp]
 301
 302                                    [1 integerp]
 303                                    [1 integerp]
 304
 305                                    [1 integerp]
 306                                    [1 integerp]
 307                                    [2 integerp]
 308                                    [2 integerp]
 309
 310                                    [1 integerp]
 311                                    [1 integerp]
 312                                    [2 integerp]
 313                                    [2 integerp]
 314
 315                                    [1 integerp]
 316                                    [1 integerp]
 317
 318                                    [1 integerp]
 319                                    [1 integerp]
 320
 321                                    [1 integerp]
 322                                    [1 integerp]
 323
 324                                    [1 booleanp]
 325                                    [1 booleanp])])]))))
 326
 327     (X-Dpy-send-read xdpy msg ReceiveFields)))
 328 ;      (X-log dpy "Get X-XRecordGetContext replay: %s\n" 'resp)
 329
 330 (defun X-XRecordEnableContext (xdpy rc)
 331   "On display XDPY enable RC context.
 332
 333 This request enables data transfer between the recording client, and
 334 the extension and returns the protocol data the recording client has
 335 previously expressed interest in.  Typically, this request is executed
 336 by the recording client over the data connection."
 337
 338   (X-Dpy-p xdpy 'X-XRecordEnableContext)
 339
 340   (let* ((xrec-ext (X-Dpy-get-extension xdpy "RECORD" 'X-XRecordEnableContext))
 341          (ListOfFields
 342           (list (vector 1 (nth 4 xrec-ext)) ;opcode
 343                 [1 X-XRecord-op-EnableContext]
 344                 [2 2]                   ;length
 345                 [4 (X-RecordContext-id rc)]))
 346          (msg (concat (X-Create-message ListOfFields)))
 347          (ReceiveFields
 348           (list [1 success]             ;success field
 349                 nil
 350                 (list [1 integerp]      ;category
 351                       [2 integerp]      ;sequence number
 352                       [4 length-1]      ;length
 353                       [1 integerp]      ;elhead
 354                       [1 integerp]      ;client-swapped
 355                       [2 nil]           ;not used
 356                       [4 integerp]      ;id-baes
 357                       [4 integerp]      ;server-time
 358                       [4 integerp]      ;recorded sequence number
 359                       [8 nil]           ;not used
 360                       [(* length-1 4) stringp])))
 361          (rep (X-Dpy-send-read xdpy msg ReceiveFields)))
 362
 363     (X-Dpy-log xdpy 'x-record "X-XRecordEnableContext:  rep=%S" 'rep)
 364     (when (and (car rep)
 365                (= (nth 1 rep) X-XRecordStartOfData))
 366       ;; Set events guess parser and events dispatcher
 367       (setf (X-Dpy-parse-guess-dispatcher xdpy) 'X-XRecord-parse-guess)
 368       (setf (X-Dpy-events-dispatcher xdpy) 'X-XRecord-event-dispatcher))
 369     rep))
 370
 371 (defun X-XRecordDisableContext (xdpy rc)
 372   "On display XDPY disable recording context RC."
 373   (X-Dpy-p xdpy 'X-XRecordGetContext)
 374   (X-RecordContext-p rc 'X-XRecordRegisterClients)
 375
 376   (let* ((xrec-ext (X-Dpy-get-extension xdpy "RECORD" 'X-XRecordGetContext))
 377          (ListOfFields
 378           (list (vector 1 (nth 4 xrec-ext)) ; opcode
 379                 [1 X-XRecord-op-DisplayContext]
 380                 [2 2]                   ; length
 381                 [4 (X-RecordContext-id rc)])) ; context
 382          (msg (X-Create-message ListOfFields)))
 383     (X-Dpy-send xdpy msg))
 384   (X-Dpy-log xdpy 'x-record "X-XRecordDisableContext: rc=%S" '(X-RecordContext-id rc)))
 385
 386 (defun X-XRecordFreeContext (xdpy rc)
 387   "On display XDPY free record context RC."
 388   (X-Dpy-p xdpy 'X-XRecordGetContext)
 389   (X-RecordContext-p rc 'X-XRecordRegisterClients)
 390
 391   (let* ((xrec-ext (X-Dpy-get-extension xdpy "RECORD" 'X-XRecordGetContext))
 392          (ListOfFields
 393           (list (vector 1 (nth 4 xrec-ext)) ; opcode
 394                 [1 X-XRecord-op-FreeContext]
 395                 [2 2]                   ; length
 396                 [4 (X-RecordContext-id rc)])) ; context
 397          (msg (X-Create-message ListOfFields)))
 398     (X-Dpy-send xdpy msg)))
 399
 400
 401 (defun X-XRecord-event-dispatcher (xdpy win xev)
 402   "Dispatch XEvent received fro XRECORD data connection."
 403   (setf (X-Dpy-evq xdpy)
 404         (append (X-Dpy-evq xdpy) (list xev))))
 405
 406 (defun X-XRecord-parse-guess (xdpy)
 407   "Parse message received in data connection."
 408   (X-Dpy-p xdpy 'X-XRecord-parse-guess)
 409
 410   (while (and (zerop (X-Dpy-readings xdpy))
 411               (> (length (X-Dpy-message-buffer xdpy)) 31))
 412     (X-Dpy-read-excursion xdpy
 413       (let* ((msg (X-Dpy-parse-message
 414                    (list [1 integerp]   ; reply
 415                          [1 integerp]   ;category
 416                          [2 integerp]   ;sequence number
 417                          [4 integerp]   ;length
 418                          [1 integerp]   ;elhead
 419                          [1 integerp]   ;client-swapped
 420                          [2 nil]        ;not used
 421                          [4 integerp]   ;id-baes
 422                          [4 integerp]   ;server-time
 423                          [4 integerp]   ;recorded sequence number
 424                          [8 nil])       ;not used
 425                    0 xdpy))
 426              (mcategory (nth 1 msg))    ; message categery
 427              (len (* 4 (nth 3 msg)))
 428              (elh (nth 4 msg))
 429              elh-value
 430              result)
 431
 432         (while (> len 0)
 433           ;; There data
 434           (setq elh-value nil)
 435           (when (> elh 0)
 436             ;; there elhead
 437             (setq elh-value
 438                   (X-Dpy-parse-message (list [4 integerp]) 0 xdpy))
 439             (setq len (- len 4)))
 440
 441           (setq result (Xforcenum (aref (X-Dpy-grab-bytes xdpy 1) 0)))
 442           (setq len (- len 1))
 443
 444           (cond ((= mcategory X-XRecordFromServer)
 445                  ;; Error, Event or Reply
 446                  (cond ((or (= result 0)
 447                             (= result 1))
 448                         ;; Error or Reply .. just flush the data
 449                         (X-Dpy-grab-bytes xdpy len)
 450                         (setq len 0))
 451
 452                        ;; Event
 453                        (t               ;(< result X-MaxEvent)
 454                         ;; Valid event
 455                         (let ((xev (X-Dpy-parse-event xdpy result)))
 456                           (setq len (- len 31))
 457
 458                           ;; Put some interception info
 459                           (X-Event-put-property xev 'XRecord-Category (nth 1 msg))
 460                           (X-Event-put-property xev 'XRecord-Sequence (nth 2 msg))
 461                           (X-Event-put-property xev 'XRecord-Elhead (nth 4 msg))
 462                           (X-Event-put-property xev 'XRecord-Elhead-value elh-value)
 463                           (X-Event-put-property xev 'XRecord-Swaped (nth 5 msg))
 464                           (X-Event-put-property xev 'XRecord-Idbase (nth 6 msg))
 465                           (X-Event-put-property xev 'XRecord-Servertime (nth 7 msg))
 466                           (X-Event-put-property xev 'XRecord-RecSeq (nth 8 msg))
 467
 468                           (X-Dpy-log (X-Event-dpy xev) 'x-record "XRECORD EXTENSION: Get Event: %S(%S[%S]), win=%S"
 469                                      '(X-Event-name xev) '(X-Event-detail xev)
 470                                      '(int-to-char (truncate (car (xwem-kbd-xkcode->xksym (X-Event-detail xev)))))
 471                                      '(X-Win-id (X-Event-win xev)))
 472
 473                           ;; Add event to event queue
 474                           (setf (X-Dpy-evq xdpy)
 475                                 (append (X-Dpy-evq xdpy) (list xev)))))))
 476
 477                 (t
 478                  ;; Unsupported category
 479                  (X-Dpy-grab-bytes xdpy len)
 480                  (setq len 0)))
 481           )))
 482   ))
 483
 484 \f
 485 ;;; Testing section:
 486 ;;
 487 ;; To record KeyPress/KeyRelease device events:
 488 ;;
 489 ;;  (setq mrc (make-X-RecordContext :dpy (xwem-dpy) :id (X-Dpy-get-id (xwem-dpy))))
 490 ;;  (setq mrr (make-X-RecordRange :device-events '(2 . 3)))
 491 ;;  (setq tcl (X-Win-id (xwem-cl-xwin (xwem-cl-selected))))
 492 ;;  (setq mrc (X-XRecordCreateContext (xwem-dpy) mrc 5 (list tcl) (list mrr)))
 493 ;;
 494 ;;  (X-XRecordRegisterClients (xwem-dpy) mrc 5 (list tcl) (list mrr))
 495 ;;
 496 ;;  (setq md (XOpenDisplay "127.0.0.1:0"))
 497 ;;  (setf (X-Dpy-log-buffer md) "XREC.log")
 498 ;;  (X-XRecordEnableContext md mrc)
 499
 500 \f
 501 (provide 'xlib-xrecord)
 502
 503 ;;; xlib-xrecord.el ends here