;;; xlib-xrecord.el --- RECORD extension for xlib.

;; Copyright (C) 2003-2005 by XWEM Org.

;; Author: Zajcev Evgeny <zevlg@yandex.ru>
;; Created: 18 October 2003
;; Keywords: xlib, xwem
;; X-CVS: $Id: xlib-xrecord.el,v 1.8 2005/04/04 19:55:30 lg Exp $

;; This file is part of XWEM.

;; XWEM is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; XWEM is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
;; License for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING.  If not, write to the Free
;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
;; 02111-1307, USA.

;;; Synched up with: Not in FSF

;;; Commentary:

;; We need to open two connections to X server to use RECORD
;; extension, one for RC controling and second for data transfer,
;; `X-XRecordEnableContext' should be issued on data connection.

;; Range8, Range16 is cons cells in form (FIRST . LAST)
;;
;; ExtRange is cons cell in form (MAJOR-Range8 . MINOR-Range16)

;;; Code:

(eval-when-compile
  (require 'cl))

(require 'xlib-xlib)

(defconst X-XRecord-major 1)
(defconst X-XRecord-minor 13)

(defconst X-XRecord-op-QueryVersion 0)
(defconst X-XRecord-op-CreateContext 1)
(defconst X-XRecord-op-RegisterClients 2)
(defconst X-XRecord-op-UnregisterClients 3)
(defconst X-XRecord-op-GetContext 4)
(defconst X-XRecord-op-EnableContext 5)
(defconst X-XRecord-op-DisplayContext 6)
(defconst X-XRecord-op-FreeContext 7)

;; element-header
(defconst X-XRecordFromServerTime (Xmask 0))
(defconst X-XRecordFromClientTime (Xmask 1))
(defconst X-XRecordFromClientSequence (Xmask 2))

(defconst X-XRecordCurrentClients 1)
(defconst X-XRecordFutureClients 2)
(defconst X-XRecordAllClients 3)

(defconst X-XRecordFromServer 0)
(defconst X-XRecordFromClient 1)
(defconst X-XRecordClientStarted 2)
(defconst X-XRecordClientDied 3)
(defconst X-XRecordStartOfData 4)
(defconst X-XRecordEndOfData 5)


;; Message generators
(defsubst X-RecordRange8-message (xrr8)
  "Return a string representing the record range8 XRR8."
  (if (null xrr8)
      (make-string 2 ?\x00)
    (concat (int->string1 (car xrr8)) (int->string1 (cdr xrr8)))))

(defsubst X-RecordRange16-message (xrr16)
  "Return a string representing the record range16 XRR16."
  (if (null xrr16)
      (make-string 4 ?\x00)
    (concat (int->string2 (car xrr16)) (int->string2 (cdr xrr16)))))

(defsubst X-RecordExtrange-message (xer)
  "Return a string representing the extrange XER."
  (if (null xer)
      (make-string 12 ?\x00)
    (concat (X-RecordRange8-message (car xer)) (X-RecordRange16-message (cdr xer)))))

(defsubst X-RecordRange-message (xrr)
  "Return a string representing the record range XRR."
  (X-Generate-simple-message 'X-RecordRange xrr))

(defsubst X-RecordClientSpec-message (xrcs)
  "Return a string representing the client spec XRCS."
  (int->string4 xrcs))

(defstruct (X-RecordContext (:predicate X-RecordContext-isrc-p))
  dpy id
  props)                                ; User defined plist

(defstruct (X-RecordExtrange (:predicate X-RecordExtrange-isrer-p))
  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)))
  )

(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
  ;; List of extractors
  (list (list 
         (cons #'(lambda (rr)
                   (X-RecordRange8-message (X-RecordRange-core-requests rr)))
               2)
         (cons #'(lambda (rr)
                   (X-RecordRange8-message (X-RecordRange-core-replies rr)))
               2)
         (cons #'(lambda (rr)
                   (X-RecordExtrange-message (X-RecordRange-ext-requests rr)))
               6)
         (cons #'(lambda (rr)
                   (X-RecordExtrange-message (X-RecordRange-ext-replies rr)))
               6)
         (cons #'(lambda (rr)
                   (X-RecordRange8-message (X-RecordRange-delivered-events rr)))
               2)
         (cons #'(lambda (rr)
                   (X-RecordRange8-message (X-RecordRange-device-events rr)))
               2)
         (cons #'(lambda (rr)
                   (X-RecordRange8-message (X-RecordRange-errors rr)))
               2)
         (cons 'X-RecordRange-client-started 1)
         (cons 'X-RecordRange-client-died 1))))

(defstruct (X-RecordClientInfo (:predicate X-RecordClientInfo-isrci-p))
  client-spec                           ; X-RecordClientSpec
  ranges)                               ; list of X-RecordRange

(defstruct X-RecordState
  enabled                               ; BOOL
  datum-flags                           ; int
  client-infos                          ; list of X-RecordClientInfo
  )


;; Predicates
(defsubst X-RecordContext-p (xrc &optional sig)
  (X-Generic-p 'X-RecordContext 'X-RecordContext-isrc-p xrc sig))

(defsubst X-RecordRange8-p (xrr8 &optional sig)
  (or (null xrr8) (consp xrr8)))

(defsubst X-RecordRange16-p (xrr16 &optional sig)
  (or (null xrr16) (consp xrr16)))

(defsubst X-RecordExtrange-p (xrer &optional sig)
  (or (null xrer) (and (consp xrer) (X-RecordRange8-p (car xrer)) (X-RecordRange16-p (cdr xrer)))))

(defsubst X-RecordRange-p (xrr &optional sig)
  (X-Generic-p 'X-RecordRange 'X-RecordRange-isrr-p xrr sig))

(defsubst X-RecordClientSpec-p (xrcs &optional sig)
  (floatp xrcs))

(defsubst X-RecordClientInfo-p (xrci &optional sig)
  (X-Generic-p 'X-RecordClientInfo 'X-RecordClientInfo-isrci-p xrci sig))


;;; Functions
(defun X-XRecordQueryVersion (xdpy &optional major minor)
  "On display XDPY query for version of record extension."
  (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
    (and (car xrec-ext)
         (X-Dpy-send-read xdpy msg ReceiveFields))))

(defun X-XRecordCreateContext (xdpy rc elhead clspecs ranges)
  "ELHEAD is contructed using `Xmask-or' and values
`X-XRecordFromServerTime', `X-XRecordFromClient' and
`X-XRecordFromClientSequence'.

CLSPECS is list of X-RecordClientSpec
RANGES is list of X-RecordRange."
  (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))))
    (X-Dpy-send xdpy msg)
    rc))

(defun X-XRecordRegisterClients (xdpy rc elhead clspecs ranges)
  "On display XDPY, register CLSPECS for intercepting in record context RC."
  (X-Dpy-p xdpy 'X-XRecordRegisterClients)
  (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))))
    (X-Dpy-send xdpy msg)))

(defun X-XRecordUnregisterClients (xdpy rc clspecs)
  "On display XDPY in record context RC unregister clients in CLSPECS."
  (X-Dpy-p xdpy 'X-XRecordRegisterClients)
  (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))))
    (X-Dpy-send xdpy msg)))

(defun X-XRecordGetContext (xdpy rc)
  "On display XDPY get context for RC."
  (X-Dpy-p xdpy 'X-XRecordGetContext)
  (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])])]))))

    (X-Dpy-send-read xdpy msg ReceiveFields)))
;      (X-log dpy "Get X-XRecordGetContext replay: %s\n" 'resp)

(defun X-XRecordEnableContext (xdpy rc)
  "On display XDPY enable RC context.

This request enables data transfer between the recording client, and
the extension and returns the protocol data the recording client has
previously expressed interest in.  Typically, this request is executed
by the recording client over the data connection."

  (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)))

    (X-Dpy-log xdpy 'x-record "X-XRecordEnableContext:  rep=%S" 'rep)
    (when (and (car rep)
               (= (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))
    rep))

(defun X-XRecordDisableContext (xdpy rc)
  "On display XDPY disable recording context RC."
  (X-Dpy-p xdpy 'X-XRecordGetContext)
  (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))
  (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."
  (X-Dpy-p xdpy 'X-XRecordGetContext)
  (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)))
    (X-Dpy-send xdpy msg)))
  

(defun X-XRecord-event-dispatcher (xdpy win xev)
  "Dispatch XEvent received fro XRECORD data connection."
  (setf (X-Dpy-evq xdpy)
        (append (X-Dpy-evq xdpy) (list xev))))

(defun X-XRecord-parse-guess (xdpy)
  "Parse message received in data connection."
  (X-Dpy-p xdpy 'X-XRecord-parse-guess)

  (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:
;;
;; To record KeyPress/KeyRelease device events:
;;
;;  (setq mrc (make-X-RecordContext :dpy (xwem-dpy) :id (X-Dpy-get-id (xwem-dpy))))
;;  (setq mrr (make-X-RecordRange :device-events '(2 . 3)))
;;  (setq tcl (X-Win-id (xwem-cl-xwin (xwem-cl-selected))))
;;  (setq mrc (X-XRecordCreateContext (xwem-dpy) mrc 5 (list tcl) (list mrr)))
;;
;;  (X-XRecordRegisterClients (xwem-dpy) mrc 5 (list tcl) (list mrr))
;;
;;  (setq md (XOpenDisplay "127.0.0.1:0"))
;;  (setf (X-Dpy-log-buffer md) "XREC.log")
;;  (X-XRecordEnableContext md mrc)


(provide 'xlib-xrecord)

;;; xlib-xrecord.el ends here
