;;; xlib-xr.el --- X receive part.

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

;; Author: Eric M. Ludlam <zappo@gnu.ai.mit.edu>
;;         Zajcev Evgeny <zevlg@yandex.ru>
;; Keywords: xlib, xwem
;; X-CVS: $Id: xlib-xr.el,v 1.10 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:

;; 

;;; Code:

(require 'xlib-math)
(require 'xlib-const)
(require 'xlib-xwin)

;; GNU Emacs compatibility
(unless (fboundp 'define-error)
  (defun define-error (err-sym doc-string &optional inherits-from)
    "Define a new error, denoted by ERR-SYM."
    (put err-sym 'error-message doc-string)
    (unless inherits-from
      (setq inherits-from 'error))
    (let ((conds (get inherits-from 'error-conditions)))
      (or conds (signal 'error (list "Not an error symbol" err-sym)))
      (put err-sym 'error-conditions (cons err-sym conds)))))

(define-error 'X-Error
  "X Server error.")

(define-error 'X-Events-stop
  "Error used to stop X events processing.")

;;; X Events section.
(defun XVectorizeList (lst)
  "Take list LST and turn it into a vector.
This makes random access of its fields much faster."
  (let ((nv (make-vector (length lst) nil))
        (cnt 0))
    (while lst
      (aset nv cnt (if (and (car lst) (listp (car lst)))
                       (XVectorizeList (car lst))
                     (car lst)))
      (setq cnt (1+ cnt))
      (setq lst (cdr lst)))
    nv))

(defvar X-Event-LASTEvent 128
  "Any event must be less then this one.
NOTE: * Core event are less than 35, but extensions may generate greater.
      * Eight bit is syntetic bit.")

(defvar X-EventsList (make-vector X-Event-LASTEvent ["Unknown" nil 0 0])
  "List of event descriptions.")

(defstruct (X-Event (:predicate X-Event-isevent-p))
  dpy                                   ; display
  type                                  ; type of event
  synth-p                               ; non-nil if event came from SendEvent request
  evdata                                ; binary event represetation
  evinfo                                ; parsed variant of evdata

  list                                  ;for use in X-Generate-message
  properties                            ; User defined plist
  )

(defsubst X-Event-put-property (xev prop val)
  "Put property PROP with value VAL in XEV's properties list."
  (setf (X-Event-properties xev)
        (plist-put (X-Event-properties xev) prop val)))

(defsubst X-Event-get-property (xev prop)
  "Get property PROP from XEV's properties list."
  (plist-get (X-Event-properties xev) prop))

(defsubst X-Event-rem-property (xev prop)
  "Remove property PROP from XEV's properties list."
  (setf (X-Event-properties xev) (plist-remprop (X-Event-properties xev) prop)))

(defun X-Event-p (ev &optional sig)
  "Return non-nil if EV is X-Event."
  (let ((isev (X-Event-isevent-p ev)))
    (if (and (not isev) sig)
        (signal 'wrong-type-argument (list sig 'X-Event-p ev))
      isev)))

(defsubst X-Event-detail (xev)
  "Return detail info stored in XEV."
  (nth 0 (X-Event-evinfo xev)))

(defsubst X-Event-seq (xev)
  "Return sequence number of XEvent XEV."
  (nth 1 (X-Event-evinfo xev)))

(defsubst X-Event-win (xev)
  "Return window which is the subject of the XEV.
Return nil if there no such window."
  (let ((evd (aref (aref X-EventsList (X-Event-type xev)) 2)))
    (and (numberp evd) (nth evd (X-Event-evinfo xev)))))

(defsubst X-Event-win-event (xev)
  "Return window for which XEV is generated.
Return nil if there is no such window."
  (let ((evd (aref (aref X-EventsList (X-Event-type xev)) 3)))
    (and (numberp evd) (nth evd (X-Event-evinfo xev)))))

(defsubst X-Event-name (xev)
  "Return symbolic XEV name."
  (aref (aref X-EventsList (X-Event-type xev)) 0))

(defun X-Event-make (&rest args)
  "Like `make-X-Event', but also fills list field automatically."
  (let* ((xev (apply 'make-X-Event args))
         (evspec (aref (X-Event-type xev) X-EventsList)))
    ;; TODO: write me ..
    ))

(defmacro X-Event-declare (type ev-name ev-msg &optional win-idx event-win-idx)
  "Only declare event of TYPE with DESCR in `X-EventsList'."
  `(aset X-EventsList ,type
        (vector ,ev-name (quote ,ev-msg) ,win-idx (or ,event-win-idx ,win-idx))))

(defmacro X-Event-define (type name dnames ev-name ev-msg &optional win-idx event-win-idx)
  "Define new event of TYPE, NAME and description of event DESCR."
  (let ((offs 0)
        fsym forms)
    (push `(aset X-EventsList ,type
                 (vector ,ev-name (quote ,ev-msg) ,win-idx (or ,event-win-idx ,win-idx)))
          forms)
    (while dnames
      (when (car dnames)
        (setq fsym (intern (concat "X-Event-" name "-" (symbol-name (car dnames)))))
        (push `(defsubst* ,fsym (ev)
                 (nth ,offs (X-Event-evinfo ev)))
              forms))
      (setq offs (1+ offs))
      (setq dnames (cdr dnames)))
    `(progn ,@forms)))

(defun X-Event->symbolkey (xev)
  "Convert XEV type to symbolic name, return keyword."
  (let ((evt (X-Event-type xev)))
    (cond ((= evt X-KeyPress) :X-KeyPress)
          ((= evt X-KeyRelease) :X-KeyRelease)
          ((= evt X-ButtonPress) :X-ButtonPress)
          ((= evt X-ButtonRelease) :X-ButtonRelease)
          ((= evt X-MotionNotify) :X-MotionNotify)
          ((= evt X-EnterNotify) :X-EnterNotify)
          ((= evt X-LeaveNotify) :X-LeaveNotify)
          ((= evt X-FocusIn) :X-FocusIn)
          ((= evt X-FocusOut) :X-FocusOut)
          ((= evt X-KeymapNotify) :X-KeymapNotify)
          ((= evt X-Expose) :X-Expose)
          ((= evt X-GraphicsExpose) :X-GraphicsExpose)
          ((= evt X-NoExpose) :X-NoExpose)
          ((= evt X-VisibilityNotify) :X-VisibilityNotify)
          ((= evt X-CreateNotify) :X-CreateNotify)
          ((= evt X-DestroyNotify) :X-DestroyNotify)
          ((= evt X-UnmapNotify) :X-UnmapNotify)
          ((= evt X-MapNotify) :X-MapNotify)
          ((= evt X-MapRequest) :X-MapRequest)
          ((= evt X-ReparentNotify) :X-ReparentNotify)
          ((= evt X-ConfigureRequest) :X-ConfigureRequest)
          ((= evt X-ConfigureNotify) :X-ConfigureNotify)
          ((= evt X-GravityNotify) :X-GravityNotify)
          ((= evt X-ResizeRequest) :X-ResizeRequest)
          ((= evt X-CirculateNotify) :X-CirculateNotify)
          ((= evt X-CirculateRequest) :X-CirculateRequest)
          ((= evt X-PropertyNotify) :X-PropertyNotify)
          ((= evt X-SelectionClear) :X-SelectionClear)
          ((= evt X-SelectionRequest) :X-SelectionRequest)
          ((= evt X-SelectionNotify) :X-SelectionNotify)
          ((= evt X-ColormapNotify) :X-ColormapNotify)
          ((= evt X-ClientMessage) :X-ClientMessage)
          ((= evt X-MappingNotify) :X-MappingNotify)

          (t :X-Unknown))))

(defmacro X-Event-CASE (xev &rest body)
  "Run event case. BODY in form (EVTYPE FORMS) (EVTYPE FORMS) ..
EVTYPE is one of :X-KeyPress, :X-KeyRelease etc."
  `(case (X-Event->symbolkey ,xev)
     ,@body))

(put 'X-Event-CASE 'lisp-indent-function 1)

(defstruct X-EventHandler
  priority
  evtypes-list                          ; list of event types
  handler                               ; function to call
  (active t)                            ; Non-nil mean event handler activated

  plist)                                ; user defined plist

;;;###autoload
(defun X-EventHandler-add (evhlist handler &optional priority evtypes-list)
  "To event handlers list EVHLIST add event HANDLER.

HANDLER is function which should accept three arguments - xdpy(X-Dpy),
xwin(X-Win) and xev(X-Event).  Only events with type that in
EVTYPES-LIST are passed to HANDLER. By default all events passed.
PRIORITY is place in events handler list, i.e. when HANDLER will be
called. Higher priorities runs first.

Return new list, use it like `(setq lst (X-EventHandler-add lst 'handler))'."
  (unless priority
    (setq priority 0))

  (let ((xeh (make-X-EventHandler :priority priority
                                  :evtypes-list evtypes-list
                                  :handler handler)))

    ;; Insert new event handler and sort event handlers by priority.
    (sort (cons xeh evhlist)
          #'(lambda (xeh1 xeh2)
              (> (X-EventHandler-priority xeh1)
                 (X-EventHandler-priority xeh2))))))

;;;###autoload
(defun X-EventHandler-isset (evhlist handler &optional prioritiy evtypes-list)
  "Examine EVHLIST and return X-EventHandler with HANDLER, PRIORITY and EVTYPES-LIST.
If you does not specify PRIORITY and EVTYPES-LIST, only matching with HANDLER occurs.
If event handler not found - nil will be returned."
  (let ((evhs evhlist))
    ;; Find appopriate handler
    (while (and evhs
                (not (and (eq (X-EventHandler-handler (car evhs)) handler)
                          (if prioritiy (equal prioritiy (X-EventHandler-priority (car evhs))) t)
                          (if evtypes-list (equal evtypes-list (X-EventHandler-evtypes-list (car evhs))) t))))
      (setq evhs (cdr evhs)))

    (car evhs)))

;;;###autoload
(defun X-EventHandler-rem (evhlist handler &optional prioritiy evtypes-list)
  "From EVHLIST remove event HANDLER with PRIORITY and EVTYPES-LIST.
If you does not specify PRIORITY and EVTYPES-LIST, only matching with HANDLER occurs.
Return new list, use it like `(setq lst (X-EventHandler-rem lst 'handler))'."
  (let ((xeh (X-EventHandler-isset evhlist handler prioritiy evtypes-list)))
    (when xeh
      (setq evhlist (delete xeh evhlist)))
    evhlist))

;;;###autoload
(defun X-EventHandler-enable (evhlist handler &optional prioritiy evtypes-list)
  "In event handlers list EVHLIST mark HANDLER with PRIORITY and EVTYPES-LIST as active."
  (let ((xeh (X-EventHandler-isset evhlist handler prioritiy evtypes-list)))
    (when xeh
      (setf (X-EventHandler-active xeh) t))))

;;;###autoload
(defun X-EventHandler-disable (evhlist handler &optional prioritiy evtypes-list)
  "In event handlers list EVHLIST mark HANDLER with PRIORITY and EVTYPES-LIST as inactive."
  (let ((xeh (X-EventHandler-isset evhlist handler prioritiy evtypes-list)))
    (when xeh
      (setf (X-EventHandler-active xeh) nil))))

;;;###autoload
(defun X-EventHandler-runall (evhlist xev)
  "Run all event handlers in EVHLIST on XEV.
Signal `X-Events-stop' to stop events processing."
  (let ((evhs evhlist))                 ; EVHS should be already sorted by priority
    (condition-case nil
        (while evhs
          ;; Check is there appopriate event handler to handle XEV event.
          (when (and (X-EventHandler-active (car evhs))
                     (or (null (X-EventHandler-evtypes-list (car evhs)))
                         (memq (X-Event-type xev) (X-EventHandler-evtypes-list (car evhs)))))
            (funcall (X-EventHandler-handler (car evhs)) (X-Event-dpy xev) (X-Event-win xev) xev))
          (setq evhs (cdr evhs)))
      (X-Events-stop nil))))

;;; X Events description.

;; TODO:
;;   - Should be X-Dpy depended to support extensions derived events
(X-Event-define X-KeyPress "xkey" (keycode nil time root event child root-x root-y event-x event-y state same-screen)
                "KeyPress"
               ([1 integerp]           ; keycode
                [2 integerp]           ; sequence
                [4 integerp]           ; time
                [4 :X-Win]             ; root
                [4 :X-Win]             ; event  (WIN-EVENT)
                [4 :X-Win]             ; child
                [2 integerp]           ; root_x
                [2 integerp]           ; root_y
                [2 integerp]           ; event_x
                [2 integerp]           ; event_y
                [2 integerp]           ; state
                [1 booleanp]           ; same_screen
                [1 nil])
               4)
(X-Event-declare X-KeyRelease
                 "KeyRelease"
                ([1 integerp]          ; keycode
                 [2 integerp]          ; sequence
                 [4 integerp]          ; time
                 [4 :X-Win]            ; root
                 [4 :X-Win]            ; event
                 [4 :X-Win]            ; child
                 [2 integerp]          ; root_x
                 [2 integerp]          ; root_y
                 [2 integerp]          ; event_x
                 [2 integerp]          ; event_y
                 [2 integerp]          ; state
                 [1 booleanp]          ; same_screen
                 [1 nil])
                4)
(X-Event-define X-ButtonPress "xbutton" (button nil time root event child root-x root-y event-x event-y state same-screen)
                "ButtonPress"
               ( [1 integerp]          ; button
                 [2 integerp]          ; sequence
                 [4 integerp]          ; time
                 [4 :X-Win]            ; root
                 [4 :X-Win]            ; event
                 [4 :X-Win]            ; child
                 [2 integerp]          ; root_x
                 [2 integerp]          ; root_y
                 [2 integerp]          ; event_x
                 [2 integerp]          ; event_y
                 [2 integerp]          ; state
                 [1 booleanp]          ; same_screen
                 [1 nil] )
               4)
(X-Event-declare X-ButtonRelease
                 "ButtonRelease"
                ( [1 integerp]         ; button
                  [2 integerp]         ; sequence
                  [4 integerp]         ; time
                  [4 :X-Win]           ; root
                  [4 :X-Win]           ; event
                  [4 :X-Win]           ; child
                  [2 integerp]         ; root_x
                  [2 integerp]         ; root_y
                  [2 integerp]         ; event_x
                  [2 integerp]         ; event_y
                  [2 integerp]         ; state
                  [1 booleanp]         ; same_screen
                  [1 nil] )
                4)
(X-Event-define X-MotionNotify "xmotion" (nil nil time root event child root-x root-y event-x event-y state same-screen)
                "MotionNotify"
               ( [1 integerp]          ; detail
                 [2 integerp]          ; sequence
                 [4 integerp]          ; time
                 [4 :X-Win]            ; root
                 [4 :X-Win]            ; event
                 [4 :X-Win]            ; child
                 [2 integerp]          ; root_x
                 [2 integerp]          ; root_y
                 [2 integerp]          ; event_x
                 [2 integerp]          ; event_y
                 [2 integerp]          ; state
                 [1 booleanp]          ; same_screen
                 [1 nil] )
               4)
(X-Event-define X-EnterNotify "xcrossing" (nil nil time root event child root-x root-y event-x event-y state mode same-screen-focus)
                "EnterNotify"
               ( [1 integerp]          ; detail
                 [2 integerp]          ; sequence
                 [4 integerp]          ; time
                 [4 :X-Win]            ; root
                 [4 :X-Win]            ; event
                 [4 :X-Win]            ; child
                 [2 integerp]          ; root_x
                 [2 integerp]          ; root_y
                 [2 integerp]          ; event_x
                 [2 integerp]          ; event_y
                 [2 integerp]          ; state
                 [1 integerp]          ; mode
                 [1 integerp])         ; same-screen, focus
               4)
(X-Event-declare X-LeaveNotify
                 "LeaveNotify"
                ( [1 integerp]         ; detail
                  [2 integerp]         ; sequence
                  [4 integerp]         ; time
                  [4 :X-Win]           ; root
                  [4 :X-Win]           ; event
                  [4 :X-Win]           ; child
                  [2 integerp]         ; root_x
                  [2 integerp]         ; root_y
                  [2 integerp]         ; event_x
                  [2 integerp]         ; event_y
                  [2 integerp]         ; state
                  [1 integerp]         ; mode
                  [1 integerp] )       ; same-screen, focus
                4)
(X-Event-define X-FocusIn "xfocus" (nil nil event mode)
                "FocusIn"
               ( [1 integerp]          ; detail
                 [2 integerp]          ; sequence
                 [4 :X-Win]            ; event
                 [1 integerp]          ; mode
                 [23 nil] )
               2)
(X-Event-declare X-FocusOut
                 "FocusOut"
                ( [1 integerp]         ; detail
                  [2 integerp]         ; sequence
                  [4 :X-Win]           ; event
                  [1 integerp]         ; mode
                  [23 nil] )
                2)

;; TODO: X-KeymapNotify

(X-Event-define X-Expose "xexpose" (nil nil window x y width height count)
                "Expose"
               ( [1 integerp]          ; detail
                 [2 integerp]          ; sequence
                 [4 :X-Win]            ; window
                 [2 integerp]          ; x
                 [2 integerp]          ; y
                 [2 integerp]          ; width
                 [2 integerp]          ; height
                 [2 integerp]          ; count
                 [14 nil] )
               2)
(X-Event-define X-GraphicsExpose "xgraphicsexpose" (nil nil drawable x y width height minor-event count major-event)
                "GraphicsExpose"
               ([1 integerp]
                [2 integerp]
                [4 integerp]           ; drawable
                [2 integerp]           ; x
                [2 integerp]           ; y
                [2 integerp]           ; width
                [2 integerp]           ; height
                [2 integerp]           ; minorEvent
                [2 integerp]           ; count
                [1 integerp]           ; majorEvent
                [11 nil])
               2)
(X-Event-define X-NoExpose "xnoexpose" (nil nil drawable minor-event major-event)
                "NoExpose"
               ([1 integerp]
                [2 integerp]
                [4 integerp]           ; drawable
                [2 integerp]           ; minorEvent
                [1 integerp]           ; majorEvent
                [21 nil])
               2)
(X-Event-define X-VisibilityNotify "xvisibility" (nil nil window state)
                "VisibilityNotify"
               ([1 integerp]
                [2 integerp]
                [4 :X-Win]             ; window
                [1 integerp]           ; state
                [23 nil])
               2)
(X-Event-define X-CreateNotify "xcreatewindow" (nil nil parent window x y width height border-width override)
                "CreateNotify"     
               ([1 integerp]           ; detail
                [2 integerp]           ; sequence
                [4 :X-Win]             ; parent window
                [4 :X-Win]             ; window
                [2 integerp]           ; x
                [2 integerp]           ; y
                [2 integerp]           ; width
                [2 integerp]           ; height
                [2 integerp]           ; border width
                [1 booleanp]           ; override-redirect
                [9 nil])
               2)
(X-Event-define X-DestroyNotify "xdestroywindow" (nil nil event window)
                "DestroyNotify"    
               ( [1 integerp]          ; detail
                 [2 integerp]          ; sequence
                 [4 :X-Win]            ; event window
                 [4 :X-Win]            ; window
                 [20 nil])
               3 2)
(X-Event-define X-UnmapNotify "xunmap" (nil nil event window from-configure)
                "UnmapNotify"      
               ( [1 integerp]          ; detail
                 [2 integerp]          ; sequence
                 [4 :X-Win]            ; event
                 [4 :X-Win]            ; window
                 [1 booleanp]          ; fromconfigure
                 [19 nil])
               3  2)
(X-Event-define X-MapNotify "xmap" (nil nil event window override)
                "MapNotify"
               ( [1 integerp]          ; detail
                 [2 integerp]          ; sequence
                 [4 :X-Win]            ; event window
                 [4 :X-Win]            ; window
                 [1 booleanp]          ; override-redirect
                 [19 nil])
               3 2)
(X-Event-define X-MapRequest "xmaprequest" (nil nil parent window)
                "MapRequest"
               ( [1 integerp]          ; detail
                 [2 integerp]          ; sequence
                 [4 :X-Win]            ; parent window
                 [4 :X-Win]            ; window
                 [20 nil])
               3 2)
(X-Event-define X-ReparentNotify "xreparent" (nil nil event window parent x y override)
                "ReparentNotify"
               ( [1 integerp]          ; detail
                 [2 integerp]          ; sequence
                 [4 :X-Win]            ; event
                 [4 :X-Win]            ; window
                 [4 :X-Win]            ; parent
                 [2 integerp]          ; x
                 [2 integerp]          ; y
                 [1 integerp]          ; override
                 [11 nil])
               3 2)
(X-Event-define X-ConfigureNotify "xconfigure" (nil nil event window above-sibling x y width height border-width override-redirect)
                "ConfigureNotify"
               ( [1 integerp]          ; detail
                 [2 integerp]          ; sequence
                 [4 :X-Win]            ; event
                 [4 :X-Win]            ; window
                 [4 :X-Win]            ; above-sibling
                 [2 integerp]          ; x
                 [2 integerp]          ; y
                 [2 integerp]          ; width
                 [2 integerp]          ; height
                 [2 integerp]          ; border-width
                 [1 booleanp]          ; override-redirect
                 [5 nil] )
               3 2)
(X-Event-define X-ConfigureRequest "xconfigurerequest" (stackmode nil parent window sibling x y width height border-width value-mask)
                "ConfigureRequest"
               ( [1 integerp]          ; detail
                 [2 integerp]          ; sequence
                 [4 :X-Win]            ; parent window
                 [4 :X-Win]            ; window
                 [4 :X-Win]            ; sibling
                 [2 integerp]          ; x
                 [2 integerp]          ; y
                 [2 integerp]          ; width
                 [2 integerp]          ; height
                 [2 integerp]          ; border width
                 [2 integerp]          ; value mask
                 [4 nil])
               3 2)
(X-Event-define X-GravityNotify "xgravity" (nil nil event window x y)
                "GravityNotify" 
               ([1 integerp]
                [2 integerp]
                [4 :X-Win]             ; event window
                [4 :X-Win]             ; window
                [2 integerp]           ; x
                [2 integerp]           ; y
                [16 nil])
               3 2)
(X-Event-define X-ResizeRequest "xresizerequest" (nil nil window width height)
                "ResizeRequest"
               ( [1 integerp]          ; detail
                 [2 integerp]          ; sequence
                 [4 :X-Win]            ; window
                 [2 integerp]          ; width
                 [2 integerp]          ; height
                 [20 nil] )
               2)
(X-Event-define X-CirculateNotify "xcirculate" (nil nil event window parent place)
                "CirculateNotify" 
               ([1 integerp]
                [2 integerp]
                [4 :X-Win]             ; event window
                [4 :X-Win]             ; window
                [4 :X-Win]             ; parent
                [1 integerp]           ; place
                [15 nil])
               3 2)
;; The event field in the xcirculate record is really the parent when this
;; is used as a CirculateRequest instead of a CircluateNotify
(X-Event-declare X-CirculateRequest
                 "CirculateRequest"
                ([1 integerp]
                 [2 integerp]
                 [4 :X-Win]            ; event window
                 [4 :X-Win]            ; window
                 [4 :X-Win]            ; parent
                 [1 integerp]          ; place
                 [15 nil])
                3 2)

(X-Event-define X-PropertyNotify "xproperty" (nil nil window atom time state)
                "PropertyNotify"
               ( [1 integerp]
                 [2 integerp]
                 [4 :X-Win]            ; window
                 [4 :X-Atom]           ; atom
                 [4 integerp]          ; time
                 [1 integerp]          ; state
                 [15 nil])
               2)
(X-Event-define X-SelectionClear "xselectionclear" (nil nil time window atom)
                "SelectionClear"
               ([1 integerp]
                [2 integerp]
                [4 integerp]           ; time
                [4 :X-Win]             ; window
                [4 :X-Atom]            ; atom
                [16 nil])
               3)
(X-Event-define X-SelectionRequest "xselectionrequest" (nil nil time owner requestor selection target property)
                "SelectionRequest"
               ([1 integerp]
                [2 integerp]
                [4 integerp]           ; time
                [4 :X-Win]             ; owner
                [4 :X-Win]             ; requestor
                [4 :X-Atom]            ; selection atom
                [4 :X-Atom]            ; target atom
                [4 :X-Atom]            ; property atom
                [4 nil])
               4)
(X-Event-define X-SelectionNotify "xselection" (nil nil time requestor selection target property)
                "SelectionNotify"
               ([1 integerp]
                [2 integerp]
                [4 integerp]           ; time
                [4 :X-Win]             ; requestor
                [4 :X-Atom]            ; selection atom
                [4 :X-Atom]            ; target atom
                [4 :X-Atom]            ; property atom
                [8 nil])
               3)
(X-Event-define X-ColormapNotify "xcolormap" (nil nil window colormap new state)
                "ColormapNotify"
               ([1 integerp]           ; detail
                [2 integerp]           ; sequence
                [4 :X-Win]             ; window
                [4 integerp]           ; colormap
                [1 booleanp]           ; new
                [1 booleanp]           ; state
                [18 nil])
               2)
(X-Event-define X-ClientMessage "xclient" (nil window atom msg)
                "ClientMessage"
               ([1 length-1]           ; format
                [2 integerp]           ; sequence number
                [4 :X-Win]             ; window
                [4 :X-Atom]            ; atom
                ;; This reads in the correct number of integers of a type
                ;; specified by the format which is 8, 16, or 32.
                [(/ 20 (/ length-1 8)) ( [ (/ length-1 8) integerp ] ) ] )
               1)
(X-Event-define X-MappingNotify "xmapping" (nil nil request first-keycode count)
                "MappingNotify"
               ([1 integerp]
                [2 integerp]
                [1 integerp]           ; request
                [1 integerp]           ; firstKeyCode
                [1 integerp]           ; count
                [25 nil]))

;; error event
(X-Event-define 0 "xerror" (code nil resourceid min-op maj-op)
                "XError"
               ([1 integerp]           ; err code
                [2 integerp]           ; sequence
                [4 integerp]           ; id
                [2 integerp]           ; minor opcode
                [1 integerp]           ; major opcode
                [21 nil]))
                 
;;; All receive message types will exclude the first byte which IDs it.
;;
;; a symbol gets 'set, functions such as integerp mean turn it into that,
;; and put it into the return list. 'arg means use next arg as this value.
(defun X-mod-4 (len)
  "Return a the number LEN moded to 4."
  (if (= (% len 4) 0) 0 (- 4 (% len 4))))

(defconst X-connect-response
  (list [1 success]
        (list [1 length-1]              ; fail message len
              [2 integerp]              ; major version
              [2 integerp]              ; minor version
              [2 length-2]              ; pad length
              [length-1 stringp]        ; error conditions
              [(X-mod-4 length-1) nil]  ; padding
              )
        (list [1 nil]                   ; successful list (this is unused)
              [2 integerp]              ; major version
              [2 integerp]              ; minor version
              [2 length-1]              ; len additional data (pad)
              [4 integerp]              ; release number
              [4 integerp]              ; resource id base
              [4 integerp]              ; resource id mask
              [4 integerp]              ; motion buffer size
              [2 length-2]              ; vendor length
              [2 integerp]              ; max request len
              [1 length-4]              ; number of screens
              [1 length-3]              ; number of formats in pix list
              [1 integerp]              ; image byte order
              [1 integerp]              ; bitmap byte order
              [1 integerp]              ; bitmap format scanline thingy
              [1 integerp]              ; bitmap format scanline pad
              [1 integerp]              ; min keycode
              [1 integerp]              ; max keycode
              [4 nil]                   ; unused
              [length-2 stringp]        ; the vendor
              [(X-mod-4 length-2) nil]  ; padding
              [length-3                 ; sublist of formats
               ( [1 integerp]           ; depth
                 [1 integerp]           ; bits/pixel
                 [1 integerp]           ; scanline-pad
                 [5 nil] ) ]            ; padding
              [length-4
               ( [4 integerp]           ; root window
                 [4 integerp]           ; colormap
                 [4 integerp]           ; white-pixel
                 [4 integerp]           ; black-pixel
                 [4 integerp]           ; event-flags
                 [2 integerp]           ; screen-width
                 [2 integerp]           ; screen-height
                 [2 integerp]           ; milimeters width
                 [2 integerp]           ; milimeters height
                 [2 integerp]           ; min-installed-maps
                 [2 integerp]           ; max installed maps
                 [4 integerp]           ; visualid
                 [1 integerp]           ; backingstores
                 [1 booleanp]           ; save-unders
                 [1 integerp]           ; root depth
                 [1 length-1]           ; # depths in depth
                 [length-1              ; list of depths
                  ( [1 integerp]        ; depth
                    [1 nil]
                    [2 length-1]        ; # visual types
                    [4 nil]
                    [length-1           ; the visuals
                     ( [4 integerp]     ; visual id
                       [1 integerp]     ; class
                       [1 integerp]     ; bits/rgb value
                       [2 integerp]     ; colormap entities
                       [4 integerp]     ; red mask
                       [4 integerp]     ; green mask
                       [4 integerp]     ; blue mask
                       [4 nil])
                     ] )
                  ] )
               ] )
        )
  "Connection response structure.")

(defun X-invalidate-cl-struct (cl-x)
  "Invalidate CL-X, after `X-invalidate-cl-struct' it won't be cl struct anymore.
NOTE: works only if CL-X is vector."
  (if (vectorp cl-x)
      (let ((i (length cl-x)))
        (while (>= (setq i (1- i)) 0)
          (aset cl-x i nil))
        t)))

;;; Protecting macros
(defmacro X-Dpy-read-excursion (xdpy &rest forms)
  "Execute FORMS in reading mode."
  `(let ((gc-cons-threshold most-positive-fixnum)) ; inhibit GC'ing
     (incf (X-Dpy-readings ,xdpy))
     (prog1
         (condition-case err
             (progn ,@forms)
           (t (decf (X-Dpy-readings ,xdpy))
              (apply 'error (car err) (cdr err))))
       (decf (X-Dpy-readings ,xdpy)))))
(put 'X-Dpy-read-excursion 'lisp-indent-function 1)

(defun X-Dpy-send-read (xdpy s rf)
  "Send S to display XDPY and receive answer according to receive fields RF."
  (let ((reqid (X-Dpy-rseq-id xdpy)))   ; Remember request id
    (X-Dpy-read-excursion xdpy
      ;; Flush output buffer
      (X-Dpy-send xdpy s)
      (X-Dpy-send-flush xdpy)
      (X-Dpy-parse-message rf reqid xdpy))))

;;;###autoload
(defvar X-default-timeout 60
  "This should be big enought, larger than any XEmacs blocking.")

;;; Reading and parsing
(defun X-Dpy-grab-bytes (xdpy num &optional to-secs to-msecs)
  "On display XDPY, wait for at least NUM bytes and return string."
  (X-Dpy-p xdpy 'X-Dpy-grab-bytes)

  (let (rstr)
    (while (< (length (X-Dpy-message-buffer xdpy)) num)
      (when (null (accept-process-output (X-Dpy-proc xdpy)
                                         (or to-secs X-default-timeout) (or to-msecs 0)))
        ;; Timeouted
        (error "X: Timeout while reading from server.")))

    (setq rstr (substring (X-Dpy-message-buffer xdpy) 0 num)) ; save bytes to string

    ;; Update message-buffer
    (setf (X-Dpy-message-buffer xdpy)
          (substring (X-Dpy-message-buffer xdpy) num))
    rstr))

;; These are defined so we can use them recursivly below
(defvar length-1 nil)
(defvar length-2 nil)
(defvar length-3 nil)
(defvar length-4 nil)

(defun X-Dpy-parse-message (message-s req-id xdpy &rest arglist)
  "Receive (via filter and waiting) a response from  the X server.
Parses MESSAGE-S structure.  When MAY-GUESS is t then if 1st el is not 1 or 0,
we must process as an event instead.  Then keep looping on guess until we get
a 0 or 1.  If not, then we are processing sub-lists.  Processing is done for
XDPY.  ARGLIST is some list of arguments.

When FROM-X-PARSE-MESSAGE is non-nil than we are called from `X-Dpy-parse-message'.

MESSAGE-S is made of size vectors `X-Dpy-create-message':

  [SIZE ENCODING]

  SIZE is how many bytes it occupies in the message.
  ENCODING is how to interpret it.

  If encoding is 'success, then the following vectors are two lists.
The first is the Failure case.  nil is a generic failure.
The second is the Success case.

  Encoding can also be one of the following:
  nil      -- Not used
  integerp -- Format integer
  stringp  -- Formatted string
  length-# -- Number stored in variable `length-#' where # is 0-4.

The length-# variables are used to read a length from one section
of a message, and use it as the size field of a later occuring field.
A variable-length string can occur like this:

  [2 length-0]       ; length of string, does not appear in the list
  [length-0 stringp] ; name"

  (X-Dpy-p xdpy 'X-Dpy-parse-message)

  (let ((inhibit-quit t)                ; so C-g will not desync
        (rlist nil)
        (reverse-me t)
        (length-1 (if (boundp 'length-1) length-1 nil))
        (length-2 (if (boundp 'length-2) length-2 nil))
        (length-3 (if (boundp 'length-3) length-3 nil))
        (length-4 (if (boundp 'length-4) length-4 nil)) )
    (while (and message-s (listp message-s))
      (let* ((tvec (car message-s))
             (tlen (aref tvec 0))
             (tval1 (aref tvec 1))
             (tval (if (and (listp tval1)
                            (member (car tval1) '(or if cond))) ;XXX
                       (eval tval1)
                     tval1))
             (result (unless (and tval (listp tval))
                       ;; Do not grab bytes for sub-lists
                       (if (or (symbolp tlen) (listp tlen))
                           (X-Dpy-grab-bytes xdpy (eval tlen))
                         (X-Dpy-grab-bytes xdpy tlen)))))

        ;; We need to put in code to represent sizes sometimes,
        ;; this will get that size.
        (when (or (listp tlen) (symbolp tlen))
          (setq tlen (eval tlen)))

        ;; Check for use of an argument.
        (when (equal tval 'arg)
          (setq tval (car arglist))
          (setq arglist (cdr arglist)))

        ;; If the val is a list, and it is an if statement, then
        ;; we want to evaluate it to get the real tval type.
        (when (and (listp tval)
                   (member (car tval) '(if or make-list)))
          (setq tval (eval tval)))

        (cond
         ;; boolean success stories.
         ((equal tval 'success)
          (let ((sublst
                 (cond ((= (aref result 0) 1)
                        ;; success condition
                        (setq result t)
                        (X-Dpy-parse-message (car (cdr (cdr message-s)))
                                             req-id xdpy arglist))

                       (t
                        ;; Here is event or error arrived, process
                        ;; errors in time or store event in events
                        ;; queue.
                        (X-Dpy-log xdpy 'x-event "!!: Inter Evaluating event ..")
                        (let ((xev (X-Dpy-parse-event
                                    xdpy (Xforcenum (aref result 0))))
                              pmsg)
                          (prog1
                              (if (and (= (X-Event-type xev) 0)
                                       (= (X-Event-seq xev)
                                          (logand req-id 65535)))
                                  ;; Error of current request
                                  (setq result nil)

                                ;; Repeat processing XXX excluding t or nil
                                (X-Dpy-log xdpy 'x-event "!!: Reprocessing: %d bytes pending, msg=%S"
                                           '(length (X-Dpy-message-buffer xdpy)) 'message-s)
                                (setq pmsg (X-Dpy-parse-message
                                            message-s req-id xdpy arglist)
                                      result (car pmsg))
                                (X-Dpy-log xdpy 'x-event "!!: Reprocessing done %d bytes pending."
                                           '(length (X-Dpy-message-buffer xdpy)))
                                (cdr pmsg))
                            (X-Dpy-dispatch-event xev)))))))
            (setq rlist (cons result sublst)))

          (setq message-s nil)
          (setq reverse-me nil))

         ;; numberp means natural number, not safe!
         ((eq tval 'numberp)
          (setq rlist (cons (funcall (if (<= tlen 2)
                                         'string2->number
                                       'string4->number) result)
                            rlist)))

         ;; integerp means tac onto end of list as an int
         ((eq tval 'integerp)
          (if (<= tlen 2)
              (setq rlist (cons (string->int result) rlist))
            (setq rlist (cons (string4->int result) rlist))))

         ;; stringp means tac onto end of list as string (verbatim)
         ((eq tval 'stringp)
          (setq rlist (cons result rlist)))

         ;; booleans don't really exist, but turn a 0 into nil, and 1 into t
         ((eq tval 'booleanp)
          (setq rlist (cons (if (= 0 (string->int result)) nil t) rlist)))

         ;; TODO: maybe add card8, card16, card32, int8, int16, int32,
         ;; string8, string16, etc?

         ;; Special forms
         ((eq tval :X-Rect)
          (setq tlen (/ tlen 8))
          (while (> tlen 0)
            (setq rlist (cons (make-X-Rect :x (string->int (substring result 0 2))
                                           :y (string->int (substring result 2 4))
                                           :width (string->int (substring result 4 6))
                                           :height (string->int (substring result 6 8)))
                              rlist))
            (setq result (substring result 8))
            (setq tlen (1- tlen))))

         ((eq tval :X-Win)
          (setq tlen (/ tlen 4))
          (while (> tlen 0)
            (setq rlist (cons (X-Win-find-or-make xdpy (string4->int result))
                              rlist))
            (setq result (substring result 4))
            (setq tlen (1- tlen))))

         ((eq tval :X-Atom)
          (setq tlen (/ tlen 4))
          (while (> tlen 0)
            (setq rlist (cons (X-Atom-find-or-make xdpy (string4->int result))
                              rlist))
            (setq result (substring result 4))
            (setq tlen (1- tlen))))

         ;; if it is a list, then we need to recursivly call ourselvs X
         ;; times on it.
         ((and tval (listp tval))
          ;; WARNING: subparts cannot use args. ;(
          (let ((sublst nil))
            (while (> tlen 0)
              (setq sublst (cons (X-Dpy-parse-message tval req-id xdpy arglist) sublst))
              (setq tlen (1- tlen)))
            ;; The sub-list of items is backwards: fix
            (setq rlist (cons (nreverse sublst) rlist))))

         ;; not a type, but some other symbol, then put it there!
         ;; if it is one of the lengththings, intify it.
         ((and tval (symbolp tval) (not (keywordp tval)))
          (if (string-match "length" (symbol-name tval))
              (set tval (string->int result))
            (set tval result)))

         ;; do nothing
         ((equal tval nil))

         ;; error case.
         (t
          (error "Error parsing X response!!!"))))
      (setq message-s (cdr message-s)))

    ;; Now that that is over, conditionally reverse the list.
    (if reverse-me
        (nreverse rlist)
      rlist)))

(defun X-Dpy-eval-error-or-event (xdpy)
  "There data on XDPY, it is error or event."
  (X-Dpy-read-excursion xdpy
    (let* ((result (X-Dpy-grab-bytes xdpy 1))
           (evetype (Xforcenum (aref result 0))))

      (cond ((= evetype 1)              ; reply, should not happen
             (X-Dpy-log xdpy 'x-error "Got unknown reply, while expecting XEvent! CRITICAL!")
             (error "Got unknown reply, while expecting XEvent!"))
            ;; Below code is not quite correct.  Because X exntensions
            ;; that generates events may use values greater then
            ;; X-MaxEvent.
;            ((>= evetype X-MaxEvent)
;            (X-Dpy-log xdpy 'x-error "Got XEvent id(%d) greater than X-MaxEvent! CRITICAL!"
;                       'evetype)
;             (error (format "Got X Event id(%d) greater than X-MaxEvent!" evetype)))
            (t (X-Dpy-dispatch-event
                (X-Dpy-parse-event xdpy evetype)))) ; error or event
      )))

;; Events/Errors dispatchers
(defvar xlib-opcodes-alist
  '((104 . XBell)
    (1 . XCreateWindow)
    (2 . XChangeWindowAttributes)
    (3 . XGetWindowAttributes)
    (12 . XConfigureWindow)
    (8 . XMapWindow)
    (10 . XUnmapWindow)
    (4 . XDestroyWindow)
    (5 . XDestroySubwindows)
    (15 . XQueryTree)
    (16 . XInternAtom)
    (17 . XGetAtomName)
    (18 . XChangeProperty)
    (20 . XGetWindowProperty)
    (78 . XCreateColormap)
    (79 . XFreeColormap)
    (84 . XAllocColor)
    (85 . XAllocNamedColor)
    (86 . XAllocColorCells)
    (89 . XStoreColors)
    (88 . XFreeColors)
    (91 . XQueryColors)
    (55 . XCreateGC)
    (56 . XChangeGC)
    (58 . XSetDashes)
    (59 . XSetClipRectangles)
    (60 . XFreeGC)
    (61 . XClearArea)
    (62 . XCopyArea)
    (63 . XCopyPlane)
    (64 . XDrawPoints)
    (65 . XDrawLines)
    (69 . XFillPoly)
    (66 . XDrawSegments)
    (67 . XDrawRectangles)
    (70 . XDrawRectangles)
    (68 . XDrawArcs)
    (71 . XDrawArcs)
    (74 . XDrawString)
    (76 . XImageString)
    (72 . XPutImage)
    (73 . XGetImage)
    (22 . XSetSelectionOwner)
    (23 . XGetSelectionOwner)
    (24 . XConvertSelection)
    (41 . XWarpPointer)
    (36 . XGrabServer)
    (37 . XUngrabServer)
    (38 . XQueryPointer)
    (31 . XGrabKeyboard)
    (32 . XUngrabKeyboard)
    (26 . XGrabPointer)
    (27 . XUngrabPointer)
    (28 . XGrabButton)
    (29 . XUngrabButton)
    (33 . XGrabKey)
    (34 . XUngrabKey)
    (43 . XGetInputFocus)
    (42 . XSetInputFocus)
    (7 . XReparentWindow)
    (14 . XGetGeometry)
    (40 . XTranslateCoordinates)
    (6 . XChangeSaveSet)
    (25 . XSendEvent)
    (44 . XQueryKeymap)
    (101 . XGetKeyboardMapping)
    (119 . XGetModifierMapping)
    (45 . XOpenFont)
    (47 . XQueryFont)
    (48 . XQueryTextExtents)
    (53 . XCreatePixmap)
    (54 . XFreePixmap)
    (93 . XCreateCursor)
    (94 . XCreateGlyphCursor)
    (95 . XFreeCursor)
    (96 . XRecolorCursor)
    (30 . XChangeActivePointerGrab)
    (98 . XQueryExtension)
    (107 . XSetScreenSaver)
    (108 . XGetScreenSaver)
    (113 . XKillClient)
    (115 . XForceScreenSaver))
  "Alist of X opcodes in form (OPCODE . FUNCTION).
This is only informative variable.")

(defun X-Dpy-run-error-hooks (xdpy xev)
  "Run XDPY's error hooks."
  (when (X-Dpy-error-hooks xdpy)
    (mapcar #'(lambda (fun)
                (funcall fun xdpy xev))
            (X-Dpy-error-hooks xdpy))))

(defun X-Dpy-error-dispatch (xev)
  "Dispatch error event XEV."
  (let* ((xdpy (X-Event-dpy xev))
         (err (X-Event-xerror-code xev))
         (badth (X-Event-xerror-resourceid xev))
         (seq (X-Event-seq xev))
         (maj (X-Event-xerror-maj-op xev))
         (opfun (cdr (assq maj xlib-opcodes-alist)))
         (min (X-Event-xerror-min-op xev))
         (bstr (cond ((= err 1) "Request")
                     ((= err 2) "Value")
                     ((= err 3) "Window")
                     ((= err 4) "Pixmap")
                     ((= err 5) "Atom")
                     ((= err 6) "Cursor")
                     ((= err 7) "Font")
                     ((= err 8) "Match")
                     ((= err 9) "Drawable")
                     ((= err 10) "Access")
                     ((= err 11) "Alloc")
                     ((= err 12) "Color")
                     ((= err 13) "GC")
                     ((= err 14) "IDChoice")
                     ((= err 15) "Name")
                     ((= err 16) "Length")
                     ((= err 17) "Implementation")
                     ((= err 128) "FirstExtension")
                     ((= err 255) "LastExtension")
                     (t "Unknown"))))
    (declare (special bstr))
    (declare (special min))
    (declare (special opfun))
    (declare (special seq))
    (declare (special badth))
    (X-Dpy-log xdpy 'x-error "X-Error: Bad %s %f seq=%f:%d ops=%d:%d/%S"
               'bstr 'badth 'seq '(X-Dpy-rseq-id xdpy) 'maj 'min 'opfun)

    ;; Now run hooks if any
    (X-Dpy-run-error-hooks xdpy xev)))

;;; Some usefull macroses (NOT USED)
(defmacro X-Generic-enqueue (obj queue)
  "Enqueue object QBJ into setf'able QUEUE."
  `(if (null ,queue)
       (setf ,queue (list ,obj))
     (setcdr (last ,queue) (list ,obj))))

(defmacro X-Generic-prequeue (obj queue)
  "Prepend object OBJ into setf'able QUEUE."
  `(setf ,queue (cons ,obj ,queue)))

(defmacro X-Generic-dequeue (queue)
  "Dequeue first object from setf'able QUEUE."
  `(let ((obj (car ,queue)))
     (setf ,queue (cdr ,queue))
     obj))

;;; Events queue support
(defun X-Dpy-default-events-dispatcher (xdpy xev)
  "Default events  dispatcher."
  (let ((win-ev (X-Event-win-event xev)))
    (when (X-Win-p win-ev)
      ;; First run display handlers
      (when (X-Dpy-event-handlers xdpy)
       (X-Dpy-EventHandler-runall xdpy xev))

      ;; Then run WIN specific handlers
      (when (X-Win-event-handlers win-ev)
       ;; WIN has its own event handlers
       (X-Win-EventHandler-runall win-ev xev)))))

(defun X-Dpy-event-dispatch (xev)
  "Dispatch event XEV."
  (let ((xdpy (X-Event-dpy xev)))
    (X-Dpy-log xdpy 'x-event "Got X event: %S for win %S / %S"
               '(X-Event-name xev)
              '(if (X-Win-p (X-Event-win-event xev))
                   (X-Win-id (X-Event-win-event xev))
                 (X-Event-win-event xev))
              '(if (X-Win-p (X-Event-win xev))
                   (X-Win-id (X-Event-win xev))
                 (X-Event-win xev)))

    (when (X-Dpy-events-dispatcher xdpy)
      (funcall (X-Dpy-events-dispatcher xdpy) xdpy xev))))

(defsubst X-Dpy-event-enqueue (event)
  "Enqueue EVENT in XDPY's events queue."
  (enqueue-eval-event 'X-Dpy-event-dispatch event))

(defun X-Dpy-dispatch-event (xev)
  "Dispatch X Event or error XEV."
  (if (= (X-Event-type xev) 0)
      (X-Dpy-error-dispatch xev)
    (X-Dpy-event-enqueue xev)))

(defun X-Dpy-parse-event (xdpy evtype)
  "On XDPY construct and enqueue event of EVTYPE type."
  ;; TODO: what about X-Event-evdata?
  ;;   (evdata (substring (X-Dpy-message-buffer xdpy) 0 31))
  ;;   :evdata (concat (char-to-string (XCharacter type)) evdata)
  (X-Dpy-read-excursion xdpy
    (let* ((type evtype)
           (synth (= (logand X-SyntheticMask type) X-SyntheticMask))
           (type (if synth (- type X-SyntheticMask) type))
           (xev (make-X-Event :dpy xdpy :type type :synth-p synth))
           (evspec (aref X-EventsList type))
           (evin (X-Dpy-parse-message (or (and evspec (aref evspec 1)) (list [31 nil])) 0 xdpy)))
      (setf (X-Event-evinfo xev) evin)

      (X-Dpy-log xdpy 'x-event "XLIB: Get new event %d(%s) win=%S ...."
                 '(X-Event-type xev) '(X-Event-name xev)
                 '(and (X-Win-p (X-Event-win xev))
                       (X-Win-id (X-Event-win xev))))

      xev)))

;;; Function to call when there data in XDPY, but noone reading it.
(defun X-Dpy-parse-message-guess (xdpy)
  "There is data waiting on XDPY, but no-one is reading it.
Try to guess what it is."
  (X-Dpy-p xdpy 'X-Dpy-parse-message-guess)

  ;; If no-one reading now, mean than error or event arrived.
  (while (and (zerop (X-Dpy-readings xdpy))
              (> (length (X-Dpy-message-buffer xdpy)) 0))
    (X-Dpy-eval-error-or-event xdpy)))


(provide 'xlib-xr)

;;; xlib-xr.el ends here
