;;; xlib-xlib.el --- X library part of new xlib.

;; 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-xlib.el,v 1.9 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-xr)

(defun XOpenDisplay (name &optional dispnum screen)
  "Open an X connection to the display named NAME such as host:0.1.
Optionally you may pass DISPNUM - display number and SCREEN - screen number."
  ;; first, open a connection to name
  (when (string-match ":\\([0-9]*\\|[0-9]*\\)\.*\\([0-9]*\\)" name)
    (setq dispnum
	  (or dispnum
	      (truncate (string-to-int (substring name (match-beginning 1) (match-end 1))))))
    (setq screen
	  (or screen
	      (truncate (string-to-int (substring name (match-beginning 2) (match-end 2))))))
    (setq name (substring name 0 (- (match-beginning 1) 1))))

  (when (= (length name) 0)
    (setq name (system-name)))

  (let ((xdpy (X-Dpy-create-connection name dispnum)))
    ;; Connection is open, and X-info contains connection informaion.
    (let ((X-info (X-Dpy-send-read xdpy (X-Create-message X-client-to-open)
				   X-connect-response)))

      (if (null (nth 0 X-info))
	  (message "X: %s" (nth X-info 3))

	(setf (X-Dpy-proto-maj xdpy) (nth 1 X-info))
	(setf (X-Dpy-proto-min xdpy) (nth 2 X-info))
	(setf (X-Dpy-resource-base xdpy) (nth 4 X-info))
	(setf (X-Dpy-resource-mask xdpy) (nth 5 X-info))
	(setf (X-Dpy-motion-bufsize xdpy) (nth 6 X-info))
	(setf (X-Dpy-max-request-size xdpy) (nth 7 X-info))
	(setf (X-Dpy-byte-order xdpy) (nth 8 X-info))
	(setf (X-Dpy-bitmap-scanline-unit xdpy) (nth 9 X-info))
	(setf (X-Dpy-bitmap-scanline-pad xdpy) (nth 10 X-info))
	(setf (X-Dpy-bitmap-bit-order xdpy) (nth 11 X-info))
	(setf (X-Dpy-min-keycode xdpy) (nth 12 X-info))
	(setf (X-Dpy-max-keycode xdpy) (nth 13 X-info))
	(setf (X-Dpy-vendor xdpy) (nth 14 X-info))

	;; Fill formats list
	(setf (X-Dpy-formats xdpy)
	      (mapcar #'(lambda (fmt)
                          (make-X-ScreenFormat :depth (nth 0 fmt)
                                               :bits-per-pixel (nth 1 fmt)
                                               :scanline-pad (nth 2 fmt)))
		      (nth 15 X-info)))

	;; Fill screens list
	(setf (X-Dpy-screens xdpy)
	      (mapcar #'(lambda (scr)
                          (let (nscreen)
                            (setq nscreen
                                  (make-X-Screen
                                   :root (X-Win-find-or-make xdpy (nth 0 scr))
                                   :colormap (make-X-Colormap :dpy xdpy :id (nth 1 scr))
                                   :white-pixel (make-X-Color :dpy xdpy :id (nth 2 scr))
                                   :black-pixel (make-X-Color :dpy xdpy :id (nth 3 scr))
                                   :root-event-mask (nth 4 scr)
                                   :width (nth 5 scr)
                                   :height (nth 6 scr)
                                   :mwidth (nth 7 scr)
                                   :mheight (nth 8 scr)
                                   :min-maps (nth 9 scr)
                                   :max-maps (nth 10 scr)
                                   :visualid (nth 11 scr)
                                   :backingstores (nth 12 scr)
                                   :save-unders (nth 13 scr)
                                   :root-depth (nth 14 scr)))

                            (setf (X-Screen-depths nscreen)
                                  (mapcar #'(lambda (dpth)
                                              (make-X-Depth :depth (nth 0 dpth)
                                                            :visuals (mapcar #'(lambda (vis)
                                                                                 (make-X-Visual :id (nth 0 vis)
                                                                                                :class (nth 1 vis)
                                                                                                :bits-per-rgb (nth 2 vis)
                                                                                                :cmap-entries (nth 3 vis)
                                                                                                :red-mask (nth 4 vis)
                                                                                                :green-mask (nth 6 vis)
                                                                                                :blue-mask (nth 5 vis)))
                                                                             (nth 1 dpth))))
                                          (nth 15 scr)))

                            ;; Create default GC
                            (setf (X-Screen-default-gc nscreen)
                                  (XCreateGC xdpy (X-Screen-root nscreen)
                                             (make-X-Gc :dpy xdpy :id (X-Dpy-get-id xdpy)
                                                        :foreground (X-Screen-white-pixel nscreen)
                                                        :background (X-Screen-black-pixel nscreen))))
                            nscreen))
		      (nth 16 X-info)))

	;; Alert user
	(message "Connection opened to %s...done" name)
	xdpy))))

(defun XCloseDisplay (xdpy)
  "Close the connection to display XDPY."
  (X-Dpy-close xdpy))

(defun XScreenCheck (xdpy scrnum)
  "Check SCRNUM screen on display XDPY."
  (unless scrnum
    (setq scrnum 0))

  (when (> scrnum (1- (length (X-Dpy-screens xdpy))))
    (error "xlib: screen with number %d does not exists." scrnum))
  scrnum)
  
(defsubst XDefaultRootWindow (xdpy &optional scrnum)
  "Return default root window on XDPY."
  (X-Dpy-p xdpy 'XDefaultRootWindow)
  (X-Screen-root (nth (XScreenCheck xdpy scrnum) (X-Dpy-screens xdpy))))

(defsubst XWhitePixel (xdpy &optional scrnum)
  "Return white pixel for display XDPY."
  (X-Dpy-p xdpy 'XWhitePixel)
  (X-Screen-white-pixel (nth (XScreenCheck xdpy scrnum) (X-Dpy-screens xdpy))))

(defsubst XBlackPixel (xdpy &optional scrnum)
  "Return black pixel for display XDPY."
  (X-Dpy-p xdpy 'XBlackPixel)
  (X-Screen-black-pixel (nth (XScreenCheck xdpy scrnum) (X-Dpy-screens xdpy))))

(defsubst XDefaultColormap (xdpy &optional scrnum)
  "Return default colormap for XDPY on screen SCRNUM."
  (X-Dpy-p xdpy 'XDefaultColormap)
  (X-Screen-colormap (nth (XScreenCheck xdpy scrnum) (X-Dpy-screens xdpy))))

(defsubst XDefaultVisual (xdpy &optional scrnum)
  "Return visual on XDPY and SCRNUM."
  (X-Dpy-p xdpy 'XDefaultVisual)
  (X-Screen-visualid (nth (XScreenCheck xdpy scrnum) (X-Dpy-screens xdpy))))

(defsubst XDefaultGC (xdpy &optional scrnum)
  "Return default GC on XDPY and SCRNUM."
  (X-Dpy-p xdpy 'XDefaultGC)
  (X-Screen-default-gc (nth (XScreenCheck xdpy scrnum) (X-Dpy-screens xdpy))))

(defun XDefaultDepth (xdpy &optional scrnum)
  "Return default depth on XDPY and screen SCRNUM."
  (X-Dpy-p xdpy 'XDefaultDepth)

  (or (X-Dpy-get-property xdpy 'default-depth)
      (let ((vid (XDefaultVisual xdpy))
            (depths (X-Screen-depths (nth (XScreenCheck xdpy scrnum) (X-Dpy-screens xdpy))))
            viss found)
        (while (and depths (not found))
          (setq viss (X-Depth-visuals (car depths)))
          (while (and viss (not (= (X-Visual-id (car viss)) vid)))
            (setq viss (cdr viss)))
          (if (car viss)
              (setq found t)
            (setq depths (cdr depths))))

        (if (car depths)
            (progn
              (X-Dpy-put-property xdpy 'default-depth (X-Depth-depth (car depths)))
              (X-Depth-depth (car depths)))

          ;; Hmm, why not found?
          (X-Depth-depth (car (X-Screen-depths (nth (XScreenCheck xdpy scrnum) (X-Dpy-screens xdpy)))))))))

(defun X-Dpy-find-visual-for-depth (xdpy depth &optional scrnum)
  "On display XDPY find appopriate visual for DEPTH."
  (let ((depths (X-Screen-depths (nth (XScreenCheck xdpy scrnum) (X-Dpy-screens xdpy)))))
    (while (and depths (not (= (X-Depth-depth (car depths)) depth)))
      (setq depths (cdr depths)))
    (when (car depths)
      ;; XXX
      (car (X-Depth-visuals (car depths))))))

;;; Simple Noise
(defun XBell (xdpy percent)
  "Ring the bell on XDPY at PERCENT volume."
  (X-Dpy-p xdpy 'XBell)
  (let ((ListOfFields
	 (list [1 104]			;opcode
	       [1 percent]		;percentage
	       [2 1])))			;length of request (in 4s)
    (X-Dpy-send xdpy (X-Create-message ListOfFields))))


(defun XCreateWindow (xdpy &optional parent x y width height
			    border-width depth class visual
			    attrs)
  "Create a window."
  (X-Dpy-p xdpy 'XCreateWindow)

  (let* ((wid (X-Dpy-get-id xdpy))
	 (attrmsg (X-Attr-message attrs))
	 (ListOfFields
	  (list [1 1]			; opcode
		[1 (or depth X-CopyFromParent)] ;depth
		[2 (+ 7 (/ (length attrmsg) 4))] ;8 means no attributes yet
		[4 wid]			;newly alloced wid.
		[4 (X-Win-id
		    (if (X-Win-p parent) parent	;the parent
		      (XDefaultRootWindow xdpy))) ]
		[2 (or x 100)]	;x position
		[2 (or y 100)]	;y position
		[2 (or width 100)] ;width
		[2 (or height 100)] ;height
		[2 (or border-width 1)] ;border width
		[2 (or class X-CopyFromParent)] ;class
		[4 (or visual X-CopyFromParent)] ;visual
		))
	 (msg (concat (X-Create-message ListOfFields)
		      attrmsg)))
    (X-Dpy-send xdpy msg)
    (X-Win-find-or-make xdpy wid)))

(defun XChangeWindowAttributes (xdpy win attrs)
  "On XDPY and window WIN, change to the ATTRIBUTES."
  (X-Dpy-p xdpy 'XChangeWindowAttributes)
  (X-Attr-p attrs 'XChangeWindowAttributes)
  (X-Win-p win 'XChangeWindowAttributes)

  (let* ((attrmsg (X-Attr-message attrs))
	 (ListOfFields
	  (list [1 2]			;opcode
		[1 nil]			;unused
		[2 (+ 2 (/ (length attrmsg) 4))] ;length
		[4 (X-Win-id win)]))	;window
	 (msg (concat (X-Create-message ListOfFields) attrmsg)))
    (X-Dpy-send xdpy msg)))

(defun XSelectInput (xdpy win event)
  "On display XDPY for window WIN, set the EVENT mask."
  (XChangeWindowAttributes xdpy win (make-X-Attr :event-mask event)))

(defun XSetWindowBackground (xdpy win pixel)
  "On display XDPY for window WIN, set the background to PIXEL."
  (XChangeWindowAttributes xdpy win (make-X-Attr :background-pixel pixel)))

(defun XSetWindowBackgroundPixmap (xdpy win pixmap)
  "On display XDPY for window WIN, set the background pixmap to PIXMAP."
  (XChangeWindowAttributes xdpy win (make-X-Attr :background-pixmap pixmap)))
  
(defun XSetWindowBorder (xdpy win pixel)
  "On display XDPY for window WIN, set the border color to PIXEL."
  (XChangeWindowAttributes xdpy win (make-X-Attr :border-pixel pixel)))

(defun XSetWindowColormap (xdpy win cmap-id)
  "On display XDPY for window WIN, set the colormap to CMAP-ID."
  (XChangeWindowAttributes xdpy win (make-X-Attr :colormap cmap-id)))

(defun XSetWindowCursor (xdpy win cursor)
  (XChangeWindowAttributes xdpy win (make-X-Attr :cursor cursor)))

(defun XGetWindowAttributes (xdpy win)
  "On display XDPY, get window's WIN attributes as an `X-Attr'."
  (X-Dpy-p xdpy 'XGetWindowAttributes)
  (X-Win-p win 'XGetWindowAttributes)

  (let ((ListOfFields
	 (list [ 1 3]			;opcode
	       [ 1 nil]                 ;unused
	       [ 2 2]			;request length
	       [ 4 (X-Win-id win)]))	;the window
	(ReceiveFields
	 (list [1 success ]		;status
	       nil			;generic bad response
	       (list
;		[ 1 integerp ]		;reply
		[ 1 integerp ]		;backingstore
		[ 2 integerp ]		;sequence number
		[ 4 integerp ]		;reply length
		[ 4 integerp ]		;visual id
		[ 2 integerp ]		;class
		[ 1 integerp ]		;bit gravity
		[ 1 integerp ]		;win gravity
		[ 4 integerp ]		;backing planes
		[ 4 integerp ]		;backing pixel
		[ 1 integerp ]		;save under
		[ 1 integerp ]		;map is installed
		[ 1 integerp ]		;map state
		[ 1 integerp ]		;override-redirect
		[ 4 integerp ]		;colormap
		[ 4 integerp ]		;all event masks
		[ 4 integerp ]		;my event masks
		[ 2 integerp ]		;do not propagate mask
		[ 2 nil ] )))		;pad
	(r nil))

    (setq r (X-Dpy-send-read xdpy (X-Create-message ListOfFields) ReceiveFields))
    (if (not (car r))
	nil
      (make-X-Attr :backing-store (nth 1 r)
		   :visualid (nth 4 r)
		   :bit-gravity (nth 6 r)
		   :win-gravity (nth 7 r)
		   :backing-planes (nth 8 r)
		   :backing-pixel (nth 9 r)
		   :save-under (if (= (nth 10 r) 0) nil t)
		   :mapstate (nth 12 r)
		   :override-redirect (if (= (nth 13 r) 0) nil t)
		   :colormap (make-X-Colormap :dpy xdpy :id (nth 14 r))
		   :event-mask (nth 16 r)
		   :do-not-propagate-mask (nth 17 r)))))

(defun XConfigureWindow (xdpy win conf)
  "On display XDPY, change window WIN to have configuration CONF.
CONF is an `X-Conf' structure."
  (X-Dpy-p xdpy 'XConfigureWindow)
  (X-Conf-p conf 'XConfigureWindow)
  (X-Win-p win 'XConfigureWindow)

  (let* ((cfgmsg (X-Conf-message conf))
	 (ListOfFields
	  (list [1 12]			;opcode
		[1 nil]			;unused
		[2 (+ 2 (/ (length cfgmsg) 4))]	;length
		[4 (X-Win-id win)]))	;window
	 (msg (concat (X-Create-message ListOfFields) cfgmsg)))
    (X-Dpy-send xdpy msg)))

(defun XLowerWindow (xdpy win)
  "On display XDPY, lower window WIN."
  (XConfigureWindow xdpy win (make-X-Conf :stackmode X-Below))) 

(defun XRaiseWindow (xdpy win)
  "On display XDPY, raise window WIN."
  (XConfigureWindow xdpy win (make-X-Conf :stackmode X-Above)))

(defun XMoveWindow (xdpy win x y)
  "On display XDPY, move window WIN to position X Y."
  (XConfigureWindow xdpy win (make-X-Conf :x x :y y)))

(defun XResizeWindow (xdpy win w h)
  "On display XDPY, resize window WIN to dimentions W H."
  (XConfigureWindow xdpy win (make-X-Conf :width w :height h))) 

(defun XMoveResizeWindow (xdpy win x y w h)
  "On display XDPY, move and resize window WIN to X, Y, W, H."
  (XConfigureWindow xdpy win (make-X-Conf :x x :y y :width w :height h)))

(defun XSetWindowBorderWidth (xdpy win width)
  "On display XDPY, set window's WIN border to be WIDTH pixels wide."
  (XConfigureWindow xdpy win (make-X-Conf :border-width width)))

(defun XMapWindow (xdpy win)
  "On display XDPY, map WIN to the screen (to make it visible.)."
  (X-Dpy-p xdpy 'XMapWindow)
  (X-Win-p win 'XMapWindow)

  (let ((ListOfFields
	 (list [1 8]			;opcode
	       [1 nil]			;unused
	       [2 2]			;length of request (in 4s)
	       [4 (X-Win-id win)])))	;window to map
    (X-Dpy-send xdpy (X-Create-message ListOfFields))))

(defun XUnmapWindow (xdpy win)
  "On display XDPY, unmap window WIN to make it hidden."
  (X-Dpy-p xdpy 'XUnmapWindow)
  (X-Win-p win 'XUnmapWindow)

  (let ((ListOfFields
	 (list [1 10]			;opcode
	       [1 nil]			;unused
	       [2 2]			;length of request (in 4s)
	       [4 (X-Win-id win)])))	;window to map
    (X-Dpy-send xdpy (X-Create-message ListOfFields))))

(defun XDestroyWindow (xdpy win)
  "On display XDPY, destroy window WIN."
  (X-Dpy-p xdpy 'XDestroyWindow)
  (X-Win-p win 'XDestroyWindow)

  (let ((ListOfFields
	 (list [1 4]			;opcode
	       [1 nil]			;unused
	       [2 2]			;length of request (in 4s)
	       [4 (X-Win-id win)])))	;window to map
    (X-Dpy-send xdpy (X-Create-message ListOfFields))

    ;; Schedule window WIN for total removing
    (X-Win-invalidate xdpy win)))

(defun XDestroySubwindows (xdpy win)
  "On display XDPY, destroy subwindows of window WIN."
  (X-Dpy-p xdpy 'XDestroySubwindows)
  (X-Win-p win 'XDestroySubwindows)

  (let ((ListOfFields
	 (list [1 5]			;opcode
	       [1 nil]			;unused
	       [2 2]			;length of request (in 4s)
	       [4 (X-Win-id win)])))	;window to map
    (X-Dpy-send xdpy (X-Create-message ListOfFields))))

(defun XQueryTree (xdpy win)
  "Query display XDPY for all children of window WIN.
Returns a list of the form (ROOT PARENT CHILD1 CHILD2 ...)
on success, or nil on failure.  ROOT is the root window for the display that
WINDOW is on.  PARENT is the parent of WINDOW, and CHILDN are the
children of WINDOW."
  (X-Dpy-p xdpy 'XQueryTree)
  (X-Win-p win 'XQueryTree)

  (let* ((ListOfFields
	  (list [ 1 15]                 ;opcode
		[ 1 nil ]		;unused
		[ 2 2 ]			;request length
		[ 4 (X-Win-id win)]))	;window we are querying.
	 (ReceiveFields
	  (list [ 1 success]		;status
		nil			;generic bad response
		(list [ 1 nil]		;unused
		      [ 2 integerp ]	;sequence number
		      [ 4 length-1 ]	;length of the return in 4 blocks
		      [ 4 :X-Win ]	;root window
		      [ 4 :X-Win ]	;parent window
		      [ 2 length-2 ]	;number of children
		      [ 14 nil ]	;unused
		      [ (* 4 length-2) :X-Win])))) ;list of the children

    (X-Dpy-send-read xdpy (X-Create-message ListOfFields) ReceiveFields)))


;;; Time to play with properties and Atoms
;;
(defun XInternAtom (xdpy name &optional only-if-exists)
  "On display XDPY, return the Atom with NAME.
If ONLY-IF-EXISTS is nil, then the atom is created if it does not already
exist.  The Atom object is returned."
  (X-Dpy-p xdpy 'XInternAtom)
  (if (not (stringp name))
      (signal 'wrong-type-argument (list 'signal 'stringp name)))

  (let ((a (X-Atom-find-by-name xdpy name)))
    (if (X-Atom-p a)
	a
      (let ((ListOfFields
	     (list [1 16]		;opcode
		   [1 only-if-exists]	;forcecreate flag.
		   [2 (+ 2 (X-padlen name))] ;message length
		   [2 (length name)]	;name length
		   [2 nil]		;unused
		   [(length name) name] ;name
		   ;; Auto-padded
		   ))
	    (ReceiveFields
	     (list [1 success]		;status message
		   nil			;generic bad response
		   (list [1 nil]	;unused
			 [2 integerp]   ;sequence
			 [4 nil]	;reply length
			 [4 :X-Atom]    ;atom id
			 [20 nil])))
	    r)

	(setq r (X-Dpy-send-read xdpy (X-Create-message ListOfFields) ReceiveFields))
	(if (car r)
	    (let ((rat (nth 2 r)))
	      (setf (X-Atom-name rat) name)
	      (X-Atom-insert xdpy rat)
	      rat)
	  nil)))))

(defun XGetAtomName (xdpy atom)
  "On display XDPY, get the textual name of ATOM.
*UNTESTED*"
  (X-Dpy-p xdpy 'XGetAtomName)
  (X-Atom-p atom 'XGetAtomName)

  (let ((a (X-Atom-find xdpy (X-Atom-id atom))))
    (if (X-Atom-p a)
	a
      (let ((ListOfFields
	     (list [ 1 17]		;opcode
		   [ 1 nil]		;unused
		   [ 2 2]		;length
		   [ 4 (X-Atom-id atom)])) ;atom id
	    (ReceiveFields
	     (list
	      [1 success ]		;status message
	      nil			;generic bad response
	      (list [ 1 nil ]		;unused
		    [ 2 integerp ]	;sequence
		    [ 4 length-1 ]	;reply length
		    [ 2 length-2 ]	;length of name
		    [ 22 nil ]		;unused
		    [ length-2 stringp ] ;the name
		    [ (X-pad length-2) nil ] ;padding
		    )))
	    r)
	(setq r (X-Dpy-send-read xdpy (X-Create-message ListOfFields) ReceiveFields))
	(if (car r)
	    (progn
	      (setf (X-Atom-name atom) (nth 2 r))
	      (X-Atom-insert xdpy atom)
	      (nth 2 r))
	  nil)))))

(defun XChangeProperty (xdpy win property type format mode data)
  "On display XDPY for window WIN, change PROPERTY.
PROPERTY is changed based on a TYPE, FORMAT, and MODE with DATA.
There are NElements."
  (X-Dpy-p xdpy 'XChangeProperty)
  (X-Win-p win 'XChangeProperty)
  (X-Atom-p property 'XChangeProperty)
  (X-Atom-p type 'XChangeProperty)

  (let* ((n (* (length data) (/ format 8)))
	 (p (X-pad n))
	 (ListOfFields
	  (list [1 18]			;opcode
		[1 mode]		;Mode: Replace Prepend, Append
		(vector 2 (+ 6 (/ (+ n p) 4)))	;length, shut up compiler
		[4 (X-Win-id win)]	;window
		[4 (X-Atom-id property)] ;property atom
		[4 (X-Atom-id type)]	;property type
		[1 format]		;property format
		[3 nil]
		[4 (/ n (/ format 8))]	;length of the list-byte thing
		)))
    (if (and (= format 8) (stringp data))
	(setq ListOfFields
	      (append ListOfFields (list (vector (length data) data))))
      (while data
	(let ((d (if (X-Generic-struct-p (car data))
		     (funcall (X-Generic-struct-p (car data)) (car data))
		   (car data))))
	  (setq ListOfFields
		(append ListOfFields (list (vector (/ format 8) d )))
		data (cdr data)))))
    (X-Dpy-send xdpy (X-Create-message ListOfFields))))

(defun XDeleteProperty (xdpy win atom)
  "On display XDPY for window WIN delete property denoted by ATOM."
  (X-Win-p win 'XDeleteProperty)
  (X-Atom-p atom 'XDeleteProperty)

  (let ((ListOfFields
         (list [1 19]			;opcode
               [1 nil]                  ;unused
               [2 3]                    ;length
               [4 (X-Win-id win)]       ;window
               [4 (X-Atom-id atom)])))  ;atom
    (X-Dpy-send xdpy (X-Create-message ListOfFields))))

;; These are Xlib convenience routines
(defun XSetPropertyString (xdpy win atom string &optional mode)
  "On display XDPY and window WIN set ATOM property to STRING."
  (XChangeProperty xdpy win atom XA-string X-format-8 (or mode X-PropModeReplace)
		    string))

(defun XSetWMProtocols (xdpy win protocol_atoms)
  "On display XDPY, set window's WIN protocols to PROTOCOL_ATOMS.
Convenience routine which calls `XChangeProperty'"
  (XChangeProperty xdpy win (XInternAtom xdpy "WM_PROTOCOLS" nil)
		    XA-atom X-format-32 X-PropModeReplace protocol_atoms))

(defun XSetWMClass (xdpy win wm-class)
  "On displayX DPY, set window's WIN Class to WM-CLASS.
WM-CLASS should be in form '(class-name class-intance)."
  (XChangeProperty xdpy win XA-wm-class XA-string X-format-8 X-PropModeReplace
		    (concat (car wm-class) (string 0) (cadr wm-class) (string 0))))

(defun XSetWMName (xdpy win wm-name)
  (XChangeProperty xdpy win XA-wm-name XA-string X-format-8 X-PropModeReplace
		    (concat wm-name)))

(defun XSetWMNormalHints (xdpy win wmnh)
  "On display XDPY, set window's WIN normal hints to HINTS.
HINTS is list in format (x1 x2 ... x18)."
  (X-WMSize-p wmnh 'XSetWMNormalHints)

  (let ((pplist (list (X-WMSize-flags wmnh) 0
		      (X-WMSize-x wmnh)
		      (X-WMSize-y wmnh)
		      (X-WMSize-width wmnh)
		      (X-WMSize-height wmnh)
		      (X-WMSize-min-width wmnh)
		      (X-WMSize-min-height wmnh)
		      (X-WMSize-max-width wmnh)
		      (X-WMSize-max-height wmnh)
		      (X-WMSize-width-inc wmnh)
		      (X-WMSize-height-inc wmnh)
		      (X-WMSize-min-aspect-x wmnh)
		      (X-WMSize-min-aspect-y wmnh)
		      (X-WMSize-max-aspect-x wmnh)
		      (X-WMSize-max-aspect-y wmnh)
		      (X-WMSize-base-width wmnh)
		      (X-WMSize-base-height wmnh)
		      (X-WMSize-gravity wmnh))))
		      
    (XChangeProperty xdpy win XA-wm-normal-hints XA-wm-size-hints X-format-32 X-PropModeReplace pplist)))

(defun XSetWMState (xdpy win wm-state &optional icon-id)
  "On display XDPY, set window's WIN state to WM-STATE.
WM-STATE is one of `X-WithdrawnState', `X-NormalState' or `X-IconicState'."
  (let ((wmsa (XInternAtom xdpy "WM_STATE" nil)))
    (XChangeProperty xdpy win wmsa wmsa X-format-32 X-PropModeReplace (list wm-state (or icon-id 0.0)))))

(defun XSetWMCommand (xdpy win cmd)
  "On display XDPY set window's WIN WM_COMMAND property to CMD."
  
  (XChangeProperty xdpy win (XInternAtom xdpy "WM_COMMAND" nil) XA-string
		   X-format-8 X-PropModeReplace cmd))

(defun XGetWindowProperty (xdpy win property &optional offset length delete required-type)
  "On display XDPY, get window's WIN PROPERTY atom value.
Get the data from optional OFFSET, and a maximum of LENGTH bytes.
OFFSET and LENGTH refer to 32 bit chunks, not 8 bit chunks.
Third optional argument DELETE will delete the property if Non-nil.
Fourth argument REQUIRED-TYPE filters only properties of the desired type.
If REQUIRED-TYPE is `XA-AnyPropertyType', or nil then no filtering is done.
The returned list is of the form:
  (TYPE_RETURN BYTES_AFTER PROP1 PROP2 ...)
Where TYPE_RETURN is the type (of same for as REQUIRED-TYPE) is the actual
type of the data being returned.
FORMAT_RETURN is the format of the data (such as 8, 16, or 32).
BYTES_AFTER is the number of bytes still attached to the property.
If there are extra bytes, then a second call to `XGetWindowProperty' will
be needed.  Lastly, PROP1 through PROPN is the list of properties
originally requested.
  It is common to call `XGetWindowProperty' asking for no data so that
BYTES_AFTER contains the exact amount of data we want to request."
  (X-Dpy-p xdpy 'XGetWindowProperty)
  (X-Win-p win 'XGetWindowProperty)
  (X-Atom-p property 'XGetWindowProperty)

  (unless offset (setq offset 0))
  (unless length (setq length 1024))
  (unless required-type (setq required-type XA-AnyPropertyType))

  (let ((ListOfFields
	 (list [ 1 20]			;opcode
	       [ 1 (if delete 1 0)]	;delete flag
	       [ 2 6 ]			;request length
	       [ 4 (X-Win-id win) ]	;the window whose property we want
	       [ 4 (X-Atom-id property) ] ;The property atom we want
	       [ 4 (X-Atom-id required-type) ] ;required type filter.
	       [ 4 offset ]		;offset in the property data
	       [ 4 length ]))		;length of data we want
	(ReceiveFields
	 (list [1 success]		;status message
	       nil			;generic bad response
	       (list
		[ 1 length-1 ]		;format of returned data
		[ 2 nil ]		;sequence number
		[ 4 length-3 ]		;length of this request
		[ 4 integerp ]		;atom representing return type
		[ 4 integerp ]		;bytes left on server
		[ 4 length-2 ]		;length of value in format units
		[ 12 nil ]		;unused
		[ (if (= length-1 0)
		      0
		    (if (memq required-type (list XA-atom XA-window XA-rectangle))
			;; known type
			(* length-2 (/ length-1 8))
		      length-2))

		  (cond ((or (= length-1 8) (eq required-type XA-string)) 'stringp)
			((eq required-type XA-atom) :X-Atom)
			((eq required-type XA-window) :X-Win)
			((eq required-type XA-rectangle) :X-Rect)
			(t '([(/ length-1 8) integerp])))]
		[ (X-pad (* length-2 (/ length-1 8))) nil ]
		)))
	(r nil)
	(proplist nil))

    (setq r (X-Dpy-send-read xdpy (X-Create-message ListOfFields) ReceiveFields))
    (if (null (car r))
	nil				;oops

      (setq proplist (list (nth 2 r) (nth 1 r))) ; start backwards
      (if (listp (nth 3 r))
	  (setq r (nth 3 r))
	(setq r (nthcdr 3 r)))

      (if (stringp r)
	  (setq proplist (cons r proplist))

	(while r
	  (let ((item (car r)))
	    (when (listp item)
	      (setq item (car item)))
	      
	  (setq proplist (cons item proplist)
		r (cdr r)))))
      (nreverse proplist))))

;; A few functions based on GetProperty
(defun XGetWMHints (xdpy win)
  "On display XDPY, get window's WIN WM_HINTS."
  (let ((wmh (XGetWindowProperty xdpy win XA-wm-hints 0 1024 nil XA-wm-hints)))
    (when (and wmh (= (car wmh) (X-Atom-id XA-wm-hints)))
      (setq wmh (cddr wmh))           ; strip REQ-TYPE and BYTES-AFTER
      (make-X-WMHints :flags (Xtruncate (nth 0 wmh))
		      :input (Xtruncate (nth 1 wmh))
		      :initial-state (Xtruncate (nth 2 wmh))
		      :icon-pixmap (nth 3 wmh)
		      :icon-window (nth 4 wmh)
		      :icon-x (Xtruncate (nth 5 wmh))
		      :icon-y (Xtruncate (nth 6 wmh))
		      :icon-mask (nth 7 wmh)
		      :window-group (nth 8 wmh)))))

(defun XGetWMNormalHints (xdpy win)
  "On display XDPY, get normal hints for WIN."
  (let ((wmnh (XGetWindowProperty xdpy win XA-wm-normal-hints 0 40 nil XA-wm-size-hints)))
    (when (and wmnh (= (car wmnh) (X-Atom-id XA-wm-size-hints)))
      (setq wmnh (cddr wmnh))           ; strip REQ-TYPE and BYTES-AFTER
      (make-X-WMSize :flags (Xtruncate (nth 0 wmnh))
		     :x (Xtruncate (nth 1 wmnh))
		     :y (Xtruncate (nth 2 wmnh))
		     :width (Xtruncate (nth 3 wmnh))
		     :height (Xtruncate (nth 4 wmnh))
		     :min-width (Xtruncate (nth 5 wmnh))
		     :min-height (Xtruncate (nth 6 wmnh))
		     :max-width (Xtruncate (nth 7 wmnh))
		     :max-height (Xtruncate (nth 8 wmnh))
		     :width-inc (Xtruncate (nth 9 wmnh))
		     :height-inc (Xtruncate (nth 10 wmnh))
		     :min-aspect-x (Xtruncate (nth 11 wmnh))
		     :min-aspect-y (Xtruncate (nth 12 wmnh))
		     :max-aspect-x (Xtruncate (nth 13 wmnh))
		     :max-aspect-y (Xtruncate (nth 14 wmnh))
		     :base-width (Xtruncate (nth 15 wmnh))
		     :base-height (Xtruncate (nth 16 wmnh))
		     :gravity (Xtruncate (nth 17 wmnh))))))

(defun XDecodeCompoundText (text)
  "Decode compound TEXT, to native string.
Evil hack, invent something better."
  (if (string-match "\x1b\x25\x2f\x31\\(.\\)\\(.\\)\\(.*?\\)\x02" text)
      (let ((len (+ (* (- (char-to-int (string-to-char (match-string 1 text))) 128) 128)
                    (- (char-to-int (string-to-char (match-string 2 text))) 128))))
        (let ((seq-beg (match-beginning 0))
              (data-beg (match-end 0))
              (data-end (+ len (match-beginning 3)))
              (cs (intern (match-string 3 text))))
          (concat (substring text 0 seq-beg)
                  (if (fboundp 'decode-coding-string)
                      (decode-coding-string (substring text data-beg data-end) cs)
                    (substring text data-beg data-end))
                  (XDecodeCompoundText (substring text data-end)))))
    text))

(defun XGetPropertyString (xdpy win atom)
  "On display XDPY, and window XWIN, get string property of type ATOM."
  (let ((propdata (XGetWindowProperty xdpy win atom 0 1024))
        (tdata nil)
	(retstring ""))
    (when (and propdata (setq tdata (nth 2 propdata)))
      (setq retstring tdata)
      (when (= (car propdata)
               (X-Atom-id (XInternAtom xdpy "COMPOUND_TEXT")))
        ;; Adjust RETSTRING in case of COMPOUND_TEXT
        (setq retstring (XDecodeCompoundText retstring)))

      (when (> (nth 1 propdata) 0.0)
        (setq propdata
              (XGetWindowProperty xdpy win atom
                                  1024 (nth 0 propdata)))
        (when (and propdata (setq tdata (nth 2 propdata)))
          (if (= (car propdata)
                 (X-Atom-id (XInternAtom xdpy "COMPOUND_TEXT")))
              (setq retstring
                    (concat retstring (XDecodeCompoundText tdata)))
            (setq retstring (concat retstring tdata))))))
    retstring))

(defun XGetWMName (xdpy win)
  "On display XDPY, get window's WIN name."
  (XGetPropertyString xdpy win XA-wm-name))

(defun XGetWMCommand (xdpy win)
  "On display XDPY, get window's WIN WM_COMMAND."
  (let ((wmcmd (XGetPropertyString xdpy win XA-wm-command)))
    (if (> (length wmcmd) 0)
        (replace-in-string (substring wmcmd 0 (1- (length wmcmd))) (string 0) " ")
      wmcmd)))

(defun XGetWMClass (xdpy win)
  "On display XDPY, get window's WIN WM_CLASS."
  (let ((wmclass (XGetPropertyString xdpy win XA-wm-class)))
    (when wmclass
      (split-string wmclass (string 0)))))

(defun XGetWMRole (xdpy win)
  "On display XDPY return WM_WINDOW_ROLE property for XWIN."
  (XGetPropertyString xdpy win (XInternAtom xdpy "WM_WINDOW_ROLE" nil)))

(defun XGetWMClientLeader (xdpy win)
  "Get window property for WM_CLIENT_LEADER atom."
  nil)

(defun XGetWMTransientFor (xdpy win)
  "Get WM_TRANSIENT_FOR property.
Returns list in form `(seq val window-for-wich-win-is-trasient)'."
  (let ((awid (XGetWindowProperty xdpy win XA-wm-transient-for 0 1 nil XA-window)))
    (when (and awid (= (car awid) (X-Atom-id XA-window)))
      (nth 2 awid))))

(defun XGetWMState (xdpy win)
  "On display XDPY get WM_STATE property for WIN."
  (let ((wmsa (XInternAtom xdpy "WM_STATE" nil)))
    (nth 2 (XGetWindowProperty xdpy win wmsa 0 2 wmsa))))

(defun XGetWMProtocols (xdpy win)
  "On display XDPY get WM_PROTOCOLS property for WIN."
  (cddr (XGetWindowProperty xdpy win  (XInternAtom xdpy "WM_PROTOCOLS" nil) 0 1024 nil XA-atom)))

(defun XWMProtocol-set-p (xdpy wmprotos name)
  "Return non-nil when atom with NAME is in WM_PROTOCOLS WMPROTO."
  (member* (XInternAtom xdpy name t) wmprotos :test 'X-Atom-equal))

;;; Colormaps
(defun XCreateColormap (xdpy win &optional v alloc)
  ;; checkdoc-params: (v alloc)
  "Create a colormap. Default values are:

VISUALID  - ID or CopyFromParent
ALLOCATE  - All are writable (1) (0 -> none writable)

args (XDPY WIN &optional VISUALID ALLOCATE)"
  (X-Dpy-p xdpy 'XCreateColormap)
  (X-Win-p win 'XCreateColormap)

  (let* ((ncmap (make-X-Colormap :dpy xdpy :id (X-Dpy-get-id xdpy)))
	 (ListOfFields
	  (list [1 78]			; opcode
		[1 (or alloc X-AllocAll)] ; alloc type
		[2 4]			; length
		[4 (X-Colormap-id ncmap)] ; id to use
		[4 (X-Win-id win)]	; window id
		[4 (X-Visual-id (or v (XDefaultVisual xdpy)))]))
	 (msg (X-Create-message ListOfFields)))
    (X-Dpy-send xdpy msg)
    ncmap))

(defun XFreeColormap (xdpy cmap)
  "Frees a colormap CMAP.
args (XDPY CMAP)"
  (X-Dpy-p xdpy 'XFreeColormap)
  (X-Colormap-p cmap 'XFreeColormap)

  (let* ((ListOfFields
	  (list [1 79]			; opcode
		[1 nil]
		[2 2]			; length
		[4 (X-Colormap-id cmap)])) ; id to use
	 (msg (X-Create-message ListOfFields)))
    (X-Dpy-send xdpy msg)

    ;; Invalidate cmap structure so noone will longer use
    (X-invalidate-cl-struct cmap)))

(defun XInstallColormap (xdpy cmap)
  "Install colormap on xdpy."
  (X-Dpy-p xdpy 'XInstallColormap)
  (X-Colormap-p cmap 'XInstallColormap)

  (let* ((ListOfFields
	  (list [1 81]			; opcode
		[1 nil]
		[2 2]			; length
		[4 (X-Colormap-id cmap)])) ; id to use
	 (msg (X-Create-message ListOfFields)))
    (X-Dpy-send xdpy msg)))

(defun XUninstallColormap (xdpy cmap)
  "Uninstall colormap on xdpy."
  (X-Dpy-p xdpy 'XUninstallColormap)
  (X-Colormap-p cmap 'XUninstallColormap)

  (let* ((ListOfFields
	  (list [1 82]			; opcode
		[1 nil]
		[2 2]			; length
		[4 (X-Colormap-id cmap)])) ; id to use
	 (msg (X-Create-message ListOfFields)))
    (X-Dpy-send xdpy msg)))

(defun XListInstalledColormaps (xdpy xwin)
  "Return list of color maps installed on XWIN."
  (X-Dpy-p xdpy 'XListInstalledColormaps)
  (X-Win-p xwin 'XListInstalledColormaps)

  (let ((ListOfFields
         (list [1 83]			; opcode
               [1 nil]
               [2 2]			; length
               [4 (X-Win-id xwin)]))    ; x window
        (ReceiveFields
         (list [1 success]		; status message
               nil			; generic bad response
               (list [1 nil]            ; unused
                     [2 integerp]	; sequence
                     [4 length-1]       ; reply length
                     [2 length-2]	; number of Colormaps
                     [22 nil]           ; unused
                     [(* 4 length-2) integerp])))) ; cmaps
    (X-Dpy-send-read xdpy (X-Create-message ListOfFields) ReceiveFields)))
  
(defun XAllocColor (xdpy cmap color)
  "On display XDPY allocate in CMAP the color struct COLOR.
Use `X-Color' to create.
Returns non-nil if successful."
  (X-Dpy-p xdpy 'XAllocColor)
  (X-Colormap-p cmap 'XAllocColor)
  (X-Color-p color 'XAllocColor)

  (let ((col (X-Colormap-lookup-by-rgb cmap color)))
    (if (X-Color-p col)
	col

      (let* ((ListOfFields
	      (list [1 84]		; opcode
		    [1 nil]		; unused
		    [2 4]		; request length
		    [4 (X-Colormap-id cmap)] ; colormap handle
		    [2 (X-Color-red color)] ; red
		    [2 (X-Color-green color)] ; green
		    [2 (X-Color-blue color)] ; blue
		    [2 nil]))		; padding
	     (msg (X-Create-message ListOfFields))
	     (ReceiveFields
	      (list [1 success]		; status message
		    nil			; generic bad response
		    (list [1 nil]	; unused
			  [2 integerp]	; sequence
			  [4 nil]	; reply length
			  [2 integerp]	; red
			  [2 integerp]	; green
			  [2 integerp]	; blue
			  [2 nil]	; unused
			  [4 integerp]	; pixel value
			  [12 nil])))	; padding
	     r)
	(setq r (X-Dpy-send-read xdpy msg ReceiveFields))

	(if (car r)
	    (progn
	      (setf (X-Color-id color) (nth 5 r))
	      (setf (X-Color-red color) (nth 2 r))
	      (setf (X-Color-green color) (nth 3 r))
	      (setf (X-Color-blue color) (nth 4 r))
	      (setf (X-Color-cmap color) cmap)
	  
	      (pushnew color (X-Colormap-colors cmap)) ; cache color
	      color)
	  nil)))))

(defun XAllocNamedColor (xdpy cmap name &optional color-exact)
  "Allocate a color based on the color struct COLOR-VISUAL and COLOR-EXACT.
If COLOR-EXACT is nil or absent, ignore.
args (DISPLAY CMAP NAME COLOR-VISUAL &optional COLOR-EXACT)"
  ;; checkdoc-order: nil
  (X-Dpy-p xdpy 'XAllocNamedColor)
  (X-Colormap-p cmap 'XAllocNamedColor)

  (when color-exact
    (X-Color-p color-exact 'XAllocNamedColor))

  (let ((col (X-Colormap-lookup-by-name cmap name)))
    (if (X-Color-p col)
        col

      (let* ((ListOfFields
              (list [1 85]              ;opcode
                    [1 nil]
                    [2 (+ 3 (X-padlen name))] ;length
                    [4 (X-Colormap-id cmap)] ;colormap
                    [2 (length name)]	;length of name
                    [2 nil]             ;unused
                    [(length name) name] ;the name
                    ));; autopadded
             (msg (X-Create-message ListOfFields))
             (ReceiveFields
              (list [1 success]		;success field
                    nil
                    (list [1 nil]       ;unused
                          [2 integerp]	;sequence
                          [4 nil]       ;length
                          [4 integerp]	;pixel id
                          [2 integerp]	;exact red
                          [2 integerp]	;exact green
                          [2 integerp]	;exact blue
                          [2 integerp]	;visual red
                          [2 integerp]	;visual green
                          [2 integerp]	;visual blue
                          [8 nil])))	;padding
             r)
        (setq r (X-Dpy-send-read xdpy msg ReceiveFields))
    
        (if (car r)
            (progn
              (setq col (make-X-Color :dpy xdpy
                                      :id (nth 2 r)
                                      :red (nth 6 r)
                                      :green (nth 7 r)
                                      :blue (nth 8 r)
                                      :name name
                                      :cmap cmap))

              (when color-exact
                (setf (X-Color-id color-exact) (nth 2 r))
                (setf (X-Color-red color-exact) (nth 3 r))
                (setf (X-Color-green color-exact) (nth 4 r))
                (setf (X-Color-blue color-exact) (nth 5 r))
                (setf (X-Color-cmap color-exact) cmap))

              (pushnew col (X-Colormap-colors cmap))
              col)
          nil))
      )))

(defun XAllocColorCells (xdpy cmap ncolors nplanes &optional contiguous)
  "On display XDPY allocate NCOLORS in colormap CMAP."
  (X-Dpy-p xdpy 'XAllocColorCells)
  (X-Colormap-p cmap 'XAllocColorCells)
  
  (let* ((ListOfFields
	  (list [1 86]                  ; opcode
		[1 contiguous]
		[2 3]			; length
		[4 (X-Colormap-id cmap)]
		[2 ncolors]
		[2 nplanes]))
	 (msg (X-Create-message ListOfFields))
	 (ReceiveFields
	  (list [1 success]
		nil
		(list [1 nil]
		      [2 integerp]	;sequence
		      [4 integerp]	; length
		      [2 length-1]	; number of pixels
		      [2 length-2]	; number of masks
		      [20 nil]
		      [length-1 ([4 integerp])]
		      [length-2 ([4 integerp])]))))
    (X-Dpy-send-read xdpy msg ReceiveFields)))

(defun XStoreColors (xdpy cmap colors)
  "On display XDPY in CMAP, store COLORS. (A list of 'X-Color)
These colors are X-Color lists containing the PIXEL, RGB values and
FLAGs (which indicates what part of the RGB value is stored into
PIXEL's slot."
  (X-Dpy-p xdpy 'XStoreColors)
  (X-Colormap-p cmap 'XStoreColors)

  (let* ((ListOfFields
	  (list [1 89]			;opcode
		[1 nil]			;unused
		[2 (+ 2 (* 3 (length colors)))] ;request length
		[4 (X-Colormap-id cmap)] ;COLORMAP
		))
	 (msg (X-Create-message ListOfFields)))
    (while colors
      (setq msg (concat msg (X-Color-message (car colors)))
	    colors (cdr colors)))
    (X-Dpy-send xdpy msg)))

(defun XStoreColor (xdpy cmap color &optional R G B)
  "On display XDPY in CMAP, store COLORS.
These colors are X-Color lists containing the PIXEL, RGB values and
FLAGs (which indicates what part of the RGB value is stored into
PIXEL's slot.
  Optionally, COLOR can be a float, and it's new value indicated by
the values of RGB, or X-Color and it will be stored as is."
  (XStoreColors
   xdpy cmap
   (if (X-Color-p color)
       (list color)
     (make-X-Color :id color
		   :red R
		   :green G
		   :blue B
		   :flags (Xmask-or (if R X-DoRed 0)
				    (if G X-DoGreen 0)
				    (if B X-DoBlue 0))))))

(defun XFreeColors (xdpy cmap colors planes)
  "On display XDPY in CMAP, free COLORS from the server.
The colors are deallocated on PLANES, which is a mask.  Use 0 for
PLANES if you don't know what it's for."
  (X-Dpy-p xdpy 'XFreeColors)
  (X-Colormap-p cmap 'XFreeColors)

  (when (not (listp colors))
    (signal 'wrong-type-argument (list 'signal 'listp colors)))
  (mapc 'X-Colormap-p colors)

  (let* ((ListOfFields
	  (list [1 88]			;opcode
		[1 nil]
		[2 (+ 3 (length colors))];length
		[4 (X-Colormap-id cmap)] ;Colormap
		[4 planes]))		;plane mask
	 (msg (concat (X-Create-message ListOfFields)
		      (X-Generate-message-for-list
                       colors
                       #'(lambda (col) (int->string4 (X-Color-id col)))))))
    (X-Dpy-send xdpy msg)
 
    ;; NOTE:
    ;;  - We should'nt invalidate colors, because they may be still
    ;;    used, FreeColors actually frees colors when there no any
    ;;    references to them.
;    ;; Invalidate each color.
;    (mapc 'X-invalidate-cl-struct colors)
    ))

(defun XQueryColors (xdpy cmap color-ids)
  "On display XDPY and colormap CMAP query COLOR-IDS."
  (X-Dpy-p xdpy 'XQueryColors)
  (X-Colormap-p cmap 'XQueryColors)

  (let* ((ListOfFields
	  (list [1 91]			;opcode
		[1 nil]			;unused
		[2 (+ 2 (length color-ids))] ;request length
		[4 (X-Colormap-id cmap)] ;COLORMAP
		))
	 (msg (concat (X-Create-message ListOfFields)
		      (X-Generate-message-for-list
                       color-ids
                       #'(lambda (colid) (int->string4 colid)))))
	 (ReceiveFields
	  (list [1 success]
		nil
		(list [1 nil]
		      [2 integerp]	;sequence
		      [4 integerp]	;reply length
		      [2 length-2]	;number of rgbs
		      [22 nil]
		      [length-2
		       ([2 integerp]	; red
			[2 integerp]	; green
			[2 integerp]	; blue
			[2 nil])]
		      ))))
    (X-Dpy-send-read xdpy msg ReceiveFields)))

;;; Graphical context operations
;;
(defun XCreateGC (xdpy d gc)
  "Allocate a graphic context display XDPY on the drawable D.
Base this new context on GC." 
  (X-Dpy-p xdpy 'XCreateGC)
  (X-Drawable-p d 'XCreateGC)
  (X-Gc-p gc 'XCreateGC)

  (let* ((attrmsg (X-Gc-message gc))
	 (ListOfFields 
	  (list [1 55]			;opcode
		[1 nil]			;unused
		;; 4 fields, but 1 is in attrmsg, making 3
		[2 (+ 3 (/ (length attrmsg) 4))] ;request length
		[4 (X-Gc-id gc)]	;GC id
		[4 (X-Drawable-id d)]	;drawable id
		))
	 (msg (concat (X-Create-message ListOfFields) attrmsg)))
    (X-Dpy-send xdpy msg)

    ;; Seems lame, but return the GC we were passed originally.
    gc))

(defun XChangeGC (xdpy gc)
  "On display XDPY change GC to have new VALUES.
I.e. update GC's info on server."
  (X-Dpy-p xdpy 'XChangeGC)
  (X-Gc-p gc 'XChangeGC)

  (let* ((attrmsg (X-Gc-message gc))
	 (ListOfFields 
	  (list [1 56]			;opcode
		[1 nil]			;unused
		[2 (+ 2 (/ (length attrmsg) 4))] ;request length
		[4 (X-Gc-id gc)]	;the GC
		))
	 (msg (concat (X-Create-message ListOfFields) attrmsg)))
    (X-Dpy-send xdpy msg)
    ))

(defun XSetDashes (xdpy gc dash-offset dashes)
  "On display XDPY for GC set DASH-OFFSET and DASHES for dashed line styles."
  (X-Dpy-p xdpy 'XSetDashes)
  (X-Gc-p gc 'XSetDashes)

  (let* ((dstr (apply 'concat (mapcar 'int->string1 dashes)))
	 (ListOfFields 
	  (list [1 58]			;opcode
		[1 nil]			;unused
		[2 (+ 3 (X-padlen dstr))] ;request length
		[4 (X-Gc-id gc)]	;the GC
		[2 dash-offset]
		[2 (length dashes)]
		))
	 (msg (concat (X-Create-message ListOfFields) dstr)))
    (X-Dpy-send xdpy msg)
    ))

(defun XSetClipRectangles (xdpy gc clip-x-origin clip-y-origin rectangles &optional order)
  "On display XDPY for GC change clip-mask according to CLIP-X-ORIGIN,
CLIP-Y-ORIGIN and RECTANGLES.

You may specify ORDER to speed up X server, ORDER is one of
`X-UnSorted', `X-YSorted', `X-YXSorted' or `X-YXBanded'."
  (X-Dpy-p xdpy 'XSetClipRectangles)
  (X-Gc-p gc 'XSetClipRectangles)

  (unless order
    (setq order X-UnSorted))

  (let* ((rstr (X-Generate-message-for-list rectangles 'X-Rect-message))
	 (ListOfFields 
	  (list [1 59]			;opcode
		(vector 1 order)	;Ordeding to speedup X server
		[2 (+ 3 (X-padlen rstr))] ;request length
		[4 (X-Gc-id gc)]	;the GC
		[2 clip-x-origin]
		[2 clip-y-origin]
		))
	 (msg (concat (X-Create-message ListOfFields) rstr)))
    (X-Dpy-send xdpy msg)
    ))

(defun XFreeGC (xdpy gc)
  "Allocate a graphic context display XDPY on the drawable D.
Base this new context on GC." 
  (X-Dpy-p xdpy 'XFreeGC)
  (X-Gc-p gc 'XFreeGC)

  (let* ((ListOfFields 
	  (list [1 60]			;opcode
		[1 nil]
		[2 2]			;length
		[4 (X-Gc-id gc)]	;GC id
		))
	 (msg (X-Create-message ListOfFields)))
    (X-Dpy-send xdpy msg)

    ;; Invalidate gc structure.
    (X-invalidate-cl-struct gc)
    ))

(defun XClearArea (xdpy win x y width height exposures)
  "On display XDPY in WIN clear rectangle X Y WIDTH HEIGHT."
  (X-Dpy-p xdpy 'XClearArea)
  (X-Win-p win 'XClearArea)

  (let* ((ListOfFields
	  (list [1 61]			;opcode
		[1 exposures]		;exposures
		[2 4]			;length
		[4 (X-Win-id win)]	;window
		[2 x]
		[2 y]
		[2 width]
		[2 height]))
	 (msg (X-Create-message ListOfFields)))
    (X-Dpy-send xdpy msg)))

(defun XCopyArea (xdpy src-d dst-d gc src-x src-y width height dst-x dst-y)
  "On display XDPY combine specified rectangle of SCR-D with DST-D."
  (X-Dpy-p xdpy 'XCopyArea)
  (X-Drawable-p src-d 'XCopyArea)
  (X-Drawable-p src-d 'XCopyArea)

  (let* ((ListOfFields
	  (list [1 62]			;opcode
		[1 nil]
		[2 7]			;length
		[4 (X-Drawable-id src-d)] ; source drawable
		[4 (X-Drawable-id dst-d)] ; destination drawable
		[4 (X-Gc-id gc)]
		[2 src-x]
		[2 src-y]
		[2 dst-x]
		[2 dst-y]
		[2 width]
		[2 height]))
	 (msg (X-Create-message ListOfFields)))
    (X-Dpy-send xdpy msg)))

(defmacro XCopyAreaRect (xdpy src-d dst-d gc src-rect dst-x dst-y)
  "Same as `XCopyArea' but rectangle specified by SRC-RECT."
  `(XCopyArea ,xdpy ,src-d ,dst-d ,gc
              (X-Rect-x ,src-rect) (X-Rect-y ,src-rect)
              (X-Rect-width ,src-rect) (X-Rect-height ,src-rect)
              ,dst-x ,dst-y))

(defun XCopyPlane (xdpy src-d dst-d gc src-x src-y width height dst-x dst-y bit-plane)
  "On display XDPY ..."
  (X-Dpy-p xdpy 'XCopyPlane)
  (X-Drawable-p src-d 'XCopyPlane)
  (X-Drawable-p src-d 'XCopyPlane)

  (let* ((ListOfFields
	  (list [1 63]			;opcode
		[1 nil]
		[2 8]			;length
		[4 (X-Drawable-id src-d)] ; source drawable
		[4 (X-Drawable-id dst-d)] ; destination drawable
		[4 (X-Gc-id gc)]
		[2 src-x]
		[2 src-y]
		[2 dst-x]
		[2 dst-y]
		[2 width]
		[2 height]
		[4 bit-plane]))
	 (msg (X-Create-message ListOfFields)))
    (X-Dpy-send xdpy msg)))

(defmacro XCopyPlaneRect (xdpy src-d dst-d gc src-rect dst-x dst-y bit-plane)
  "Same as `XCopyPlane' but rectangle specified by SRC-RECT."
  `(XCopyPlane ,xdpy ,src-d ,dst-d ,gc
              (X-Rect-x ,src-rect) (X-Rect-y ,src-rect)
              (X-Rect-width ,src-rect) (X-Rect-height ,src-rect)
              ,dst-x ,dst-y ,bit-plane))

;;; Drawing routines
;;
(defun XDrawPoints (xdpy d gc pts &optional mode)
  "Draw points on a drawable. (XDPY D GC PTS &optional MODE)."
  (X-Dpy-p xdpy 'XDrawPoints)
  (X-Drawable-p d 'XDrawPoints)
  (X-Gc-p gc 'XDrawPoints)

  (let* ((ListOfFields
	  (list [1 64]			; opcode
		[1 (or mode X-Origin)]	; mode of drawing, shutup compiler
		[2 (+ 3 (length pts))]	; request length
		[4 (X-Drawable-id d)]	; drawable id
		[4 (X-Gc-id gc)]))	; id of the GC
	 (msg (concat (X-Create-message ListOfFields)
		      (X-Generate-message-for-list pts 'X-Point-message))))
    (X-Dpy-send xdpy msg)))

(defun XDrawPoint (xdpy d gc x y)
  "Draw a point. (XDPY D GC X Y)."
  (XDrawPoints xdpy d gc (list (cons x y)) X-Origin))

(defun XDrawLines (xdpy d gc pts &optional mode)
  "Draw a multipoint line. (XDPY D GC PTS &optional MODE)."
  (X-Dpy-p xdpy 'XDrawLines)
  (X-Drawable-p d 'XDrawLines)
  (X-Gc-p gc 'XDrawLines)

  (let* ((ListOfFields
	  (list [1 65]			; opcode
		[1 (or mode X-Origin)]	; mode of drawing, shut up compiler
		[2 (+ 3 (length pts))]	; request length
		[4 (X-Drawable-id d)]
		[4 (X-Gc-id gc)]))
	 (msg (concat (X-Create-message ListOfFields)
		      (X-Generate-message-for-list pts 'X-Point-message))))
    (X-Dpy-send xdpy msg)))

(defun XFillPoly (xdpy d gc pts &optional shape mode)
  "Fill poly."
  (X-Dpy-p xdpy 'XFillPoly)
  (X-Drawable-p d 'XFillPoly)
  (X-Gc-p gc 'XFillPoly)

  (let* ((ListOfFields
	  (list [1 69]			; opcode
		[1 nil]                 ; unused
		[2 (+ 4 (length pts))]	; request length
		[4 (X-Drawable-id d)]
		[4 (X-Gc-id gc)]
                [1 (or shape X-Nonconvex)]
                [1 (or mode X-Origin)]
                [2 nil]))               ; pad
	 (msg (concat (X-Create-message ListOfFields)
		      (X-Generate-message-for-list pts 'X-Point-message))))
    (X-Dpy-send xdpy msg)))
  
(defun XDrawLine (xdpy d gc x y x2 y2)
  "Draw a line on display XDPY in drawable D.
args (XDPY D GC X Y X2 Y2)."
  (XDrawLines xdpy d gc (list (cons x y) (cons x2 y2))))

(defun XDrawSegments (xdpy d gc xsegments)
  "Draw Segments. (XDPY D GC PTS &optional MODE).
Drawing segments is different from lines in that segments are disconnected
every other pair of points."
  (X-Dpy-p xdpy 'XDrawSegments)
  (X-Drawable-p d 'XDrawSegments)
  (X-Gc-p gc 'XDrawSegments)

  (let* ((ListOfFields
	  (list [1 66]			;opcode
		[1 nil]
		[2 (+ 3 (* 2 (length xsegments)))]
		[4 (X-Drawable-id d)]
		[4 (X-Gc-id gc)]))
	 (msg (concat (X-Create-message ListOfFields)
		      (X-Generate-message-for-list xsegments 'X-Segment-message))))
    (X-Dpy-send xdpy msg)))
	
(defun XDrawRectangles (xdpy d gc rectangles &optional fill)
  "Draw rectangles. (XDPY D GC RECTANGLES &optional FILL)."
  (X-Dpy-p xdpy 'XDrawRectangles)
  (X-Drawable-p d 'XDrawRectangles)
  (X-Gc-p gc 'XDrawRectangles)

  (let* ((ListOfFields
	  (list [1 (if fill 70 67)]	;opcode
		[1 nil]			;mode of drawing
		[2 (+ 3 (* (length rectangles) 2))] ; number of rects *2
		[4 (X-Drawable-id d)]	;drawable id
		[4 (X-Gc-id gc)]))	;id of the GC
	 (msg (concat (X-Create-message ListOfFields)
		      (X-Generate-message-for-list rectangles 'X-Rect-message))))
    (X-Dpy-send xdpy msg)))

(defun XDrawRectangle (xdpy d gc x y width height)
  "Draw a rectangle. (XDPY D GC X Y WIDTH HEIGHT)."
  (XDrawRectangles xdpy d gc (list (make-X-Rect :x x :y y :width width :height height))))

(defun XFillRectangle (xdpy d gc x y width height)
  "Draw a rectangle. (XDPY D GC X Y WIDTH HEIGHT)."
  (XDrawRectangles xdpy d gc (list (make-X-Rect :x x :y y :width width :height height)) t))

(defun XFillRectangles (xdpy d gc rectangles)
  "Draw rectangles. (XDPY D GC RECTANGLES)."
  (XDrawRectangles xdpy d gc rectangles t))

(defun XDrawArcs (xdpy d gc xarcs &optional fill mode)
  "Draw arcs. (XDPY D GC ARCS &optional FILL)."
  (X-Dpy-p xdpy 'XDrawArcs)
  (X-Drawable-p d 'XDrawArcs)
  (X-Gc-p gc 'XDrawArcs)

  (let* ((ListOfFields
	  (list [1 (if fill 71 68)]	;opcode
		[1 mode]                ;mode of drawing
		[2 (+ 3 (* 3 (length xarcs)))] ; number of arcs * 3
		[4 (X-Drawable-id d)]	;drawable id
		[4 (X-Gc-id gc)]))	;id of the GC
	 (msg (concat (X-Create-message ListOfFields)
		      (X-Generate-message-for-list xarcs 'X-Arc-message))))
    (X-Dpy-send xdpy msg)))

(defun XDrawArc (xdpy d gc x y width height angle1 angle2 &optional fill mode)
  "Draw an arc on display XDPY in drawable D.
args (DISPLAY D GC X Y WIDTH HEIGHT ANGLE1 ANGLE2)"
  (XDrawArcs xdpy d gc (list (make-X-Arc :x x :y y :width width :height height :angle1 angle1 :angle2 angle2)) fill))

(defun XFillArc (xdpy d gc x y width height angle1 angle2 &optional mode)
  "Draw a filled arc on display XDPY in drawable D.
args (DISPLAY D GC X Y WIDTH HEIGHT ANGLE1 ANGLE2)"
  (XDrawArcs xdpy d gc (list (make-X-Arc :x x :y y :width width :height height :angle1 angle1 :angle2 angle2)) t mode))

(defun XFillArcs (xdpy d gc arcs &optional mode)
  "Draw filled arcs. (XDPY D GC ARCS)."
  (XDrawArcs xdpy d gc arcs t mode))

(defun XDrawString (xdpy d gc x y str &optional len)
  "Draw a string at specified point. (XDPY D GC X Y STR &optional LEN)."
  (X-Dpy-p xdpy 'XDrawString)
  (X-Drawable-p d 'XDrawString)
  (X-Gc-p gc 'XDrawString)

  ;; Check len, must be < 255
  (when (or (and len (>= len 255))
	    (>= (length str) 255))
    (setq str (substring str 0 254)))

  (let* ((slen (if len len (length str))) ;make len optional
	 (ListOfFields
	  (list [1 74]			;opcode
		[1 nil]			;unused
		[2 (+ 4 (X-padlen (concat "12" str)))] ;length
		[4 (X-Drawable-id d)]	;drawable id
		[4 (X-Gc-id gc)]	;gc id
		[2 x]
		[2 y]
		(vector 1 slen)		;text length, shutup compiler
		[1 0]			;delta????????
		[slen str]		;the string
		))
		;; auto-padding in X-create
	 (msg (X-Create-message ListOfFields)))
    (X-Dpy-send xdpy msg)))

(defun XImageString (xdpy d gc x y str &optional len)
  "Draw a string using ImageText8 request.
XDPY, D, GC, X, Y, STR and LEN are the same as in `XDrawString'."
  (X-Dpy-p xdpy 'XImageString)
  (X-Drawable-p d 'XImageString)
  (X-Gc-p gc 'XImageString)

  (let* ((slen (if len len (length str))) ; make len optional
	 (ListOfFields
	  (list [1 76]			; opcode
		(vector 1 slen)         ; string length, shutup compiler
		[2 (+ 4 (/ (+ (X-pad slen) slen) 4))] ;length
		[4 (X-Drawable-id d)]	;drawable id
		[4 (X-Gc-id gc)]	;gc id
		[2 x]
		[2 y]
                [slen str]
		))
          ;; auto-padding in X-create
	 (msg (X-Create-message ListOfFields)))
    (X-Dpy-send xdpy msg)))
  
(defun XDrawText8 ()
  )

(defun XDrawText16 ()
  )

(defun XPutImage (xdpy d gc depth width height dst-x dst-y left-pad format data)
  "On display XDPY and drawable D, put an image."
  (X-Dpy-p xdpy 'XPutImage)
  (X-Drawable-p d 'XPutImage)
  (X-Gc-p gc 'XPutImage)

  (let* ((ListOfFields
	  (list [1 72]                  ; opcode
		[1 format]
		[2 (+ 6 (X-padlen data))]
		[4 (X-Drawable-id d)]
		[4 (X-Gc-id gc)]
		[2 width]
		[2 height]
		[2 dst-x]
		[2 dst-y]
		[1 left-pad]
		[1 depth]
		[2 nil]
		[(length data) data]
		[(X-pad (length data)) nil]))
	 (msg (X-Create-message ListOfFields)))
    (X-Dpy-send xdpy msg)))

(defun XGetImage (xdpy d x y width height plane-mask format)
  "On display XDPY and drawable D, get image with geometry WIDTHxHEIGHT+X+Y in FORMAT.
PLANE-MASK is one of `X-AllPlanes' or something elese."
  (X-Dpy-p xdpy 'XGetImage)
  (X-Drawable-p d 'XGetImage)

  (let* ((ListOfFields
	  (list [1 73]			; opcode
		[1 format]		; format
		[2 5]			; len
		[4 (X-Drawable-id d)]	; drawable
		[2 x]
		[2 y]
		[2 width]
		[2 height]
		[4 plane-mask]))
	 (msg (X-Create-message ListOfFields))
	 (ReceiveFields
	  (list [1 success]
		nil
		(list [1 integerp]	; depth
		      [2 integerp]	; sequence
		      [4 length-1]	; length
		      [4 integerp]	; visual id or X-None
		      [20 nil]		; not used
		      [(* length-1 4) stringp]))))	;data
    (X-Dpy-send-read xdpy msg ReceiveFields)))
;		      [(X-mod-4 length-1) nil])))) ; padding

;;; Selections operations
(defun XSetSelectionOwner (xdpy selection-atom &optional owner-win time)
  "Set SELECTION-ATOM to be owned by OWNER-WIN."
  (X-Dpy-p xdpy 'XSetSelectionOwner)

  (let* ((ListOfFields
	  (list [1 22]			;opcode
		[1 nil]			;unused
		[2 4]			;length
		[4 (if owner-win (X-Win-id owner-win) X-None)] ;owner window
		[4 (X-Atom-id selection-atom)] ; selection atom
		[4 (if time time X-CurrentTime)]))
	 (msg (X-Create-message ListOfFields)))
    (X-Dpy-send xdpy msg)))

(defun XGetSelectionOwner (xdpy selection-atom)
  "Get owner of SELECTION-ATOM on display XDPY.
Returns nil or X-Win structure."
  (X-Dpy-p xdpy 'XGetSelectionOwner)

  (let* ((ListOfFields
          (list [1 23]			;opcode
                [1 nil]                 ;unused
                [2 2]			;length
                [4 (X-Atom-id selection-atom)])) ;selection atom
         (msg (X-Create-message ListOfFields))
         (ReceiveFields
          (list [1 success]		;success field
                nil
                (list [1 nil]		;unused
                      [2 integerp]	;sequence
                      [4 nil]		;length
                      [4 integerp]	;owner window
                      [20 nil])))	;pad
         r win)
    (setq r (X-Dpy-send-read xdpy msg ReceiveFields))
    (when (car r)
      (setq win (X-Win-find-or-make xdpy (nth 2 r))))
    win))

(defun XConvertSelection (xdpy selection target prop requestor &optional time)
  "ConvertSelection."
  (X-Dpy-p xdpy 'XConvertSelection)

  (let* ((ListOfFields
	  (list [1 24]			;opcode
		[1 nil]			;unused
		[2 6]			;length
		[4 (if requestor (X-Win-id requestor) X-None)] ;owner window
		[4 (X-Atom-id selection)] ; selection atom
		[4 (X-Atom-id target)]  ; target atom
		[4 (if prop (X-Atom-id prop) X-None)] ; property atom
		[4 (or time X-CurrentTime)]))
	 (msg (X-Create-message ListOfFields)))
    (X-Dpy-send xdpy msg)))

;;; Warping
(defun XWarpPointer (xdpy src-win dst-win src-x src-y src-width src-height dest-x dest-y)
  "On display XDPY warp pointer to DEST-X DEST-Y"
  (X-Dpy-p xdpy 'XWarpPointer)
;  (X-Win-p src-win 'XWarpPointer)
;  (X-Win-p dst-win 'XWarpPointer)

  (let* ((srcid (or (and (X-Win-p src-win) (X-Win-id src-win)) src-win))
	 (dstid (or (and (X-Win-p dst-win) (X-Win-id dst-win)) dst-win))
	 (ListOfFields
	  (list [1 41]			; opcode
		[1 nil]			; unused
		[2 6]			; length
		(vector 4 srcid)	; source window
		(vector 4 dstid)	; dst window
		[2 src-x]		;
		[2 src-y]		;
		[2 src-width]
		[2 src-height]
		[2 dest-x]
		[2 dest-y]))
	 (msg (X-Create-message ListOfFields)))
    (X-Dpy-send xdpy msg)))

;;; Grabbing
(defun XGrabServer (xdpy)
  "Grabs X server on display XDPY"
  (X-Dpy-p xdpy 'XGrabServer)

  (let* ((ListOfFields
	  (list [1 36]			;opcode
		[1 nil]			;unused
		[2 1]))			;length
	 (msg (X-Create-message ListOfFields)))
    (X-Dpy-send xdpy msg)))

(defun XUngrabServer (xdpy)
  "Ungrab X server on display XDPY."
  (X-Dpy-p xdpy 'XUngrabServer)

  (let* ((ListOfFields
	  (list [1 37]			;opcode
		[1 nil]			;unused
		[2 1]))			;length
	 (msg (X-Create-message ListOfFields)))
    (X-Dpy-send xdpy msg)))

(defun XQueryPointer (xdpy xwin)
  "In display XDPY and window XWIN query pointer position."
  (X-Dpy-p xdpy 'XQueryPointer)

  (let* ((ListOfFields
          (list [1 38]                  ; opcode
                [1 nil]                 ; unused
                [2 2]                   ; length
                [4 (X-Win-id xwin)]))
         (msg (X-Create-message ListOfFields))
	 (ReceiveFields
	  (list [1 success]		;success field
		nil
		(list [1 integerp]	; same-screen
		      [2 integerp]	; sequence
		      [4 nil]           ; length
                      [4 :X-Win]        ; root
                      [4 :X-Win]        ; child
                      [2 integerp]      ; root-x
                      [2 integerp]      ; root-y
                      [2 integerp]      ; win-x
                      [2 integerp]      ; win-y
                      [2 integerp]      ; mask
                      [6 nil]))))
    (X-Dpy-send-read xdpy msg ReceiveFields)))

(defun XGrabKeyboard (xdpy grab-win &optional owe pmode kmode time)
  "On display XDPY in window GRAB-WIN start grabbing keyboard.
OWE - owner events (default `nil')
PMODE - Pointer grabbing mode (default `X-GrabModeAsync')
KMODE - Keyboard grabbing mode (default `X-GrabModeAsync')
TIME - Time when start to grab (default `X-CurrentTime')"
  (X-Dpy-p xdpy 'XGrabKeyboard)
  (X-Win-p grab-win 'XGrabKeyboard)

  (let* ((ListOfFields
	  (list [1 31]			; opcode
		[1 owe]			; owner_events
		[2 4]			; length
		[4 (X-Win-id grab-win)] ; grab window
		[4 (or time X-CurrentTime)] ; time
		[1 (or pmode X-GrabModeAsync)] ; pointer mode
		[1 (or kmode X-GrabModeAsync)] ; keyboard mode
		[2 nil]))		; pad
	 (msg (X-Create-message ListOfFields))
	 (ReceiveFields
	  (list [1 success]		;success field
		nil
		(list [1 integerp]	;status
		      [2 integerp]	;sequence
		      [4 integerp]	;length . Hmm length-1
		      [24 nil]))))	;pad
;		      [length-1
;		       ([4 nil]) ]))))	;pad
    (X-Dpy-send-read xdpy msg ReceiveFields)))

(defun XUngrabKeyboard (xdpy &optional time)
  "On display XDPY at TIME stop grabbing keyboard.
Default TIME is `X-CurrentTime'."
  (X-Dpy-p xdpy 'XUngrabKeyboard)

  (let* ((ListOfFields
	  (list [1 32]			; opcode
		[1 nil]			; owner_events
		[2 2]			;length
		[4 (if time time X-CurrentTime)]))
	 (msg (X-Create-message ListOfFields)))
    (X-Dpy-send xdpy msg)))

(defun XGrabPointer (xdpy grab-win ev-mask &optional cursor owe pmode kmode confto-win time)
  "On display XDPY in window GRAB-WIN start grabbing pointer.
CURSOR - Cursor to use while grabbing.
EV-MASK - Mask for events to receive. Result of `Xmask-or'.
OWE - owner events (default `nil')
PMODE - Pointer grabbing mode (default `X-GrabModeAsync')
KMODE - Keyboard grabbing mode (default `X-GrabModeAsync')
CONFTO-WIN - Confine to window (default `nil'
TIME - Time when start to grab (default `X-CurrentTime')"
  (X-Dpy-p xdpy 'XGrabPointer)
  (X-Win-p grab-win 'XGrabPointer)

  (let* ((ListOfFields
	  (list [1 26]			;opcode
		[1 owe]
		[2 6]
		[4 (X-Win-id grab-win)] ;grab window
		[2 ev-mask]		;event mask
		[1 (or pmode X-GrabModeAsync)] ;pointerMode
		[1 (or kmode X-GrabModeAsync)] ;keyboardMode
		[4 (if confto-win (X-Win-id confto-win) 0.0)] ;confineTo window
		[4 (if cursor (X-Cursor-id cursor) 0.0)] ;Cursor
		[4 (or time X-CurrentTime)]))
	 (msg (X-Create-message ListOfFields))
	 (ReceiveFields 
	  (list [1 success]
		nil
		(list [1 nil]		;unsed
		      [2 integerp]	;sequence
		      [28 nil]))))	;padding
    (X-Dpy-send-read xdpy msg ReceiveFields)))

(defun XUngrabPointer (xdpy &optional time)
  "On display XDPY at TIME, stop grabbing pointer."
  (X-Dpy-p xdpy 'XUngrabPointer)

  (let* ((ListOfFields
	  (list [1 27]			;opcode
		[1 nil]
		[2 2]
		[4 (or time X-CurrentTime)]))
	 (msg (X-Create-message ListOfFields)))
    (X-Dpy-send xdpy msg)))

(defun XGrabButton (xdpy button mods grab-win ev-mask &optional cursor owe pmode kmode conf-to)
  "On display XDPY in window GRAB-WIN, start grabbing for BUTTON with MODS.
TODO: Describe optional arguments."
  (X-Dpy-p xdpy 'XGrabButton)
  (X-Win-p grab-win 'XGrabButton)

  (let* ((ListOfFields
	  (list [1 28]                  ; opcode
		[1 (if owe owe nil)]
		[2 6]
		[4 (X-Win-id grab-win)]
		[2 ev-mask]
		[1 (or pmode X-GrabModeAsync)]
		[1 (or kmode X-GrabModeAsync)]
		[4 (if conf-to (X-Win-id conf-to) 0.0)]
		[4 (if cursor (X-Cursor-id cursor) 0.0)]
		[1 button]
		[1 nil]			; pad
		[2 mods]))
	 (msg (X-Create-message ListOfFields)))
    (X-Dpy-send xdpy msg)))

(defun XUngrabButton (xdpy button mods grab-win)
  "On display XDPY in window GRAB-WIN stop grabbing for BUTTON with MODS."
  (X-Dpy-p xdpy 'XUngrabButton)
  (X-Win-p grab-win 'XUngrabButton)

  (let* ((ListOfFields
	  (list [1 29]			; opcode
		[1 button]
		[2 3]			; length
		[4 (X-Win-id grab-win)]
		[2 mods]
		[2 nil]))		; pad
	 (msg (X-Create-message ListOfFields)))
    (X-Dpy-send xdpy msg)))
		
(defun XGrabKey (xdpy keycode mods grab-win &optional owe pmode kmode)
  "On display XDPY in window GRAB-WIN start grabbing for KEYCODE with MODS.
TODO: Description for OWE, PMODE and KMODE."
  (X-Dpy-p xdpy 'XGrabKey)
  (X-Win-p grab-win 'XGrabKey)

  (let ((ListOfFields `([1 33]          ; opcode
                        [1 ,owe]       ; owner_events
                        [2 4]          ; length
                        [4 ,(X-Win-id grab-win)] ; grab window
                        [2 ,mods]      ; modifiers
                        [1 ,keycode]   ; key
                        [1 ,(or pmode X-GrabModeAsync)] ; pointer mode
                        [1 ,(or kmode X-GrabModeAsync)] ; keyboard mode
                        [3 nil])))      ; pad
    (X-Dpy-send xdpy (X-Create-message ListOfFields))))

(defun XUngrabKey (xdpy keycode mods grab-win)
  "On display XDPY in window GRAB-WIN stop grabbing KEYCODE with MODS."
  (X-Dpy-p xdpy 'XUngrabKey)
  (X-Win-p grab-win 'XUngrabKey)

  (let* ((ListOfFields
	  (list [1 34]			; opcode
		[1 keycode]		; keycode
		[2 3]			; length
		[4 (X-Win-id grab-win)]	; grab window
		[2 mods]		; modifiers
		[2 nil]))		; pad
	 (msg (X-Create-message ListOfFields)))
    (X-Dpy-send xdpy msg)))

(defun XAllowEvents (xdpy mode &optional time)
  "On display XDPY allow events in MODE."
  (X-Dpy-p xdpy 'XAllowEvents)

  (let* ((ListOfFields
	  (list [1 35]
		[1 mode]
		[2 2]
		[4 (or time X-CurrentTime)]))
	 (msg (X-Create-message ListOfFields)))
    (X-Dpy-send xdpy msg)))
  

;;; Focusing
(defun XGetInputFocus (xdpy)
  "On display XDPY get curret input focus."
  (X-Dpy-p xdpy 'XGetInputFocus)

  (let* ((ListOfFields
	  (list [1 43]			;opcode
		[1 nil]			;unused
		[2 1]))			;length
	 (msg (X-Create-message ListOfFields))
	 (ReceiveFields
	  (list [1 success]
		nil
		(list [1 integerp]	;revertTo
		      [2 integerp]	;sequence
		      [4 nil]		;length
		      [4 integerp]	;focus win
		      [20 nil])))	;pad
	 r thing)
    (setq r (X-Dpy-send-read xdpy msg ReceiveFields))

    (when (car r)
      (if (member (nth 3 r) (list X-PointerRoot X-None))
	  (setq thing (nth 3 r))
	(setq thing (X-Win-find xdpy (nth 3 r)))))
    thing))

(defun XSetInputFocus (xdpy win-or-val rev-to &optional time)
  "On display XDPY set input focus to window WIN-OR-VAL.
REV-TO - Focus revert to when WIN-OR-VAL will lost input focus.
TIME - Set input focus at this time (default `X-CurrentTime')"
  (X-Dpy-p xdpy 'XSetInputFocus)

  (let* ((ListOfFields
	  (list [1 42]			; opcode
		[1 rev-to]		; Revert to
		[2 3]			; length
		[4 (cond ((integerp win-or-val) win-or-val) ;X-PointerRoot, X-None, etc
			 ((X-Win-p win-or-val) (X-Win-id win-or-val)) ;window
			 (t nil))]	; X-None
		[4 time]))		; time
	 (msg (X-Create-message ListOfFields)))
    (X-Dpy-send xdpy msg)))

;;; Misc requests
(defun XReparentWindow (xdpy win parwin x y)
  "On display XDPY reparent window WIN to PARWIN at X Y."
  (X-Dpy-p xdpy 'XReparentWindow)
  (X-Win-p win 'XReparentWindow)
  (X-Win-p parwin 'XReparentWindow)

  (let* ((ListOfFields
	  (list [1 7]			;opcode
		[1 nil]			;pad
		[2 4]			;length
		[4 (X-Win-id win)]	;win
		[4 (X-Win-id parwin)]	;parent window
		[2 x]			;x
		[2 y]))			;y
	 (msg (X-Create-message ListOfFields)))
    (X-Dpy-send xdpy msg)))

(defun XGetGeometry (xdpy d)
  "On display XDPY return geomtry for drawable D.
Side effect of this function is to set 'xdepth property in drawable
D."
  (X-Dpy-p xdpy 'XGetGeometry)
  (X-Drawable-p d 'XGetGeometry)

  (let* ((ListOfFields
	  (list [1 14]			;opcode
		[1 nil]			;pad
		[2 2]			;length
		[4 (X-Drawable-id d)]))	;chars in string
	 (msg (X-Create-message ListOfFields))
	 (ReceiveFields
	  (list [1 success]
		nil
		(list [1 integerp]	;depth
		      [2 integerp]	;sequence
		      [4 nil]		;length
		      [4 integerp]	;root
		      [2 integerp]	;x
		      [2 integerp]	;y
		      [2 integerp]	;width
		      [2 integerp]	;height
		      [2 integerp]	;border width
		      [10 nil])))	;pad
	 r rgeom)
    (setq r (X-Dpy-send-read xdpy msg ReceiveFields))
    (when (car r)
      (if (X-Win-p d)
          (X-Win-put-prop d 'xdepth (nth 1 r))
        (X-Pixmap-put-prop d 'xdepth (nth 1 r)))
      (setq rgeom (make-X-Geom :x (nth 4 r)
			       :y (nth 5 r)
			       :width (nth 6 r)
			       :height (nth 7 r)
			       :border-width (nth 8 r))))
    rgeom))

(defun XGetDepth (xdpy d)
  "On display xdpy return drawable's D depth."
  (or (if (X-Win-p d)
          (X-Win-get-prop d 'xdepth)
        (X-Pixmap-get-prop d 'xdepth))
      (progn
        (XGetGeometry xdpy d)
        (if (X-Win-p d)
            (X-Win-get-prop d 'xdepth)
          (X-Pixmap-get-prop d 'xdepth)))))

;; TODO: XTranslateCoordinates
(defun XTranslateCoordinates (xdpy src-win dst-win src-x src-y)
  "On display XDPY translate SCR-X SCR-y coordinates to coordinates on DST-WIN."
  (X-Dpy-p xdpy 'XTranslateCoordinates)
  (X-Win-p src-win 'XTranslateCoordinates)
  (X-Win-p dst-win 'XTranslateCoordinates)

  (let* ((ListOfFields
	  (list [1 40]			;opcode
		[1 nil]			;pad
		[2 4]			;length
		[4 (X-Win-id src-win)]	;source win
		[4 (X-Win-id dst-win)]	;destination win
		[2 src-x]
		[2 src-y]))
	 (msg (X-Create-message ListOfFields))
	 (ReceiveFields
	  (list [1 success]
		nil
		(list [1 booleanp]	;same-screen
		      [2 integerp]	;sequence
		      [4 nil]		;length
		      [4 :X-Win]	;child
		      [2 integerp]	;dst-x
		      [2 integerp]	;dst-y
		      [16 nil])))	;pad
	 r)
    (setq r (X-Dpy-send-read xdpy msg ReceiveFields))
    (if (car r)
	(cons (cons (nth 4 r) (nth 5 r)) (nth 3 r))
      nil)))

(defun XChangeSaveSet (xdpy win change-mode)
  "On display XDPY change SaveSet according to CHANGE-MODE."
  (X-Dpy-p xdpy 'XChangeSaveSet)
  (X-Win-p win 'XChangeSaveSet)

  (let* ((ListOfFields
	  (list [1 6]                   ; opcode
		[1 change-mode]
		[2 2]			;length
		[4 (X-Win-id win)]))
	 (msg (X-Create-message ListOfFields)))
    (X-Dpy-send xdpy msg)))

(defun XSendEvent (xdpy win propogate ev_mask xevent)
  "WIN is X11 window or one of X-InputFocus, X-XXXxxxXXX.
Evil hack, do not use this function."
  (X-Dpy-p xdpy 'XSendEvent)

  (let* ((ListOfFields
	  (list [1 25]                  ; opcode
		[1 propogate]
		[2 11] ;(+ 3 (X-padlen xevent))] ;length
		[4 (if (X-Win-p win) (X-Win-id win) win)]
		[4 ev_mask]))		;event mask
	 (padding (make-string (- 44 12 (length xevent)) 0))
	 (msg (concat (X-Create-message ListOfFields) xevent padding)))
    (X-Dpy-send xdpy msg)))


;;; Keyboard mapping
(defun XQueryKeymap (xdpy)
  "On display XDPY query keyboard mapping."
  (X-Dpy-p xdpy 'XQueryKeymap)

  (let* ((ListOfFields
	  (list [1 44]			;opcode
		[1 nil]			;pad
		[2 1]))			;length
	 (msg (X-Create-message ListOfFields))
	 (ReceiveFields
	  (list [1 success]
		nil
		(list [1 nil]		;unused
		      [2 integerp]	;sequence
		      [4 integerp]	;length
		      [32 nil]))))	;unknown

    (X-Dpy-send-read xdpy msg ReceiveFields)))

(defun XGetKeyboardMapping (xdpy keycode count)
  "On display XDPY get keyboard mapping."
  (X-Dpy-p xdpy 'XGetKeyboardMapping)

  (let* ((ListOfFields
	  (list [1 101]			;opcode
		[1 nil]			;pad
		[2 2]			;length
		[1 keycode]		;first_keycode
		[1 count]		;count
		[2 nil]))		;pad
	 (msg (X-Create-message ListOfFields))
	 (ReceiveFields
	  (list [1 success]
		nil
		(list [1 length-1]	;keySymsPerKeyCode
		      [2 integerp]	;sequence
		      [4 length-2]	;length
		      [24 nil]		;pad
		      [count		;list of the children
		       (make-list length-1 [4 integerp])]))))

    (X-Dpy-send-read xdpy msg ReceiveFields)))

(defun XGetModifierMapping (xdpy)
  "On display XDPY get modifiers mapping."
  (X-Dpy-p xdpy 'XGetModifierMapping)

  (let* ((ListOfFields
	  (list [1 119]			;opcode
		[1 nil]			;pad
		[2 1]))			;length
	 (msg (X-Create-message ListOfFields))
	 (ReceiveFields
	  (list [1 success]
		nil
		(list [1 length-2]	;numKeyPerModifier
		      [2 integerp]	;sequence
		      [4 length-1]	;length
		      [4 integerp]	;pad
		      [4 integerp]	;pad
		      [4 integerp]	;pad
		      [4 integerp]	;pad
		      [4 integerp]	;pad
		      [4 integerp]	;pad
		      [(/ (* length-1 4) length-2) ;list of the children
		       (make-list length-2 [1 integerp])]))))

    (X-Dpy-send-read xdpy msg ReceiveFields)))

;;; Fonts supoprt
(defun XOpenFont (xdpy font)
  "On display XDPY open FONT, created using `X-Font'."
  (X-Dpy-p xdpy 'XOpenFont)
  (X-Font-p font 'XOpenFont)
  
  (let* ((name (X-Font-name font))
	 (ListOfFields
	  (list [1 45]			; opcode
		[1 nil]			;pad
		[2 (+ 3 (X-padlen name))] ;length
		[4 (X-Font-id font)]
		[2 (length name)]
		[2 nil]))		;pad
	 (msg (concat (X-Create-message ListOfFields) name (make-string (- (* 4 (X-padlen name)) (length name)) ?\0))))
    (X-Dpy-send xdpy msg)))

(defun XQueryFont (xdpy font)
  "On display XDPY query for FONT."
  (X-Dpy-p xdpy 'XQueryFont)

  (let* ((ListOfFields
	  (list [1 47]                  ; opcode
		[1 nil]
		[2 2]			;length
		[4 (X-Font-id font)]))
	 (msg (X-Create-message ListOfFields))
	 (ReceiveFields
	  (list [1 success]		;success field
		nil
		(list [1 nil]		;unused
		      [2 integerp]	;sequence
		      [4 length-1]	;length

		      ;; xCharInfo minBounds and maxBounds
		      [2 ([2 integerp]	;leftSideBearing
			  [2 integerp]	;rightSideBearing
			  [2 integerp]	;characterWidth
			  [2 integerp]	;ascent
			  [2 integerp]	;descent
			  [2 integerp]	;attributes
			  [4 nil])]	;walign

		      [2 integerp]	;minCharOrByte2
		      [2 integerp]	;maxCharOrByte2
		      [2 integerp]	;defaultChar
		      [2 length-2]	;nFontProps
		      [1 integerp]	;drawDirection
		      [1 integerp]	;minByte1
		      [1 integerp]	;maxByte1
		      [1 booleanp]	;allCharsExist
		      [2 integerp]	;fontAscent
		      [2 integerp]	;fontDescent
		      [4 length-3]	;nCharInfos
		      
		      ;; FontProps
		      [length-2 ([4 integerp] ;atom name
				 [4 integerp])] ;value
		      
		      ;; Character info
		      [length-3 ([2 integerp] ; leftSideBearing
				 [2 integerp] ; rightSideBearing
				 [2 integerp] ; characterWidth
				 [2 integerp] ; ascent
				 [2 integerp] ; descent
				 [2 integerp])] ; attributes
		      )))
	 r)
    (setq r (X-Dpy-send-read xdpy msg ReceiveFields))

    (if (car r)
	(let ((bounds (nth 2 r))
	      (props (nth 12 r))
	      (chinfo (nth 13 r)))

	  (setf (X-Font-minb font) (vconcat (nth 0 bounds)))
	  (setf (X-Font-maxb font) (vconcat (nth 1 bounds)))
	  (setf (X-Font-micob font) (nth 3 r))
	  (setf (X-Font-macob font) (nth 4 r))
	  (setf (X-Font-defchar font) (nth 5 r))
	  (setf (X-Font-nprops font) (length props))
	  (setf (X-Font-dd font) (nth 6 r))
	  (setf (X-Font-minbyte font) (nth 7 r))
	  (setf (X-Font-maxbyte font) (nth 8 r))
	  (setf (X-Font-allce font) (nth 9 r))
	  (setf (X-Font-fontascent font) (nth 10 r))
	  (setf (X-Font-fontdescent font) (nth 11 r))
	  (setf (X-Font-ncinfo font) (length chinfo))
	  (setf (X-Font-props font) (vconcat (mapcar 'vconcat props)))
	  (setf (X-Font-chinfo font) (vconcat (mapcar 'vconcat chinfo)))
	  t)
      nil)))

(defun XQueryTextExtents (xdpy font string)
  "On display XDPY fetch FONT's info for STRING."
  (X-Dpy-p xdpy 'XQueryTextExtents)
  (X-Font-p font 'XQueryTextExtents)

  (let* ((ListOfFields
	  (list [1 48]                  ; opcode
		[1 (% (length string) 2)] ;oddLength
		[2 (+ 2 (X-padlen (concat string string)))] ;length
		[4 (X-Font-id font)]))
	 (msg (concat (X-Create-message ListOfFields)
		      (apply 'concat
                             (mapcar #'(lambda (c) (string ?\0 c)) string))
		      (when (> (% (length string) 2) 0) (make-string 2 ?\0))
		      ))
	 (ReceiveFields
	  (list [1 success]		;success field
		nil
		(list [1 integerp]	;draw direction (> 0 - left to right, < - right to left)
		      [2 integerp]	;sequence
		      [4 nil]		;length
		      [2 integerp]	;font ascent
		      [2 integerp]	;font descent
		      [2 integerp]	;over all ascent
		      [2 integerp]	;over all descont
		      [4 numberp]	;over all width
		      [4 numberp]	;over all left
		      [4 numberp]	;over all right
		      [4 nil]))))	;pad

    (X-Dpy-send-read xdpy msg ReceiveFields)))

;; Pixmaps

(defun XCreatePixmap (xdpy pixmap d depth width height)
  "On display XDPY create PIXMAP using drawable D.
Return X-Pixmap structure."
  (X-Dpy-p xdpy 'XCreatePixmap)
  (X-Pixmap-p pixmap 'XCreatePixmap)
  (X-Drawable-p d)

  (setf (X-Pixmap-width pixmap) width)
  (setf (X-Pixmap-height pixmap) height)
  (setf (X-Pixmap-depth pixmap) depth)
  
  ;; Set pixmap's drawable
  (setf (X-Pixmap-d pixmap) d)

  (let* ((ListOfFields
	  (list [1 53]			; opcode
		[1 depth]
		[2 4]			; length
		[4 (X-Pixmap-id pixmap)]
		[4 (X-Drawable-id d)]
		[2 width]
		[2 height]))
	 (msg (X-Create-message ListOfFields)))
    (X-Dpy-send xdpy msg)
    pixmap))

(defun XFreePixmap (xdpy pixmap)
  "On display XDPY free pixmap."
  (X-Dpy-p xdpy 'XFreePixmap)
  (X-Pixmap-p pixmap 'XFreePixmap)

  (let* ((ListOfFields
	  (list [1 54]                  ; opcode
		[1 nil]
		[2 2]
		[4 (X-Pixmap-id pixmap)]))
	 (msg (X-Create-message ListOfFields)))
    (X-Dpy-send xdpy msg)

    ;; Invalidate pixmap
    (X-invalidate-cl-struct pixmap)
    ))

;; Cursoring
(defun XCreateCursor (xdpy type)
  "On display XDPY create cursor of TYPE."
  (X-Dpy-p xdpy 'XCreateCursor)

  (let* ((ListOfFields
	  (list [1 93]			;opcode
		[1 type]
		[2 2]			;length
		[4 nil]))
	 (msg (X-Create-message ListOfFields)))
    (X-Dpy-send xdpy msg)))

(defun XCreateGlyphCursor (xdpy cursor)
  "On display XDPY create CURSOR.
CURSOR is `X-Cursor' structure."
  (X-Dpy-p xdpy 'XCreateGlyphCursor)
  (X-Cursor-p cursor 'XCreateGlyphCursor)

  (unless (X-Cursor-id cursor)
    (setf (X-Cursor-id cursor) (X-Dpy-get-id xdpy)))

  (let* ((attrmsg (X-Cursor-message cursor))
	 (ListOfFields
	  (list [1 94]			;opcode
		[1 nil]			;pad
		[2 (+ 2 (/ (length attrmsg) 4))] ;length
		[4 (X-Cursor-id cursor)])) ;cursor id
	 (msg (concat (X-Create-message ListOfFields) attrmsg)))
    (X-Dpy-send xdpy msg)))

(defun XFreeCursor (xdpy cursor)
  "On display XDPY free resources associated with CURSOR."
  (let ((ListOfFields
         (list [1 95]			;opcode
               [1 nil]			;pad
               [2 2]
               [4 (X-Cursor-id cursor)]))) ;cursor id
    (X-Dpy-send xdpy (X-Create-message ListOfFields)))
  (X-invalidate-cl-struct cursor))

(defun XRecolorCursor (xdpy cursor fore-red fore-green fore-blue &optional back-red back-green back-blue)
  "On display XDPY recolorize CURSOR."
  (when fore-red
    (setf (X-Cursor-fgred cursor) fore-red))
  (when fore-green
    (setf (X-Cursor-fggreen cursor) fore-green))
  (when fore-blue
    (setf (X-Cursor-fgblue cursor) fore-blue))
  (when back-red
    (setf (X-Cursor-bgred cursor) back-red))
  (when back-green
    (setf (X-Cursor-bggreen cursor) back-green))
  (when back-blue
    (setf (X-Cursor-bgblue cursor) back-blue))

  (let ((ListOfFields
         (list [1 96]			;opcode
               [1 nil]			;pad
               [2 5]
               [4 (X-Cursor-id cursor)] ;cursor id
               [2 (X-Cursor-fgred cursor)]
               [2 (X-Cursor-fggreen cursor)]
               [2 (X-Cursor-fgblue cursor)]
               [2 (X-Cursor-bgred cursor)]
               [2 (X-Cursor-bggreen cursor)]
               [2 (X-Cursor-bgblue cursor)])))
    (X-Dpy-send xdpy (X-Create-message ListOfFields))))
  
(defun XChangeActivePointerGrab (xdpy cursor ev-mask &optional time)
  "Change active pointer grabbing."
  (X-Dpy-p xdpy 'XChangeActivePointerGrab)
  (X-Cursor-p cursor 'XChangeActivePointerGrab)

  (let* ((ListOfFields
	  (list [1 30]			;opcode
		[1 nil]			;pad
		[2 4]			;length
		[4 (X-Cursor-id cursor)] ;cursor 
		[4 (or time X-CurrentTime)]
		[2 ev-mask]
		[2 nil]))		;pad
	 (msg (X-Create-message ListOfFields)))
    (X-Dpy-send xdpy msg)))

;;; Extensions support

(defun XQueryExtension (xdpy name)
  "On display XDPY query for extension with NAME."
  (X-Dpy-p xdpy 'XQueryExtension)

  (let* ((ListOfFields
	  (list [1 98]			;opcode
		[1 nil]			;pad
		[2 (+ 2 (X-padlen name))] ;length
		[2 (length name)]	;chars in string
		[2 nil]))		;pad
	 (msg (concat (X-Create-message ListOfFields)
		      name
		      (make-string (- (* 4 (X-padlen name)) (length name)) 0)))
	 (ReceiveFields
	  (list [1 success]
		nil
		(list [1 nil]		;unused
		      [2 integerp]	;sequence
		      [4 nil]		;length
		      [1 booleanp]	;present
		      [1 integerp]	;major_opcode
		      [1 integerp]	;first_event
		      [1 integerp]	;first_error
		      [20 nil])))	;padding
	 r)

    (setq r (X-Dpy-send-read xdpy msg ReceiveFields))
    (X-Dpy-log xdpy 'x-misc "Get reply for query ext: %s" 'r)

    (if (and (car r)
	     (nth 2 r))			; present field
	(pushnew (cons name r) (X-Dpy-extensions xdpy))
      nil)))

(defun X-Dpy-get-extension (xdpy extname &optional sig)
  "On display XDPY get extension with EXTNAME.
If SIG, then signal an error if extension is not available."
  (let ((ext (or (assoc extname (X-Dpy-extensions xdpy))
		 (car (XQueryExtension xdpy extname)))))
    (if (and (null ext) sig)
	(signal 'search-failed (list sig 'X-Dpy-get-extension extname))
      ext)))

;; Screen saver support
(defun XSetScreenSaver (xdpy timeout interval prefer-blacking allow-exposures)
  "On dispay XDPY set screen saver parameters."
  (X-Dpy-p xdpy 'XSetScreenSaver)

  (let* ((ListOfFields
	  (list [1 107]		; opcode
		[1 nil]
		[2 3]
		[2 timeout]
		[2 interval]
		[1 prefer-blacking]
		[1 allow-exposures]
		[2 nil]))
	 (msg (X-Create-message ListOfFields)))
    (X-Dpy-send xdpy msg)))

(defun XGetScreenSaver (xdpy)
  "On display XDPY get info about screen saver."
  (X-Dpy-p xdpy 'XGetScreenSaver)

  (let* ((ListOfFields
	  (list [1 108]			;opcode
		[1 nil]			; unused
		[2 1]))
	 (msg (X-Create-message ListOfFields))
	 (ReceiveFields
	  (list [1 success]
		nil
		(list [1 nil]
		      [2 nil]
		      [4 nil]
		      [2 integerp]	; timeout
		      [2 integerp]	; interval
		      [1 booleanp]	; prefer-blacking
		      [1 booleanp]	; allow-exposures
		      [18 nil]))))
    (X-Dpy-send-read xdpy msg ReceiveFields)))

(defun XKillClient (xdpy resource)
  "On display XDPY kill client RESOURCE."
  (X-Dpy-p xdpy 'XKillClient)

  (let* ((ListOfFields
          (list [1 113]                 ; opcode
                [1 nil]                 ; unused
                [2 2]                   ; length
                [4 resource]))          ; resource ID
         (msg (X-Create-message ListOfFields)))
    (X-Dpy-send xdpy msg)))
                
(defun XForceScreenSaver (xdpy &optional mode)
  "On display XDPY force screen saver in mode."
  (X-Dpy-p xdpy 'XForceScreenSaver)

  (let* ((ListOfFields
	  (list [1 115]                 ; opcode
		[1 mode]
		[2 1]))
	 (msg (X-Create-message ListOfFields)))
    (X-Dpy-send xdpy msg)))

;; Additional events queue operations
(defun XNextEvent (xdpy &optional timeout predict)
  "On display XDPY get next X Event.
Optionally you can specify TIMEOUT.
If TIMEOUT specified and no event arrived in TIMEOUT period, return nil.
If PREDICT is non-nil return only events which on which PREDICT returns non-nil,
others(not matched) events continue processing normally."
  (let ((timo (and timeout (add-timeout timeout nil 'XNextEvent-timeout)))
        done ret)

    (while (not done)
      (let* ((nev (next-event))
             (type (event-type nev))
             obj)
        (setq ret (cond ((and (eq type 'timeout)
                              (eq (event-object nev) 'XNextEvent-timeout))
                         (setq timo nil) ; unset it
                         (setq done t)
                         nil)
                        ((and (eq type 'eval)
                              (X-Event-p (setq obj (event-object nev)))
                              (or (null predict)
                                  (funcall predict obj)))
                         (setq done t)
                         obj)
                        (t (dispatch-event nev) nil)))))

    (when timo
      (disable-timeout timo))
    ret))

(defun XIfEvent (xdpy predict)
  "Return next X event on XDPY, who match PREDICT."
  (XNextEvent xdpy nil predict))

(defun XSyncEvents (xdpy)
  "Syncronize events ready for XDPY."
  (funcall (X-Dpy-parse-guess-dispatcher xdpy) xdpy))
  
(defun XSync (xdpy &optional discard)
  "Sync with server.
When DISCARD is non nil, remove all events in events queue, even these
who was before entering `XSync'."
  (XGetInputFocus xdpy))

(defun XSetFont (xdpy gc font)
  "On display XDPY for GC set FONT."
  (X-Dpy-p xdpy 'XSetFont)
  (X-Gc-p gc 'XSetFont)
  (X-Font-p font 'XSetFont)

  (setf (X-Gc-font gc) font)
  (XChangeGC xdpy gc))

(defalias 'XFlush 'X-Dpy-send-flush)


(provide 'xlib-xlib)

;;; xlib-xlib.el ends here