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

   1 ;;; xlib-xlib.el --- X library part of new xlib.
   2
   3 ;; Copyright (C) 2003-2005 by XWEM Org.
   4
   5 ;; Author: Eric M. Ludlam <zappo@gnu.ai.mit.edu>
   6 ;;         Zajcev Evgeny <zevlg@yandex.ru>
   7 ;; Keywords: xlib, xwem
   8 ;; X-CVS: $Id: xlib-xlib.el,v 1.9 2005-04-04 19:55:30 lg Exp $
   9
  10 ;; This file is part of XWEM.
  11
  12 ;; XWEM is free software; you can redistribute it and/or modify it
  13 ;; under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; XWEM is distributed in the hope that it will be useful, but WITHOUT
  18 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  19 ;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
  20 ;; License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  24 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  25 ;; 02111-1307, USA.
  26
  27 ;;; Synched up with: Not in FSF
  28
  29 ;;; Commentary:
  30
  31 ;;; Code:
  32 \f
  33 (require 'xlib-xr)
  34
  35 (defun XOpenDisplay (name &optional dispnum screen)
  36   "Open an X connection to the display named NAME such as host:0.1.
  37 Optionally you may pass DISPNUM - display number and SCREEN - screen number."
  38   ;; first, open a connection to name
  39   (when (string-match ":\\([0-9]*\\|[0-9]*\\)\.*\\([0-9]*\\)" name)
  40     (setq dispnum
  41           (or dispnum
  42               (truncate (string-to-int (substring name (match-beginning 1) (match-end 1))))))
  43     (setq screen
  44           (or screen
  45               (truncate (string-to-int (substring name (match-beginning 2) (match-end 2))))))
  46     (setq name (substring name 0 (- (match-beginning 1) 1))))
  47
  48   (when (= (length name) 0)
  49     (setq name (system-name)))
  50
  51   (let ((xdpy (X-Dpy-create-connection name dispnum)))
  52     ;; Connection is open, and X-info contains connection informaion.
  53     (let ((X-info (X-Dpy-send-read xdpy (X-Create-message X-client-to-open)
  54                                    X-connect-response)))
  55
  56       (if (null (nth 0 X-info))
  57           (message "X: %s" (nth X-info 3))
  58
  59         (setf (X-Dpy-proto-maj xdpy) (nth 1 X-info))
  60         (setf (X-Dpy-proto-min xdpy) (nth 2 X-info))
  61         (setf (X-Dpy-resource-base xdpy) (nth 4 X-info))
  62         (setf (X-Dpy-resource-mask xdpy) (nth 5 X-info))
  63         (setf (X-Dpy-motion-bufsize xdpy) (nth 6 X-info))
  64         (setf (X-Dpy-max-request-size xdpy) (nth 7 X-info))
  65         (setf (X-Dpy-byte-order xdpy) (nth 8 X-info))
  66         (setf (X-Dpy-bitmap-scanline-unit xdpy) (nth 9 X-info))
  67         (setf (X-Dpy-bitmap-scanline-pad xdpy) (nth 10 X-info))
  68         (setf (X-Dpy-bitmap-bit-order xdpy) (nth 11 X-info))
  69         (setf (X-Dpy-min-keycode xdpy) (nth 12 X-info))
  70         (setf (X-Dpy-max-keycode xdpy) (nth 13 X-info))
  71         (setf (X-Dpy-vendor xdpy) (nth 14 X-info))
  72
  73         ;; Fill formats list
  74         (setf (X-Dpy-formats xdpy)
  75               (mapcar #'(lambda (fmt)
  76                           (make-X-ScreenFormat :depth (nth 0 fmt)
  77                                                :bits-per-pixel (nth 1 fmt)
  78                                                :scanline-pad (nth 2 fmt)))
  79                       (nth 15 X-info)))
  80
  81         ;; Fill screens list
  82         (setf (X-Dpy-screens xdpy)
  83               (mapcar #'(lambda (scr)
  84                           (let (nscreen)
  85                             (setq nscreen
  86                                   (make-X-Screen
  87                                    :root (X-Win-find-or-make xdpy (nth 0 scr))
  88                                    :colormap (make-X-Colormap :dpy xdpy :id (nth 1 scr))
  89                                    :white-pixel (make-X-Color :dpy xdpy :id (nth 2 scr))
  90                                    :black-pixel (make-X-Color :dpy xdpy :id (nth 3 scr))
  91                                    :root-event-mask (nth 4 scr)
  92                                    :width (nth 5 scr)
  93                                    :height (nth 6 scr)
  94                                    :mwidth (nth 7 scr)
  95                                    :mheight (nth 8 scr)
  96                                    :min-maps (nth 9 scr)
  97                                    :max-maps (nth 10 scr)
  98                                    :visualid (nth 11 scr)
  99                                    :backingstores (nth 12 scr)
 100                                    :save-unders (nth 13 scr)
 101                                    :root-depth (nth 14 scr)))
 102
 103                             (setf (X-Screen-depths nscreen)
 104                                   (mapcar #'(lambda (dpth)
 105                                               (make-X-Depth :depth (nth 0 dpth)
 106                                                             :visuals (mapcar #'(lambda (vis)
 107                                                                                  (make-X-Visual :id (nth 0 vis)
 108                                                                                                 :class (nth 1 vis)
 109                                                                                                 :bits-per-rgb (nth 2 vis)
 110                                                                                                 :cmap-entries (nth 3 vis)
 111                                                                                                 :red-mask (nth 4 vis)
 112                                                                                                 :green-mask (nth 6 vis)
 113                                                                                                 :blue-mask (nth 5 vis)))
 114                                                                              (nth 1 dpth))))
 115                                           (nth 15 scr)))
 116
 117                             ;; Create default GC
 118                             (setf (X-Screen-default-gc nscreen)
 119                                   (XCreateGC xdpy (X-Screen-root nscreen)
 120                                              (make-X-Gc :dpy xdpy :id (X-Dpy-get-id xdpy)
 121                                                         :foreground (X-Screen-white-pixel nscreen)
 122                                                         :background (X-Screen-black-pixel nscreen))))
 123                             nscreen))
 124                       (nth 16 X-info)))
 125
 126         ;; Alert user
 127         (message "Connection opened to %s...done" name)
 128         xdpy))))
 129
 130 (defun XCloseDisplay (xdpy)
 131   "Close the connection to display XDPY."
 132   (X-Dpy-close xdpy))
 133
 134 (defun XScreenCheck (xdpy scrnum)
 135   "Check SCRNUM screen on display XDPY."
 136   (unless scrnum
 137     (setq scrnum 0))
 138
 139   (when (> scrnum (1- (length (X-Dpy-screens xdpy))))
 140     (error "xlib: screen with number %d does not exists." scrnum))
 141   scrnum)
 142
 143 (defsubst XDefaultRootWindow (xdpy &optional scrnum)
 144   "Return default root window on XDPY."
 145   (X-Dpy-p xdpy 'XDefaultRootWindow)
 146   (X-Screen-root (nth (XScreenCheck xdpy scrnum) (X-Dpy-screens xdpy))))
 147
 148 (defsubst XWhitePixel (xdpy &optional scrnum)
 149   "Return white pixel for display XDPY."
 150   (X-Dpy-p xdpy 'XWhitePixel)
 151   (X-Screen-white-pixel (nth (XScreenCheck xdpy scrnum) (X-Dpy-screens xdpy))))
 152
 153 (defsubst XBlackPixel (xdpy &optional scrnum)
 154   "Return black pixel for display XDPY."
 155   (X-Dpy-p xdpy 'XBlackPixel)
 156   (X-Screen-black-pixel (nth (XScreenCheck xdpy scrnum) (X-Dpy-screens xdpy))))
 157
 158 (defsubst XDefaultColormap (xdpy &optional scrnum)
 159   "Return default colormap for XDPY on screen SCRNUM."
 160   (X-Dpy-p xdpy 'XDefaultColormap)
 161   (X-Screen-colormap (nth (XScreenCheck xdpy scrnum) (X-Dpy-screens xdpy))))
 162
 163 (defsubst XDefaultVisual (xdpy &optional scrnum)
 164   "Return visual on XDPY and SCRNUM."
 165   (X-Dpy-p xdpy 'XDefaultVisual)
 166   (X-Screen-visualid (nth (XScreenCheck xdpy scrnum) (X-Dpy-screens xdpy))))
 167
 168 (defsubst XDefaultGC (xdpy &optional scrnum)
 169   "Return default GC on XDPY and SCRNUM."
 170   (X-Dpy-p xdpy 'XDefaultGC)
 171   (X-Screen-default-gc (nth (XScreenCheck xdpy scrnum) (X-Dpy-screens xdpy))))
 172
 173 (defun XDefaultDepth (xdpy &optional scrnum)
 174   "Return default depth on XDPY and screen SCRNUM."
 175   (X-Dpy-p xdpy 'XDefaultDepth)
 176
 177   (or (X-Dpy-get-property xdpy 'default-depth)
 178       (let ((vid (XDefaultVisual xdpy))
 179             (depths (X-Screen-depths (nth (XScreenCheck xdpy scrnum) (X-Dpy-screens xdpy))))
 180             viss found)
 181         (while (and depths (not found))
 182           (setq viss (X-Depth-visuals (car depths)))
 183           (while (and viss (not (= (X-Visual-id (car viss)) vid)))
 184             (setq viss (cdr viss)))
 185           (if (car viss)
 186               (setq found t)
 187             (setq depths (cdr depths))))
 188
 189         (if (car depths)
 190             (progn
 191               (X-Dpy-put-property xdpy 'default-depth (X-Depth-depth (car depths)))
 192               (X-Depth-depth (car depths)))
 193
 194           ;; Hmm, why not found?
 195           (X-Depth-depth (car (X-Screen-depths (nth (XScreenCheck xdpy scrnum) (X-Dpy-screens xdpy)))))))))
 196
 197 (defun X-Dpy-find-visual-for-depth (xdpy depth &optional scrnum)
 198   "On display XDPY find appopriate visual for DEPTH."
 199   (let ((depths (X-Screen-depths (nth (XScreenCheck xdpy scrnum) (X-Dpy-screens xdpy)))))
 200     (while (and depths (not (= (X-Depth-depth (car depths)) depth)))
 201       (setq depths (cdr depths)))
 202     (when (car depths)
 203       ;; XXX
 204       (car (X-Depth-visuals (car depths))))))
 205
 206 ;;; Simple Noise
 207 (defun XBell (xdpy percent)
 208   "Ring the bell on XDPY at PERCENT volume."
 209   (X-Dpy-p xdpy 'XBell)
 210   (let ((ListOfFields
 211          (list [1 104]                  ;opcode
 212                [1 percent]              ;percentage
 213                [2 1])))                 ;length of request (in 4s)
 214     (X-Dpy-send xdpy (X-Create-message ListOfFields))))
 215
 216
 217 (defun XCreateWindow (xdpy &optional parent x y width height
 218                             border-width depth class visual
 219                             attrs)
 220   "Create a window."
 221   (X-Dpy-p xdpy 'XCreateWindow)
 222
 223   (let* ((wid (X-Dpy-get-id xdpy))
 224          (attrmsg (X-Attr-message attrs))
 225          (ListOfFields
 226           (list [1 1]                   ; opcode
 227                 [1 (or depth X-CopyFromParent)] ;depth
 228                 [2 (+ 7 (/ (length attrmsg) 4))] ;8 means no attributes yet
 229                 [4 wid]                 ;newly alloced wid.
 230                 [4 (X-Win-id
 231                     (if (X-Win-p parent) parent ;the parent
 232                       (XDefaultRootWindow xdpy))) ]
 233                 [2 (or x 100)]  ;x position
 234                 [2 (or y 100)]  ;y position
 235                 [2 (or width 100)] ;width
 236                 [2 (or height 100)] ;height
 237                 [2 (or border-width 1)] ;border width
 238                 [2 (or class X-CopyFromParent)] ;class
 239                 [4 (or visual X-CopyFromParent)] ;visual
 240                 ))
 241          (msg (concat (X-Create-message ListOfFields)
 242                       attrmsg)))
 243     (X-Dpy-send xdpy msg)
 244     (X-Win-find-or-make xdpy wid)))
 245
 246 (defun XChangeWindowAttributes (xdpy win attrs)
 247   "On XDPY and window WIN, change to the ATTRIBUTES."
 248   (X-Dpy-p xdpy 'XChangeWindowAttributes)
 249   (X-Attr-p attrs 'XChangeWindowAttributes)
 250   (X-Win-p win 'XChangeWindowAttributes)
 251
 252   (let* ((attrmsg (X-Attr-message attrs))
 253          (ListOfFields
 254           (list [1 2]                   ;opcode
 255                 [1 nil]                 ;unused
 256                 [2 (+ 2 (/ (length attrmsg) 4))] ;length
 257                 [4 (X-Win-id win)]))    ;window
 258          (msg (concat (X-Create-message ListOfFields) attrmsg)))
 259     (X-Dpy-send xdpy msg)))
 260
 261 (defun XSelectInput (xdpy win event)
 262   "On display XDPY for window WIN, set the EVENT mask."
 263   (XChangeWindowAttributes xdpy win (make-X-Attr :event-mask event)))
 264
 265 (defun XSetWindowBackground (xdpy win pixel)
 266   "On display XDPY for window WIN, set the background to PIXEL."
 267   (XChangeWindowAttributes xdpy win (make-X-Attr :background-pixel pixel)))
 268
 269 (defun XSetWindowBackgroundPixmap (xdpy win pixmap)
 270   "On display XDPY for window WIN, set the background pixmap to PIXMAP."
 271   (XChangeWindowAttributes xdpy win (make-X-Attr :background-pixmap pixmap)))
 272
 273 (defun XSetWindowBorder (xdpy win pixel)
 274   "On display XDPY for window WIN, set the border color to PIXEL."
 275   (XChangeWindowAttributes xdpy win (make-X-Attr :border-pixel pixel)))
 276
 277 (defun XSetWindowColormap (xdpy win cmap-id)
 278   "On display XDPY for window WIN, set the colormap to CMAP-ID."
 279   (XChangeWindowAttributes xdpy win (make-X-Attr :colormap cmap-id)))
 280
 281 (defun XSetWindowCursor (xdpy win cursor)
 282   (XChangeWindowAttributes xdpy win (make-X-Attr :cursor cursor)))
 283
 284 (defun XGetWindowAttributes (xdpy win)
 285   "On display XDPY, get window's WIN attributes as an `X-Attr'."
 286   (X-Dpy-p xdpy 'XGetWindowAttributes)
 287   (X-Win-p win 'XGetWindowAttributes)
 288
 289   (let ((ListOfFields
 290          (list [ 1 3]                   ;opcode
 291                [ 1 nil]                 ;unused
 292                [ 2 2]                   ;request length
 293                [ 4 (X-Win-id win)]))    ;the window
 294         (ReceiveFields
 295          (list [1 success ]             ;status
 296                nil                      ;generic bad response
 297                (list
 298 ;               [ 1 integerp ]          ;reply
 299                 [ 1 integerp ]          ;backingstore
 300                 [ 2 integerp ]          ;sequence number
 301                 [ 4 integerp ]          ;reply length
 302                 [ 4 integerp ]          ;visual id
 303                 [ 2 integerp ]          ;class
 304                 [ 1 integerp ]          ;bit gravity
 305                 [ 1 integerp ]          ;win gravity
 306                 [ 4 integerp ]          ;backing planes
 307                 [ 4 integerp ]          ;backing pixel
 308                 [ 1 integerp ]          ;save under
 309                 [ 1 integerp ]          ;map is installed
 310                 [ 1 integerp ]          ;map state
 311                 [ 1 integerp ]          ;override-redirect
 312                 [ 4 integerp ]          ;colormap
 313                 [ 4 integerp ]          ;all event masks
 314                 [ 4 integerp ]          ;my event masks
 315                 [ 2 integerp ]          ;do not propagate mask
 316                 [ 2 nil ] )))           ;pad
 317         (r nil))
 318
 319     (setq r (X-Dpy-send-read xdpy (X-Create-message ListOfFields) ReceiveFields))
 320     (if (not (car r))
 321         nil
 322       (make-X-Attr :backing-store (nth 1 r)
 323                    :visualid (nth 4 r)
 324                    :bit-gravity (nth 6 r)
 325                    :win-gravity (nth 7 r)
 326                    :backing-planes (nth 8 r)
 327                    :backing-pixel (nth 9 r)
 328                    :save-under (if (= (nth 10 r) 0) nil t)
 329                    :mapstate (nth 12 r)
 330                    :override-redirect (if (= (nth 13 r) 0) nil t)
 331                    :colormap (make-X-Colormap :dpy xdpy :id (nth 14 r))
 332                    :event-mask (nth 16 r)
 333                    :do-not-propagate-mask (nth 17 r)))))
 334
 335 (defun XConfigureWindow (xdpy win conf)
 336   "On display XDPY, change window WIN to have configuration CONF.
 337 CONF is an `X-Conf' structure."
 338   (X-Dpy-p xdpy 'XConfigureWindow)
 339   (X-Conf-p conf 'XConfigureWindow)
 340   (X-Win-p win 'XConfigureWindow)
 341
 342   (let* ((cfgmsg (X-Conf-message conf))
 343          (ListOfFields
 344           (list [1 12]                  ;opcode
 345                 [1 nil]                 ;unused
 346                 [2 (+ 2 (/ (length cfgmsg) 4))] ;length
 347                 [4 (X-Win-id win)]))    ;window
 348          (msg (concat (X-Create-message ListOfFields) cfgmsg)))
 349     (X-Dpy-send xdpy msg)))
 350
 351 (defun XLowerWindow (xdpy win)
 352   "On display XDPY, lower window WIN."
 353   (XConfigureWindow xdpy win (make-X-Conf :stackmode X-Below)))
 354
 355 (defun XRaiseWindow (xdpy win)
 356   "On display XDPY, raise window WIN."
 357   (XConfigureWindow xdpy win (make-X-Conf :stackmode X-Above)))
 358
 359 (defun XMoveWindow (xdpy win x y)
 360   "On display XDPY, move window WIN to position X Y."
 361   (XConfigureWindow xdpy win (make-X-Conf :x x :y y)))
 362
 363 (defun XResizeWindow (xdpy win w h)
 364   "On display XDPY, resize window WIN to dimentions W H."
 365   (XConfigureWindow xdpy win (make-X-Conf :width w :height h)))
 366
 367 (defun XMoveResizeWindow (xdpy win x y w h)
 368   "On display XDPY, move and resize window WIN to X, Y, W, H."
 369   (XConfigureWindow xdpy win (make-X-Conf :x x :y y :width w :height h)))
 370
 371 (defun XSetWindowBorderWidth (xdpy win width)
 372   "On display XDPY, set window's WIN border to be WIDTH pixels wide."
 373   (XConfigureWindow xdpy win (make-X-Conf :border-width width)))
 374
 375 (defun XMapWindow (xdpy win)
 376   "On display XDPY, map WIN to the screen (to make it visible.)."
 377   (X-Dpy-p xdpy 'XMapWindow)
 378   (X-Win-p win 'XMapWindow)
 379
 380   (let ((ListOfFields
 381          (list [1 8]                    ;opcode
 382                [1 nil]                  ;unused
 383                [2 2]                    ;length of request (in 4s)
 384                [4 (X-Win-id win)])))    ;window to map
 385     (X-Dpy-send xdpy (X-Create-message ListOfFields))))
 386
 387 (defun XUnmapWindow (xdpy win)
 388   "On display XDPY, unmap window WIN to make it hidden."
 389   (X-Dpy-p xdpy 'XUnmapWindow)
 390   (X-Win-p win 'XUnmapWindow)
 391
 392   (let ((ListOfFields
 393          (list [1 10]                   ;opcode
 394                [1 nil]                  ;unused
 395                [2 2]                    ;length of request (in 4s)
 396                [4 (X-Win-id win)])))    ;window to map
 397     (X-Dpy-send xdpy (X-Create-message ListOfFields))))
 398
 399 (defun XDestroyWindow (xdpy win)
 400   "On display XDPY, destroy window WIN."
 401   (X-Dpy-p xdpy 'XDestroyWindow)
 402   (X-Win-p win 'XDestroyWindow)
 403
 404   (let ((ListOfFields
 405          (list [1 4]                    ;opcode
 406                [1 nil]                  ;unused
 407                [2 2]                    ;length of request (in 4s)
 408                [4 (X-Win-id win)])))    ;window to map
 409     (X-Dpy-send xdpy (X-Create-message ListOfFields))
 410
 411     ;; Schedule window WIN for total removing
 412     (X-Win-invalidate xdpy win)))
 413
 414 (defun XDestroySubwindows (xdpy win)
 415   "On display XDPY, destroy subwindows of window WIN."
 416   (X-Dpy-p xdpy 'XDestroySubwindows)
 417   (X-Win-p win 'XDestroySubwindows)
 418
 419   (let ((ListOfFields
 420          (list [1 5]                    ;opcode
 421                [1 nil]                  ;unused
 422                [2 2]                    ;length of request (in 4s)
 423                [4 (X-Win-id win)])))    ;window to map
 424     (X-Dpy-send xdpy (X-Create-message ListOfFields))))
 425
 426 (defun XQueryTree (xdpy win)
 427   "Query display XDPY for all children of window WIN.
 428 Returns a list of the form (ROOT PARENT CHILD1 CHILD2 ...)
 429 on success, or nil on failure.  ROOT is the root window for the display that
 430 WINDOW is on.  PARENT is the parent of WINDOW, and CHILDN are the
 431 children of WINDOW."
 432   (X-Dpy-p xdpy 'XQueryTree)
 433   (X-Win-p win 'XQueryTree)
 434
 435   (let* ((ListOfFields
 436           (list [ 1 15]                 ;opcode
 437                 [ 1 nil ]               ;unused
 438                 [ 2 2 ]                 ;request length
 439                 [ 4 (X-Win-id win)]))   ;window we are querying.
 440          (ReceiveFields
 441           (list [ 1 success]            ;status
 442                 nil                     ;generic bad response
 443                 (list [ 1 nil]          ;unused
 444                       [ 2 integerp ]    ;sequence number
 445                       [ 4 length-1 ]    ;length of the return in 4 blocks
 446                       [ 4 :X-Win ]      ;root window
 447                       [ 4 :X-Win ]      ;parent window
 448                       [ 2 length-2 ]    ;number of children
 449                       [ 14 nil ]        ;unused
 450                       [ (* 4 length-2) :X-Win])))) ;list of the children
 451
 452     (X-Dpy-send-read xdpy (X-Create-message ListOfFields) ReceiveFields)))
 453
 454
 455 ;;; Time to play with properties and Atoms
 456 ;;
 457 (defun XInternAtom (xdpy name &optional only-if-exists)
 458   "On display XDPY, return the Atom with NAME.
 459 If ONLY-IF-EXISTS is nil, then the atom is created if it does not already
 460 exist.  The Atom object is returned."
 461   (X-Dpy-p xdpy 'XInternAtom)
 462   (if (not (stringp name))
 463       (signal 'wrong-type-argument (list 'signal 'stringp name)))
 464
 465   (let ((a (X-Atom-find-by-name xdpy name)))
 466     (if (X-Atom-p a)
 467         a
 468       (let ((ListOfFields
 469              (list [1 16]               ;opcode
 470                    [1 only-if-exists]   ;forcecreate flag.
 471                    [2 (+ 2 (X-padlen name))] ;message length
 472                    [2 (length name)]    ;name length
 473                    [2 nil]              ;unused
 474                    [(length name) name] ;name
 475                    ;; Auto-padded
 476                    ))
 477             (ReceiveFields
 478              (list [1 success]          ;status message
 479                    nil                  ;generic bad response
 480                    (list [1 nil]        ;unused
 481                          [2 integerp]   ;sequence
 482                          [4 nil]        ;reply length
 483                          [4 :X-Atom]    ;atom id
 484                          [20 nil])))
 485             r)
 486
 487         (setq r (X-Dpy-send-read xdpy (X-Create-message ListOfFields) ReceiveFields))
 488         (if (car r)
 489             (let ((rat (nth 2 r)))
 490               (setf (X-Atom-name rat) name)
 491               (X-Atom-insert xdpy rat)
 492               rat)
 493           nil)))))
 494
 495 (defun XGetAtomName (xdpy atom)
 496   "On display XDPY, get the textual name of ATOM.
 497 *UNTESTED*"
 498   (X-Dpy-p xdpy 'XGetAtomName)
 499   (X-Atom-p atom 'XGetAtomName)
 500
 501   (let ((a (X-Atom-find xdpy (X-Atom-id atom))))
 502     (if (X-Atom-p a)
 503         a
 504       (let ((ListOfFields
 505              (list [ 1 17]              ;opcode
 506                    [ 1 nil]             ;unused
 507                    [ 2 2]               ;length
 508                    [ 4 (X-Atom-id atom)])) ;atom id
 509             (ReceiveFields
 510              (list
 511               [1 success ]              ;status message
 512               nil                       ;generic bad response
 513               (list [ 1 nil ]           ;unused
 514                     [ 2 integerp ]      ;sequence
 515                     [ 4 length-1 ]      ;reply length
 516                     [ 2 length-2 ]      ;length of name
 517                     [ 22 nil ]          ;unused
 518                     [ length-2 stringp ] ;the name
 519                     [ (X-pad length-2) nil ] ;padding
 520                     )))
 521             r)
 522         (setq r (X-Dpy-send-read xdpy (X-Create-message ListOfFields) ReceiveFields))
 523         (if (car r)
 524             (progn
 525               (setf (X-Atom-name atom) (nth 2 r))
 526               (X-Atom-insert xdpy atom)
 527               (nth 2 r))
 528           nil)))))
 529
 530 (defun XChangeProperty (xdpy win property type format mode data)
 531   "On display XDPY for window WIN, change PROPERTY.
 532 PROPERTY is changed based on a TYPE, FORMAT, and MODE with DATA.
 533 There are NElements."
 534   (X-Dpy-p xdpy 'XChangeProperty)
 535   (X-Win-p win 'XChangeProperty)
 536   (X-Atom-p property 'XChangeProperty)
 537   (X-Atom-p type 'XChangeProperty)
 538
 539   (let* ((n (* (length data) (/ format 8)))
 540          (p (X-pad n))
 541          (ListOfFields
 542           (list [1 18]                  ;opcode
 543                 [1 mode]                ;Mode: Replace Prepend, Append
 544                 (vector 2 (+ 6 (/ (+ n p) 4)))  ;length, shut up compiler
 545                 [4 (X-Win-id win)]      ;window
 546                 [4 (X-Atom-id property)] ;property atom
 547                 [4 (X-Atom-id type)]    ;property type
 548                 [1 format]              ;property format
 549                 [3 nil]
 550                 [4 (/ n (/ format 8))]  ;length of the list-byte thing
 551                 )))
 552     (if (and (= format 8) (stringp data))
 553         (setq ListOfFields
 554               (append ListOfFields (list (vector (length data) data))))
 555       (while data
 556         (let ((d (if (X-Generic-struct-p (car data))
 557                      (funcall (X-Generic-struct-p (car data)) (car data))
 558                    (car data))))
 559           (setq ListOfFields
 560                 (append ListOfFields (list (vector (/ format 8) d )))
 561                 data (cdr data)))))
 562     (X-Dpy-send xdpy (X-Create-message ListOfFields))))
 563
 564 (defun XDeleteProperty (xdpy win atom)
 565   "On display XDPY for window WIN delete property denoted by ATOM."
 566   (X-Win-p win 'XDeleteProperty)
 567   (X-Atom-p atom 'XDeleteProperty)
 568
 569   (let ((ListOfFields
 570          (list [1 19]                   ;opcode
 571                [1 nil]                  ;unused
 572                [2 3]                    ;length
 573                [4 (X-Win-id win)]       ;window
 574                [4 (X-Atom-id atom)])))  ;atom
 575     (X-Dpy-send xdpy (X-Create-message ListOfFields))))
 576
 577 ;; These are Xlib convenience routines
 578 (defun XSetPropertyString (xdpy win atom string &optional mode)
 579   "On display XDPY and window WIN set ATOM property to STRING."
 580   (XChangeProperty xdpy win atom XA-string X-format-8 (or mode X-PropModeReplace)
 581                     string))
 582
 583 (defun XSetWMProtocols (xdpy win protocol_atoms)
 584   "On display XDPY, set window's WIN protocols to PROTOCOL_ATOMS.
 585 Convenience routine which calls `XChangeProperty'"
 586   (XChangeProperty xdpy win (XInternAtom xdpy "WM_PROTOCOLS" nil)
 587                     XA-atom X-format-32 X-PropModeReplace protocol_atoms))
 588
 589 (defun XSetWMClass (xdpy win wm-class)
 590   "On displayX DPY, set window's WIN Class to WM-CLASS.
 591 WM-CLASS should be in form '(class-name class-intance)."
 592   (XChangeProperty xdpy win XA-wm-class XA-string X-format-8 X-PropModeReplace
 593                     (concat (car wm-class) (string 0) (cadr wm-class) (string 0))))
 594
 595 (defun XSetWMName (xdpy win wm-name)
 596   (XChangeProperty xdpy win XA-wm-name XA-string X-format-8 X-PropModeReplace
 597                     (concat wm-name)))
 598
 599 (defun XSetWMNormalHints (xdpy win wmnh)
 600   "On display XDPY, set window's WIN normal hints to HINTS.
 601 HINTS is list in format (x1 x2 ... x18)."
 602   (X-WMSize-p wmnh 'XSetWMNormalHints)
 603
 604   (let ((pplist (list (X-WMSize-flags wmnh) 0
 605                       (X-WMSize-x wmnh)
 606                       (X-WMSize-y wmnh)
 607                       (X-WMSize-width wmnh)
 608                       (X-WMSize-height wmnh)
 609                       (X-WMSize-min-width wmnh)
 610                       (X-WMSize-min-height wmnh)
 611                       (X-WMSize-max-width wmnh)
 612                       (X-WMSize-max-height wmnh)
 613                       (X-WMSize-width-inc wmnh)
 614                       (X-WMSize-height-inc wmnh)
 615                       (X-WMSize-min-aspect-x wmnh)
 616                       (X-WMSize-min-aspect-y wmnh)
 617                       (X-WMSize-max-aspect-x wmnh)
 618                       (X-WMSize-max-aspect-y wmnh)
 619                       (X-WMSize-base-width wmnh)
 620                       (X-WMSize-base-height wmnh)
 621                       (X-WMSize-gravity wmnh))))
 622
 623     (XChangeProperty xdpy win XA-wm-normal-hints XA-wm-size-hints X-format-32 X-PropModeReplace pplist)))
 624
 625 (defun XSetWMState (xdpy win wm-state &optional icon-id)
 626   "On display XDPY, set window's WIN state to WM-STATE.
 627 WM-STATE is one of `X-WithdrawnState', `X-NormalState' or `X-IconicState'."
 628   (let ((wmsa (XInternAtom xdpy "WM_STATE" nil)))
 629     (XChangeProperty xdpy win wmsa wmsa X-format-32 X-PropModeReplace (list wm-state (or icon-id 0.0)))))
 630
 631 (defun XSetWMCommand (xdpy win cmd)
 632   "On display XDPY set window's WIN WM_COMMAND property to CMD."
 633
 634   (XChangeProperty xdpy win (XInternAtom xdpy "WM_COMMAND" nil) XA-string
 635                    X-format-8 X-PropModeReplace cmd))
 636
 637 (defun XGetWindowProperty (xdpy win property &optional offset length delete required-type)
 638   "On display XDPY, get window's WIN PROPERTY atom value.
 639 Get the data from optional OFFSET, and a maximum of LENGTH bytes.
 640 OFFSET and LENGTH refer to 32 bit chunks, not 8 bit chunks.
 641 Third optional argument DELETE will delete the property if Non-nil.
 642 Fourth argument REQUIRED-TYPE filters only properties of the desired type.
 643 If REQUIRED-TYPE is `XA-AnyPropertyType', or nil then no filtering is done.
 644 The returned list is of the form:
 645   (TYPE_RETURN BYTES_AFTER PROP1 PROP2 ...)
 646 Where TYPE_RETURN is the type (of same for as REQUIRED-TYPE) is the actual
 647 type of the data being returned.
 648 FORMAT_RETURN is the format of the data (such as 8, 16, or 32).
 649 BYTES_AFTER is the number of bytes still attached to the property.
 650 If there are extra bytes, then a second call to `XGetWindowProperty' will
 651 be needed.  Lastly, PROP1 through PROPN is the list of properties
 652 originally requested.
 653   It is common to call `XGetWindowProperty' asking for no data so that
 654 BYTES_AFTER contains the exact amount of data we want to request."
 655   (X-Dpy-p xdpy 'XGetWindowProperty)
 656   (X-Win-p win 'XGetWindowProperty)
 657   (X-Atom-p property 'XGetWindowProperty)
 658
 659   (unless offset (setq offset 0))
 660   (unless length (setq length 1024))
 661   (unless required-type (setq required-type XA-AnyPropertyType))
 662
 663   (let ((ListOfFields
 664          (list [ 1 20]                  ;opcode
 665                [ 1 (if delete 1 0)]     ;delete flag
 666                [ 2 6 ]                  ;request length
 667                [ 4 (X-Win-id win) ]     ;the window whose property we want
 668                [ 4 (X-Atom-id property) ] ;The property atom we want
 669                [ 4 (X-Atom-id required-type) ] ;required type filter.
 670                [ 4 offset ]             ;offset in the property data
 671                [ 4 length ]))           ;length of data we want
 672         (ReceiveFields
 673          (list [1 success]              ;status message
 674                nil                      ;generic bad response
 675                (list
 676                 [ 1 length-1 ]          ;format of returned data
 677                 [ 2 nil ]               ;sequence number
 678                 [ 4 length-3 ]          ;length of this request
 679                 [ 4 integerp ]          ;atom representing return type
 680                 [ 4 integerp ]          ;bytes left on server
 681                 [ 4 length-2 ]          ;length of value in format units
 682                 [ 12 nil ]              ;unused
 683                 [ (if (= length-1 0)
 684                       0
 685                     (if (memq required-type (list XA-atom XA-window XA-rectangle))
 686                         ;; known type
 687                         (* length-2 (/ length-1 8))
 688                       length-2))
 689
 690                   (cond ((or (= length-1 8) (eq required-type XA-string)) 'stringp)
 691                         ((eq required-type XA-atom) :X-Atom)
 692                         ((eq required-type XA-window) :X-Win)
 693                         ((eq required-type XA-rectangle) :X-Rect)
 694                         (t '([(/ length-1 8) integerp])))]
 695                 [ (X-pad (* length-2 (/ length-1 8))) nil ]
 696                 )))
 697         (r nil)
 698         (proplist nil))
 699
 700     (setq r (X-Dpy-send-read xdpy (X-Create-message ListOfFields) ReceiveFields))
 701     (if (null (car r))
 702         nil                             ;oops
 703
 704       (setq proplist (list (nth 2 r) (nth 1 r))) ; start backwards
 705       (if (listp (nth 3 r))
 706           (setq r (nth 3 r))
 707         (setq r (nthcdr 3 r)))
 708
 709       (if (stringp r)
 710           (setq proplist (cons r proplist))
 711
 712         (while r
 713           (let ((item (car r)))
 714             (when (listp item)
 715               (setq item (car item)))
 716
 717           (setq proplist (cons item proplist)
 718                 r (cdr r)))))
 719       (nreverse proplist))))
 720
 721 ;; A few functions based on GetProperty
 722 (defun XGetWMHints (xdpy win)
 723   "On display XDPY, get window's WIN WM_HINTS."
 724   (let ((wmh (XGetWindowProperty xdpy win XA-wm-hints 0 1024 nil XA-wm-hints)))
 725     (when (and wmh (= (car wmh) (X-Atom-id XA-wm-hints)))
 726       (setq wmh (cddr wmh))           ; strip REQ-TYPE and BYTES-AFTER
 727       (make-X-WMHints :flags (Xtruncate (nth 0 wmh))
 728                       :input (Xtruncate (nth 1 wmh))
 729                       :initial-state (Xtruncate (nth 2 wmh))
 730                       :icon-pixmap (nth 3 wmh)
 731                       :icon-window (nth 4 wmh)
 732                       :icon-x (Xtruncate (nth 5 wmh))
 733                       :icon-y (Xtruncate (nth 6 wmh))
 734                       :icon-mask (nth 7 wmh)
 735                       :window-group (nth 8 wmh)))))
 736
 737 (defun XGetWMNormalHints (xdpy win)
 738   "On display XDPY, get normal hints for WIN."
 739   (let ((wmnh (XGetWindowProperty xdpy win XA-wm-normal-hints 0 40 nil XA-wm-size-hints)))
 740     (when (and wmnh (= (car wmnh) (X-Atom-id XA-wm-size-hints)))
 741       (setq wmnh (cddr wmnh))           ; strip REQ-TYPE and BYTES-AFTER
 742       (make-X-WMSize :flags (Xtruncate (nth 0 wmnh))
 743                      :x (Xtruncate (nth 1 wmnh))
 744                      :y (Xtruncate (nth 2 wmnh))
 745                      :width (Xtruncate (nth 3 wmnh))
 746                      :height (Xtruncate (nth 4 wmnh))
 747                      :min-width (Xtruncate (nth 5 wmnh))
 748                      :min-height (Xtruncate (nth 6 wmnh))
 749                      :max-width (Xtruncate (nth 7 wmnh))
 750                      :max-height (Xtruncate (nth 8 wmnh))
 751                      :width-inc (Xtruncate (nth 9 wmnh))
 752                      :height-inc (Xtruncate (nth 10 wmnh))
 753                      :min-aspect-x (Xtruncate (nth 11 wmnh))
 754                      :min-aspect-y (Xtruncate (nth 12 wmnh))
 755                      :max-aspect-x (Xtruncate (nth 13 wmnh))
 756                      :max-aspect-y (Xtruncate (nth 14 wmnh))
 757                      :base-width (Xtruncate (nth 15 wmnh))
 758                      :base-height (Xtruncate (nth 16 wmnh))
 759                      :gravity (Xtruncate (nth 17 wmnh))))))
 760
 761 (defun XDecodeCompoundText (text)
 762   "Decode compound TEXT, to native string.
 763 Evil hack, invent something better."
 764   (if (string-match "\x1b\x25\x2f\x31\\(.\\)\\(.\\)\\(.*?\\)\x02" text)
 765       (let ((len (+ (* (- (char-to-int (string-to-char (match-string 1 text))) 128) 128)
 766                     (- (char-to-int (string-to-char (match-string 2 text))) 128))))
 767         (let ((seq-beg (match-beginning 0))
 768               (data-beg (match-end 0))
 769               (data-end (+ len (match-beginning 3)))
 770               (cs (intern (match-string 3 text))))
 771           (concat (substring text 0 seq-beg)
 772                   (if (fboundp 'decode-coding-string)
 773                       (decode-coding-string (substring text data-beg data-end) cs)
 774                     (substring text data-beg data-end))
 775                   (XDecodeCompoundText (substring text data-end)))))
 776     text))
 777
 778 (defun XGetPropertyString (xdpy win atom)
 779   "On display XDPY, and window XWIN, get string property of type ATOM."
 780   (let ((propdata (XGetWindowProperty xdpy win atom 0 1024))
 781         (tdata nil)
 782         (retstring ""))
 783     (when (and propdata (setq tdata (nth 2 propdata)))
 784       (setq retstring tdata)
 785       (when (= (car propdata)
 786                (X-Atom-id (XInternAtom xdpy "COMPOUND_TEXT")))
 787         ;; Adjust RETSTRING in case of COMPOUND_TEXT
 788         (setq retstring (XDecodeCompoundText retstring)))
 789
 790       (when (> (nth 1 propdata) 0.0)
 791         (setq propdata
 792               (XGetWindowProperty xdpy win atom
 793                                   1024 (nth 0 propdata)))
 794         (when (and propdata (setq tdata (nth 2 propdata)))
 795           (if (= (car propdata)
 796                  (X-Atom-id (XInternAtom xdpy "COMPOUND_TEXT")))
 797               (setq retstring
 798                     (concat retstring (XDecodeCompoundText tdata)))
 799             (setq retstring (concat retstring tdata))))))
 800     retstring))
 801
 802 (defun XGetWMName (xdpy win)
 803   "On display XDPY, get window's WIN name."
 804   (XGetPropertyString xdpy win XA-wm-name))
 805
 806 (defun XGetWMCommand (xdpy win)
 807   "On display XDPY, get window's WIN WM_COMMAND."
 808   (let ((wmcmd (XGetPropertyString xdpy win XA-wm-command)))
 809     (if (> (length wmcmd) 0)
 810         (replace-in-string (substring wmcmd 0 (1- (length wmcmd))) (string 0) " ")
 811       wmcmd)))
 812
 813 (defun XGetWMClass (xdpy win)
 814   "On display XDPY, get window's WIN WM_CLASS."
 815   (let ((wmclass (XGetPropertyString xdpy win XA-wm-class)))
 816     (when wmclass
 817       (split-string wmclass (string 0)))))
 818
 819 (defun XGetWMRole (xdpy win)
 820   "On display XDPY return WM_WINDOW_ROLE property for XWIN."
 821   (XGetPropertyString xdpy win (XInternAtom xdpy "WM_WINDOW_ROLE" nil)))
 822
 823 (defun XGetWMClientLeader (xdpy win)
 824   "Get window property for WM_CLIENT_LEADER atom."
 825   nil)
 826
 827 (defun XGetWMTransientFor (xdpy win)
 828   "Get WM_TRANSIENT_FOR property.
 829 Returns list in form `(seq val window-for-wich-win-is-trasient)'."
 830   (let ((awid (XGetWindowProperty xdpy win XA-wm-transient-for 0 1 nil XA-window)))
 831     (when (and awid (= (car awid) (X-Atom-id XA-window)))
 832       (nth 2 awid))))
 833
 834 (defun XGetWMState (xdpy win)
 835   "On display XDPY get WM_STATE property for WIN."
 836   (let ((wmsa (XInternAtom xdpy "WM_STATE" nil)))
 837     (nth 2 (XGetWindowProperty xdpy win wmsa 0 2 wmsa))))
 838
 839 (defun XGetWMProtocols (xdpy win)
 840   "On display XDPY get WM_PROTOCOLS property for WIN."
 841   (cddr (XGetWindowProperty xdpy win  (XInternAtom xdpy "WM_PROTOCOLS" nil) 0 1024 nil XA-atom)))
 842
 843 (defun XWMProtocol-set-p (xdpy wmprotos name)
 844   "Return non-nil when atom with NAME is in WM_PROTOCOLS WMPROTO."
 845   (member* (XInternAtom xdpy name t) wmprotos :test 'X-Atom-equal))
 846
 847 ;;; Colormaps
 848 (defun XCreateColormap (xdpy win &optional v alloc)
 849   ;; checkdoc-params: (v alloc)
 850   "Create a colormap. Default values are:
 851
 852 VISUALID  - ID or CopyFromParent
 853 ALLOCATE  - All are writable (1) (0 -> none writable)
 854
 855 args (XDPY WIN &optional VISUALID ALLOCATE)"
 856   (X-Dpy-p xdpy 'XCreateColormap)
 857   (X-Win-p win 'XCreateColormap)
 858
 859   (let* ((ncmap (make-X-Colormap :dpy xdpy :id (X-Dpy-get-id xdpy)))
 860          (ListOfFields
 861           (list [1 78]                  ; opcode
 862                 [1 (or alloc X-AllocAll)] ; alloc type
 863                 [2 4]                   ; length
 864                 [4 (X-Colormap-id ncmap)] ; id to use
 865                 [4 (X-Win-id win)]      ; window id
 866                 [4 (X-Visual-id (or v (XDefaultVisual xdpy)))]))
 867          (msg (X-Create-message ListOfFields)))
 868     (X-Dpy-send xdpy msg)
 869     ncmap))
 870
 871 (defun XFreeColormap (xdpy cmap)
 872   "Frees a colormap CMAP.
 873 args (XDPY CMAP)"
 874   (X-Dpy-p xdpy 'XFreeColormap)
 875   (X-Colormap-p cmap 'XFreeColormap)
 876
 877   (let* ((ListOfFields
 878           (list [1 79]                  ; opcode
 879                 [1 nil]
 880                 [2 2]                   ; length
 881                 [4 (X-Colormap-id cmap)])) ; id to use
 882          (msg (X-Create-message ListOfFields)))
 883     (X-Dpy-send xdpy msg)
 884
 885     ;; Invalidate cmap structure so noone will longer use
 886     (X-invalidate-cl-struct cmap)))
 887
 888 (defun XInstallColormap (xdpy cmap)
 889   "Install colormap on xdpy."
 890   (X-Dpy-p xdpy 'XInstallColormap)
 891   (X-Colormap-p cmap 'XInstallColormap)
 892
 893   (let* ((ListOfFields
 894           (list [1 81]                  ; opcode
 895                 [1 nil]
 896                 [2 2]                   ; length
 897                 [4 (X-Colormap-id cmap)])) ; id to use
 898          (msg (X-Create-message ListOfFields)))
 899     (X-Dpy-send xdpy msg)))
 900
 901 (defun XUninstallColormap (xdpy cmap)
 902   "Uninstall colormap on xdpy."
 903   (X-Dpy-p xdpy 'XUninstallColormap)
 904   (X-Colormap-p cmap 'XUninstallColormap)
 905
 906   (let* ((ListOfFields
 907           (list [1 82]                  ; opcode
 908                 [1 nil]
 909                 [2 2]                   ; length
 910                 [4 (X-Colormap-id cmap)])) ; id to use
 911          (msg (X-Create-message ListOfFields)))
 912     (X-Dpy-send xdpy msg)))
 913
 914 (defun XListInstalledColormaps (xdpy xwin)
 915   "Return list of color maps installed on XWIN."
 916   (X-Dpy-p xdpy 'XListInstalledColormaps)
 917   (X-Win-p xwin 'XListInstalledColormaps)
 918
 919   (let ((ListOfFields
 920          (list [1 83]                   ; opcode
 921                [1 nil]
 922                [2 2]                    ; length
 923                [4 (X-Win-id xwin)]))    ; x window
 924         (ReceiveFields
 925          (list [1 success]              ; status message
 926                nil                      ; generic bad response
 927                (list [1 nil]            ; unused
 928                      [2 integerp]       ; sequence
 929                      [4 length-1]       ; reply length
 930                      [2 length-2]       ; number of Colormaps
 931                      [22 nil]           ; unused
 932                      [(* 4 length-2) integerp])))) ; cmaps
 933     (X-Dpy-send-read xdpy (X-Create-message ListOfFields) ReceiveFields)))
 934
 935 (defun XAllocColor (xdpy cmap color)
 936   "On display XDPY allocate in CMAP the color struct COLOR.
 937 Use `X-Color' to create.
 938 Returns non-nil if successful."
 939   (X-Dpy-p xdpy 'XAllocColor)
 940   (X-Colormap-p cmap 'XAllocColor)
 941   (X-Color-p color 'XAllocColor)
 942
 943   (let ((col (X-Colormap-lookup-by-rgb cmap color)))
 944     (if (X-Color-p col)
 945         col
 946
 947       (let* ((ListOfFields
 948               (list [1 84]              ; opcode
 949                     [1 nil]             ; unused
 950                     [2 4]               ; request length
 951                     [4 (X-Colormap-id cmap)] ; colormap handle
 952                     [2 (X-Color-red color)] ; red
 953                     [2 (X-Color-green color)] ; green
 954                     [2 (X-Color-blue color)] ; blue
 955                     [2 nil]))           ; padding
 956              (msg (X-Create-message ListOfFields))
 957              (ReceiveFields
 958               (list [1 success]         ; status message
 959                     nil                 ; generic bad response
 960                     (list [1 nil]       ; unused
 961                           [2 integerp]  ; sequence
 962                           [4 nil]       ; reply length
 963                           [2 integerp]  ; red
 964                           [2 integerp]  ; green
 965                           [2 integerp]  ; blue
 966                           [2 nil]       ; unused
 967                           [4 integerp]  ; pixel value
 968                           [12 nil])))   ; padding
 969              r)
 970         (setq r (X-Dpy-send-read xdpy msg ReceiveFields))
 971
 972         (if (car r)
 973             (progn
 974               (setf (X-Color-id color) (nth 5 r))
 975               (setf (X-Color-red color) (nth 2 r))
 976               (setf (X-Color-green color) (nth 3 r))
 977               (setf (X-Color-blue color) (nth 4 r))
 978               (setf (X-Color-cmap color) cmap)
 979
 980               (pushnew color (X-Colormap-colors cmap)) ; cache color
 981               color)
 982           nil)))))
 983
 984 (defun XAllocNamedColor (xdpy cmap name &optional color-exact)
 985   "Allocate a color based on the color struct COLOR-VISUAL and COLOR-EXACT.
 986 If COLOR-EXACT is nil or absent, ignore.
 987 args (DISPLAY CMAP NAME COLOR-VISUAL &optional COLOR-EXACT)"
 988   ;; checkdoc-order: nil
 989   (X-Dpy-p xdpy 'XAllocNamedColor)
 990   (X-Colormap-p cmap 'XAllocNamedColor)
 991
 992   (when color-exact
 993     (X-Color-p color-exact 'XAllocNamedColor))
 994
 995   (let ((col (X-Colormap-lookup-by-name cmap name)))
 996     (if (X-Color-p col)
 997         col
 998
 999       (let* ((ListOfFields
1000               (list [1 85]              ;opcode
1001                     [1 nil]
1002                     [2 (+ 3 (X-padlen name))] ;length
1003                     [4 (X-Colormap-id cmap)] ;colormap
1004                     [2 (length name)]   ;length of name
1005                     [2 nil]             ;unused
1006                     [(length name) name] ;the name
1007                     ));; autopadded
1008              (msg (X-Create-message ListOfFields))
1009              (ReceiveFields
1010               (list [1 success]         ;success field
1011                     nil
1012                     (list [1 nil]       ;unused
1013                           [2 integerp]  ;sequence
1014                           [4 nil]       ;length
1015                           [4 integerp]  ;pixel id
1016                           [2 integerp]  ;exact red
1017                           [2 integerp]  ;exact green
1018                           [2 integerp]  ;exact blue
1019                           [2 integerp]  ;visual red
1020                           [2 integerp]  ;visual green
1021                           [2 integerp]  ;visual blue
1022                           [8 nil])))    ;padding
1023              r)
1024         (setq r (X-Dpy-send-read xdpy msg ReceiveFields))
1025
1026         (if (car r)
1027             (progn
1028               (setq col (make-X-Color :dpy xdpy
1029                                       :id (nth 2 r)
1030                                       :red (nth 6 r)
1031                                       :green (nth 7 r)
1032                                       :blue (nth 8 r)
1033                                       :name name
1034                                       :cmap cmap))
1035
1036               (when color-exact
1037                 (setf (X-Color-id color-exact) (nth 2 r))
1038                 (setf (X-Color-red color-exact) (nth 3 r))
1039                 (setf (X-Color-green color-exact) (nth 4 r))
1040                 (setf (X-Color-blue color-exact) (nth 5 r))
1041                 (setf (X-Color-cmap color-exact) cmap))
1042
1043               (pushnew col (X-Colormap-colors cmap))
1044               col)
1045           nil))
1046       )))
1047
1048 (defun XAllocColorCells (xdpy cmap ncolors nplanes &optional contiguous)
1049   "On display XDPY allocate NCOLORS in colormap CMAP."
1050   (X-Dpy-p xdpy 'XAllocColorCells)
1051   (X-Colormap-p cmap 'XAllocColorCells)
1052
1053   (let* ((ListOfFields
1054           (list [1 86]                  ; opcode
1055                 [1 contiguous]
1056                 [2 3]                   ; length
1057                 [4 (X-Colormap-id cmap)]
1058                 [2 ncolors]
1059                 [2 nplanes]))
1060          (msg (X-Create-message ListOfFields))
1061          (ReceiveFields
1062           (list [1 success]
1063                 nil
1064                 (list [1 nil]
1065                       [2 integerp]      ;sequence
1066                       [4 integerp]      ; length
1067                       [2 length-1]      ; number of pixels
1068                       [2 length-2]      ; number of masks
1069                       [20 nil]
1070                       [length-1 ([4 integerp])]
1071                       [length-2 ([4 integerp])]))))
1072     (X-Dpy-send-read xdpy msg ReceiveFields)))
1073
1074 (defun XStoreColors (xdpy cmap colors)
1075   "On display XDPY in CMAP, store COLORS. (A list of 'X-Color)
1076 These colors are X-Color lists containing the PIXEL, RGB values and
1077 FLAGs (which indicates what part of the RGB value is stored into
1078 PIXEL's slot."
1079   (X-Dpy-p xdpy 'XStoreColors)
1080   (X-Colormap-p cmap 'XStoreColors)
1081
1082   (let* ((ListOfFields
1083           (list [1 89]                  ;opcode
1084                 [1 nil]                 ;unused
1085                 [2 (+ 2 (* 3 (length colors)))] ;request length
1086                 [4 (X-Colormap-id cmap)] ;COLORMAP
1087                 ))
1088          (msg (X-Create-message ListOfFields)))
1089     (while colors
1090       (setq msg (concat msg (X-Color-message (car colors)))
1091             colors (cdr colors)))
1092     (X-Dpy-send xdpy msg)))
1093
1094 (defun XStoreColor (xdpy cmap color &optional R G B)
1095   "On display XDPY in CMAP, store COLORS.
1096 These colors are X-Color lists containing the PIXEL, RGB values and
1097 FLAGs (which indicates what part of the RGB value is stored into
1098 PIXEL's slot.
1099   Optionally, COLOR can be a float, and it's new value indicated by
1100 the values of RGB, or X-Color and it will be stored as is."
1101   (XStoreColors
1102    xdpy cmap
1103    (if (X-Color-p color)
1104        (list color)
1105      (make-X-Color :id color
1106                    :red R
1107                    :green G
1108                    :blue B
1109                    :flags (Xmask-or (if R X-DoRed 0)
1110                                     (if G X-DoGreen 0)
1111                                     (if B X-DoBlue 0))))))
1112
1113 (defun XFreeColors (xdpy cmap colors planes)
1114   "On display XDPY in CMAP, free COLORS from the server.
1115 The colors are deallocated on PLANES, which is a mask.  Use 0 for
1116 PLANES if you don't know what it's for."
1117   (X-Dpy-p xdpy 'XFreeColors)
1118   (X-Colormap-p cmap 'XFreeColors)
1119
1120   (when (not (listp colors))
1121     (signal 'wrong-type-argument (list 'signal 'listp colors)))
1122   (mapc 'X-Colormap-p colors)
1123
1124   (let* ((ListOfFields
1125           (list [1 88]                  ;opcode
1126                 [1 nil]
1127                 [2 (+ 3 (length colors))];length
1128                 [4 (X-Colormap-id cmap)] ;Colormap
1129                 [4 planes]))            ;plane mask
1130          (msg (concat (X-Create-message ListOfFields)
1131                       (X-Generate-message-for-list
1132                        colors
1133                        #'(lambda (col) (int->string4 (X-Color-id col)))))))
1134     (X-Dpy-send xdpy msg)
1135
1136     ;; NOTE:
1137     ;;  - We should'nt invalidate colors, because they may be still
1138     ;;    used, FreeColors actually frees colors when there no any
1139     ;;    references to them.
1140 ;    ;; Invalidate each color.
1141 ;    (mapc 'X-invalidate-cl-struct colors)
1142     ))
1143
1144 (defun XQueryColors (xdpy cmap color-ids)
1145   "On display XDPY and colormap CMAP query COLOR-IDS."
1146   (X-Dpy-p xdpy 'XQueryColors)
1147   (X-Colormap-p cmap 'XQueryColors)
1148
1149   (let* ((ListOfFields
1150           (list [1 91]                  ;opcode
1151                 [1 nil]                 ;unused
1152                 [2 (+ 2 (length color-ids))] ;request length
1153                 [4 (X-Colormap-id cmap)] ;COLORMAP
1154                 ))
1155          (msg (concat (X-Create-message ListOfFields)
1156                       (X-Generate-message-for-list
1157                        color-ids
1158                        #'(lambda (colid) (int->string4 colid)))))
1159          (ReceiveFields
1160           (list [1 success]
1161                 nil
1162                 (list [1 nil]
1163                       [2 integerp]      ;sequence
1164                       [4 integerp]      ;reply length
1165                       [2 length-2]      ;number of rgbs
1166                       [22 nil]
1167                       [length-2
1168                        ([2 integerp]    ; red
1169                         [2 integerp]    ; green
1170                         [2 integerp]    ; blue
1171                         [2 nil])]
1172                       ))))
1173     (X-Dpy-send-read xdpy msg ReceiveFields)))
1174
1175 ;;; Graphical context operations
1176 ;;
1177 (defun XCreateGC (xdpy d gc)
1178   "Allocate a graphic context display XDPY on the drawable D.
1179 Base this new context on GC."
1180   (X-Dpy-p xdpy 'XCreateGC)
1181   (X-Drawable-p d 'XCreateGC)
1182   (X-Gc-p gc 'XCreateGC)
1183
1184   (let* ((attrmsg (X-Gc-message gc))
1185          (ListOfFields
1186           (list [1 55]                  ;opcode
1187                 [1 nil]                 ;unused
1188                 ;; 4 fields, but 1 is in attrmsg, making 3
1189                 [2 (+ 3 (/ (length attrmsg) 4))] ;request length
1190                 [4 (X-Gc-id gc)]        ;GC id
1191                 [4 (X-Drawable-id d)]   ;drawable id
1192                 ))
1193          (msg (concat (X-Create-message ListOfFields) attrmsg)))
1194     (X-Dpy-send xdpy msg)
1195
1196     ;; Seems lame, but return the GC we were passed originally.
1197     gc))
1198
1199 (defun XChangeGC (xdpy gc)
1200   "On display XDPY change GC to have new VALUES.
1201 I.e. update GC's info on server."
1202   (X-Dpy-p xdpy 'XChangeGC)
1203   (X-Gc-p gc 'XChangeGC)
1204
1205   (let* ((attrmsg (X-Gc-message gc))
1206          (ListOfFields
1207           (list [1 56]                  ;opcode
1208                 [1 nil]                 ;unused
1209                 [2 (+ 2 (/ (length attrmsg) 4))] ;request length
1210                 [4 (X-Gc-id gc)]        ;the GC
1211                 ))
1212          (msg (concat (X-Create-message ListOfFields) attrmsg)))
1213     (X-Dpy-send xdpy msg)
1214     ))
1215
1216 (defun XSetDashes (xdpy gc dash-offset dashes)
1217   "On display XDPY for GC set DASH-OFFSET and DASHES for dashed line styles."
1218   (X-Dpy-p xdpy 'XSetDashes)
1219   (X-Gc-p gc 'XSetDashes)
1220
1221   (let* ((dstr (apply 'concat (mapcar 'int->string1 dashes)))
1222          (ListOfFields
1223           (list [1 58]                  ;opcode
1224                 [1 nil]                 ;unused
1225                 [2 (+ 3 (X-padlen dstr))] ;request length
1226                 [4 (X-Gc-id gc)]        ;the GC
1227                 [2 dash-offset]
1228                 [2 (length dashes)]
1229                 ))
1230          (msg (concat (X-Create-message ListOfFields) dstr)))
1231     (X-Dpy-send xdpy msg)
1232     ))
1233
1234 (defun XSetClipRectangles (xdpy gc clip-x-origin clip-y-origin rectangles &optional order)
1235   "On display XDPY for GC change clip-mask according to CLIP-X-ORIGIN,
1236 CLIP-Y-ORIGIN and RECTANGLES.
1237
1238 You may specify ORDER to speed up X server, ORDER is one of
1239 `X-UnSorted', `X-YSorted', `X-YXSorted' or `X-YXBanded'."
1240   (X-Dpy-p xdpy 'XSetClipRectangles)
1241   (X-Gc-p gc 'XSetClipRectangles)
1242
1243   (unless order
1244     (setq order X-UnSorted))
1245
1246   (let* ((rstr (X-Generate-message-for-list rectangles 'X-Rect-message))
1247          (ListOfFields
1248           (list [1 59]                  ;opcode
1249                 (vector 1 order)        ;Ordeding to speedup X server
1250                 [2 (+ 3 (X-padlen rstr))] ;request length
1251                 [4 (X-Gc-id gc)]        ;the GC
1252                 [2 clip-x-origin]
1253                 [2 clip-y-origin]
1254                 ))
1255          (msg (concat (X-Create-message ListOfFields) rstr)))
1256     (X-Dpy-send xdpy msg)
1257     ))
1258
1259 (defun XFreeGC (xdpy gc)
1260   "Allocate a graphic context display XDPY on the drawable D.
1261 Base this new context on GC."
1262   (X-Dpy-p xdpy 'XFreeGC)
1263   (X-Gc-p gc 'XFreeGC)
1264
1265   (let* ((ListOfFields
1266           (list [1 60]                  ;opcode
1267                 [1 nil]
1268                 [2 2]                   ;length
1269                 [4 (X-Gc-id gc)]        ;GC id
1270                 ))
1271          (msg (X-Create-message ListOfFields)))
1272     (X-Dpy-send xdpy msg)
1273
1274     ;; Invalidate gc structure.
1275     (X-invalidate-cl-struct gc)
1276     ))
1277
1278 (defun XClearArea (xdpy win x y width height exposures)
1279   "On display XDPY in WIN clear rectangle X Y WIDTH HEIGHT."
1280   (X-Dpy-p xdpy 'XClearArea)
1281   (X-Win-p win 'XClearArea)
1282
1283   (let* ((ListOfFields
1284           (list [1 61]                  ;opcode
1285                 [1 exposures]           ;exposures
1286                 [2 4]                   ;length
1287                 [4 (X-Win-id win)]      ;window
1288                 [2 x]
1289                 [2 y]
1290                 [2 width]
1291                 [2 height]))
1292          (msg (X-Create-message ListOfFields)))
1293     (X-Dpy-send xdpy msg)))
1294
1295 (defun XCopyArea (xdpy src-d dst-d gc src-x src-y width height dst-x dst-y)
1296   "On display XDPY combine specified rectangle of SCR-D with DST-D."
1297   (X-Dpy-p xdpy 'XCopyArea)
1298   (X-Drawable-p src-d 'XCopyArea)
1299   (X-Drawable-p src-d 'XCopyArea)
1300
1301   (let* ((ListOfFields
1302           (list [1 62]                  ;opcode
1303                 [1 nil]
1304                 [2 7]                   ;length
1305                 [4 (X-Drawable-id src-d)] ; source drawable
1306                 [4 (X-Drawable-id dst-d)] ; destination drawable
1307                 [4 (X-Gc-id gc)]
1308                 [2 src-x]
1309                 [2 src-y]
1310                 [2 dst-x]
1311                 [2 dst-y]
1312                 [2 width]
1313                 [2 height]))
1314          (msg (X-Create-message ListOfFields)))
1315     (X-Dpy-send xdpy msg)))
1316
1317 (defmacro XCopyAreaRect (xdpy src-d dst-d gc src-rect dst-x dst-y)
1318   "Same as `XCopyArea' but rectangle specified by SRC-RECT."
1319   `(XCopyArea ,xdpy ,src-d ,dst-d ,gc
1320               (X-Rect-x ,src-rect) (X-Rect-y ,src-rect)
1321               (X-Rect-width ,src-rect) (X-Rect-height ,src-rect)
1322               ,dst-x ,dst-y))
1323
1324 (defun XCopyPlane (xdpy src-d dst-d gc src-x src-y width height dst-x dst-y bit-plane)
1325   "On display XDPY ..."
1326   (X-Dpy-p xdpy 'XCopyPlane)
1327   (X-Drawable-p src-d 'XCopyPlane)
1328   (X-Drawable-p src-d 'XCopyPlane)
1329
1330   (let* ((ListOfFields
1331           (list [1 63]                  ;opcode
1332                 [1 nil]
1333                 [2 8]                   ;length
1334                 [4 (X-Drawable-id src-d)] ; source drawable
1335                 [4 (X-Drawable-id dst-d)] ; destination drawable
1336                 [4 (X-Gc-id gc)]
1337                 [2 src-x]
1338                 [2 src-y]
1339                 [2 dst-x]
1340                 [2 dst-y]
1341                 [2 width]
1342                 [2 height]
1343                 [4 bit-plane]))
1344          (msg (X-Create-message ListOfFields)))
1345     (X-Dpy-send xdpy msg)))
1346
1347 (defmacro XCopyPlaneRect (xdpy src-d dst-d gc src-rect dst-x dst-y bit-plane)
1348   "Same as `XCopyPlane' but rectangle specified by SRC-RECT."
1349   `(XCopyPlane ,xdpy ,src-d ,dst-d ,gc
1350               (X-Rect-x ,src-rect) (X-Rect-y ,src-rect)
1351               (X-Rect-width ,src-rect) (X-Rect-height ,src-rect)
1352               ,dst-x ,dst-y ,bit-plane))
1353
1354 ;;; Drawing routines
1355 ;;
1356 (defun XDrawPoints (xdpy d gc pts &optional mode)
1357   "Draw points on a drawable. (XDPY D GC PTS &optional MODE)."
1358   (X-Dpy-p xdpy 'XDrawPoints)
1359   (X-Drawable-p d 'XDrawPoints)
1360   (X-Gc-p gc 'XDrawPoints)
1361
1362   (let* ((ListOfFields
1363           (list [1 64]                  ; opcode
1364                 [1 (or mode X-Origin)]  ; mode of drawing, shutup compiler
1365                 [2 (+ 3 (length pts))]  ; request length
1366                 [4 (X-Drawable-id d)]   ; drawable id
1367                 [4 (X-Gc-id gc)]))      ; id of the GC
1368          (msg (concat (X-Create-message ListOfFields)
1369                       (X-Generate-message-for-list pts 'X-Point-message))))
1370     (X-Dpy-send xdpy msg)))
1371
1372 (defun XDrawPoint (xdpy d gc x y)
1373   "Draw a point. (XDPY D GC X Y)."
1374   (XDrawPoints xdpy d gc (list (cons x y)) X-Origin))
1375
1376 (defun XDrawLines (xdpy d gc pts &optional mode)
1377   "Draw a multipoint line. (XDPY D GC PTS &optional MODE)."
1378   (X-Dpy-p xdpy 'XDrawLines)
1379   (X-Drawable-p d 'XDrawLines)
1380   (X-Gc-p gc 'XDrawLines)
1381
1382   (let* ((ListOfFields
1383           (list [1 65]                  ; opcode
1384                 [1 (or mode X-Origin)]  ; mode of drawing, shut up compiler
1385                 [2 (+ 3 (length pts))]  ; request length
1386                 [4 (X-Drawable-id d)]
1387                 [4 (X-Gc-id gc)]))
1388          (msg (concat (X-Create-message ListOfFields)
1389                       (X-Generate-message-for-list pts 'X-Point-message))))
1390     (X-Dpy-send xdpy msg)))
1391
1392 (defun XFillPoly (xdpy d gc pts &optional shape mode)
1393   "Fill poly."
1394   (X-Dpy-p xdpy 'XFillPoly)
1395   (X-Drawable-p d 'XFillPoly)
1396   (X-Gc-p gc 'XFillPoly)
1397
1398   (let* ((ListOfFields
1399           (list [1 69]                  ; opcode
1400                 [1 nil]                 ; unused
1401                 [2 (+ 4 (length pts))]  ; request length
1402                 [4 (X-Drawable-id d)]
1403                 [4 (X-Gc-id gc)]
1404                 [1 (or shape X-Nonconvex)]
1405                 [1 (or mode X-Origin)]
1406                 [2 nil]))               ; pad
1407          (msg (concat (X-Create-message ListOfFields)
1408                       (X-Generate-message-for-list pts 'X-Point-message))))
1409     (X-Dpy-send xdpy msg)))
1410
1411 (defun XDrawLine (xdpy d gc x y x2 y2)
1412   "Draw a line on display XDPY in drawable D.
1413 args (XDPY D GC X Y X2 Y2)."
1414   (XDrawLines xdpy d gc (list (cons x y) (cons x2 y2))))
1415
1416 (defun XDrawSegments (xdpy d gc xsegments)
1417   "Draw Segments. (XDPY D GC PTS &optional MODE).
1418 Drawing segments is different from lines in that segments are disconnected
1419 every other pair of points."
1420   (X-Dpy-p xdpy 'XDrawSegments)
1421   (X-Drawable-p d 'XDrawSegments)
1422   (X-Gc-p gc 'XDrawSegments)
1423
1424   (let* ((ListOfFields
1425           (list [1 66]                  ;opcode
1426                 [1 nil]
1427                 [2 (+ 3 (* 2 (length xsegments)))]
1428                 [4 (X-Drawable-id d)]
1429                 [4 (X-Gc-id gc)]))
1430          (msg (concat (X-Create-message ListOfFields)
1431                       (X-Generate-message-for-list xsegments 'X-Segment-message))))
1432     (X-Dpy-send xdpy msg)))
1433
1434 (defun XDrawRectangles (xdpy d gc rectangles &optional fill)
1435   "Draw rectangles. (XDPY D GC RECTANGLES &optional FILL)."
1436   (X-Dpy-p xdpy 'XDrawRectangles)
1437   (X-Drawable-p d 'XDrawRectangles)
1438   (X-Gc-p gc 'XDrawRectangles)
1439
1440   (let* ((ListOfFields
1441           (list [1 (if fill 70 67)]     ;opcode
1442                 [1 nil]                 ;mode of drawing
1443                 [2 (+ 3 (* (length rectangles) 2))] ; number of rects *2
1444                 [4 (X-Drawable-id d)]   ;drawable id
1445                 [4 (X-Gc-id gc)]))      ;id of the GC
1446          (msg (concat (X-Create-message ListOfFields)
1447                       (X-Generate-message-for-list rectangles 'X-Rect-message))))
1448     (X-Dpy-send xdpy msg)))
1449
1450 (defun XDrawRectangle (xdpy d gc x y width height)
1451   "Draw a rectangle. (XDPY D GC X Y WIDTH HEIGHT)."
1452   (XDrawRectangles xdpy d gc (list (make-X-Rect :x x :y y :width width :height height))))
1453
1454 (defun XFillRectangle (xdpy d gc x y width height)
1455   "Draw a rectangle. (XDPY D GC X Y WIDTH HEIGHT)."
1456   (XDrawRectangles xdpy d gc (list (make-X-Rect :x x :y y :width width :height height)) t))
1457
1458 (defun XFillRectangles (xdpy d gc rectangles)
1459   "Draw rectangles. (XDPY D GC RECTANGLES)."
1460   (XDrawRectangles xdpy d gc rectangles t))
1461
1462 (defun XDrawArcs (xdpy d gc xarcs &optional fill mode)
1463   "Draw arcs. (XDPY D GC ARCS &optional FILL)."
1464   (X-Dpy-p xdpy 'XDrawArcs)
1465   (X-Drawable-p d 'XDrawArcs)
1466   (X-Gc-p gc 'XDrawArcs)
1467
1468   (let* ((ListOfFields
1469           (list [1 (if fill 71 68)]     ;opcode
1470                 [1 mode]                ;mode of drawing
1471                 [2 (+ 3 (* 3 (length xarcs)))] ; number of arcs * 3
1472                 [4 (X-Drawable-id d)]   ;drawable id
1473                 [4 (X-Gc-id gc)]))      ;id of the GC
1474          (msg (concat (X-Create-message ListOfFields)
1475                       (X-Generate-message-for-list xarcs 'X-Arc-message))))
1476     (X-Dpy-send xdpy msg)))
1477
1478 (defun XDrawArc (xdpy d gc x y width height angle1 angle2 &optional fill mode)
1479   "Draw an arc on display XDPY in drawable D.
1480 args (DISPLAY D GC X Y WIDTH HEIGHT ANGLE1 ANGLE2)"
1481   (XDrawArcs xdpy d gc (list (make-X-Arc :x x :y y :width width :height height :angle1 angle1 :angle2 angle2)) fill))
1482
1483 (defun XFillArc (xdpy d gc x y width height angle1 angle2 &optional mode)
1484   "Draw a filled arc on display XDPY in drawable D.
1485 args (DISPLAY D GC X Y WIDTH HEIGHT ANGLE1 ANGLE2)"
1486   (XDrawArcs xdpy d gc (list (make-X-Arc :x x :y y :width width :height height :angle1 angle1 :angle2 angle2)) t mode))
1487
1488 (defun XFillArcs (xdpy d gc arcs &optional mode)
1489   "Draw filled arcs. (XDPY D GC ARCS)."
1490   (XDrawArcs xdpy d gc arcs t mode))
1491
1492 (defun XDrawString (xdpy d gc x y str &optional len)
1493   "Draw a string at specified point. (XDPY D GC X Y STR &optional LEN)."
1494   (X-Dpy-p xdpy 'XDrawString)
1495   (X-Drawable-p d 'XDrawString)
1496   (X-Gc-p gc 'XDrawString)
1497
1498   ;; Check len, must be < 255
1499   (when (or (and len (>= len 255))
1500             (>= (length str) 255))
1501     (setq str (substring str 0 254)))
1502
1503   (let* ((slen (if len len (length str))) ;make len optional
1504          (ListOfFields
1505           (list [1 74]                  ;opcode
1506                 [1 nil]                 ;unused
1507                 [2 (+ 4 (X-padlen (concat "12" str)))] ;length
1508                 [4 (X-Drawable-id d)]   ;drawable id
1509                 [4 (X-Gc-id gc)]        ;gc id
1510                 [2 x]
1511                 [2 y]
1512                 (vector 1 slen)         ;text length, shutup compiler
1513                 [1 0]                   ;delta????????
1514                 [slen str]              ;the string
1515                 ))
1516                 ;; auto-padding in X-create
1517          (msg (X-Create-message ListOfFields)))
1518     (X-Dpy-send xdpy msg)))
1519
1520 (defun XImageString (xdpy d gc x y str &optional len)
1521   "Draw a string using ImageText8 request.
1522 XDPY, D, GC, X, Y, STR and LEN are the same as in `XDrawString'."
1523   (X-Dpy-p xdpy 'XImageString)
1524   (X-Drawable-p d 'XImageString)
1525   (X-Gc-p gc 'XImageString)
1526
1527   (let* ((slen (if len len (length str))) ; make len optional
1528          (ListOfFields
1529           (list [1 76]                  ; opcode
1530                 (vector 1 slen)         ; string length, shutup compiler
1531                 [2 (+ 4 (/ (+ (X-pad slen) slen) 4))] ;length
1532                 [4 (X-Drawable-id d)]   ;drawable id
1533                 [4 (X-Gc-id gc)]        ;gc id
1534                 [2 x]
1535                 [2 y]
1536                 [slen str]
1537                 ))
1538           ;; auto-padding in X-create
1539          (msg (X-Create-message ListOfFields)))
1540     (X-Dpy-send xdpy msg)))
1541
1542 (defun XDrawText8 ()
1543   )
1544
1545 (defun XDrawText16 ()
1546   )
1547
1548 (defun XPutImage (xdpy d gc depth width height dst-x dst-y left-pad format data)
1549   "On display XDPY and drawable D, put an image."
1550   (X-Dpy-p xdpy 'XPutImage)
1551   (X-Drawable-p d 'XPutImage)
1552   (X-Gc-p gc 'XPutImage)
1553
1554   (let* ((ListOfFields
1555           (list [1 72]                  ; opcode
1556                 [1 format]
1557                 [2 (+ 6 (X-padlen data))]
1558                 [4 (X-Drawable-id d)]
1559                 [4 (X-Gc-id gc)]
1560                 [2 width]
1561                 [2 height]
1562                 [2 dst-x]
1563                 [2 dst-y]
1564                 [1 left-pad]
1565                 [1 depth]
1566                 [2 nil]
1567                 [(length data) data]
1568                 [(X-pad (length data)) nil]))
1569          (msg (X-Create-message ListOfFields)))
1570     (X-Dpy-send xdpy msg)))
1571
1572 (defun XGetImage (xdpy d x y width height plane-mask format)
1573   "On display XDPY and drawable D, get image with geometry WIDTHxHEIGHT+X+Y in FORMAT.
1574 PLANE-MASK is one of `X-AllPlanes' or something elese."
1575   (X-Dpy-p xdpy 'XGetImage)
1576   (X-Drawable-p d 'XGetImage)
1577
1578   (let* ((ListOfFields
1579           (list [1 73]                  ; opcode
1580                 [1 format]              ; format
1581                 [2 5]                   ; len
1582                 [4 (X-Drawable-id d)]   ; drawable
1583                 [2 x]
1584                 [2 y]
1585                 [2 width]
1586                 [2 height]
1587                 [4 plane-mask]))
1588          (msg (X-Create-message ListOfFields))
1589          (ReceiveFields
1590           (list [1 success]
1591                 nil
1592                 (list [1 integerp]      ; depth
1593                       [2 integerp]      ; sequence
1594                       [4 length-1]      ; length
1595                       [4 integerp]      ; visual id or X-None
1596                       [20 nil]          ; not used
1597                       [(* length-1 4) stringp]))))      ;data
1598     (X-Dpy-send-read xdpy msg ReceiveFields)))
1599 ;                     [(X-mod-4 length-1) nil])))) ; padding
1600
1601 ;;; Selections operations
1602 (defun XSetSelectionOwner (xdpy selection-atom &optional owner-win time)
1603   "Set SELECTION-ATOM to be owned by OWNER-WIN."
1604   (X-Dpy-p xdpy 'XSetSelectionOwner)
1605
1606   (let* ((ListOfFields
1607           (list [1 22]                  ;opcode
1608                 [1 nil]                 ;unused
1609                 [2 4]                   ;length
1610                 [4 (if owner-win (X-Win-id owner-win) X-None)] ;owner window
1611                 [4 (X-Atom-id selection-atom)] ; selection atom
1612                 [4 (if time time X-CurrentTime)]))
1613          (msg (X-Create-message ListOfFields)))
1614     (X-Dpy-send xdpy msg)))
1615
1616 (defun XGetSelectionOwner (xdpy selection-atom)
1617   "Get owner of SELECTION-ATOM on display XDPY.
1618 Returns nil or X-Win structure."
1619   (X-Dpy-p xdpy 'XGetSelectionOwner)
1620
1621   (let* ((ListOfFields
1622           (list [1 23]                  ;opcode
1623                 [1 nil]                 ;unused
1624                 [2 2]                   ;length
1625                 [4 (X-Atom-id selection-atom)])) ;selection atom
1626          (msg (X-Create-message ListOfFields))
1627          (ReceiveFields
1628           (list [1 success]             ;success field
1629                 nil
1630                 (list [1 nil]           ;unused
1631                       [2 integerp]      ;sequence
1632                       [4 nil]           ;length
1633                       [4 integerp]      ;owner window
1634                       [20 nil])))       ;pad
1635          r win)
1636     (setq r (X-Dpy-send-read xdpy msg ReceiveFields))
1637     (when (car r)
1638       (setq win (X-Win-find-or-make xdpy (nth 2 r))))
1639     win))
1640
1641 (defun XConvertSelection (xdpy selection target prop requestor &optional time)
1642   "ConvertSelection."
1643   (X-Dpy-p xdpy 'XConvertSelection)
1644
1645   (let* ((ListOfFields
1646           (list [1 24]                  ;opcode
1647                 [1 nil]                 ;unused
1648                 [2 6]                   ;length
1649                 [4 (if requestor (X-Win-id requestor) X-None)] ;owner window
1650                 [4 (X-Atom-id selection)] ; selection atom
1651                 [4 (X-Atom-id target)]  ; target atom
1652                 [4 (if prop (X-Atom-id prop) X-None)] ; property atom
1653                 [4 (or time X-CurrentTime)]))
1654          (msg (X-Create-message ListOfFields)))
1655     (X-Dpy-send xdpy msg)))
1656
1657 ;;; Warping
1658 (defun XWarpPointer (xdpy src-win dst-win src-x src-y src-width src-height dest-x dest-y)
1659   "On display XDPY warp pointer to DEST-X DEST-Y"
1660   (X-Dpy-p xdpy 'XWarpPointer)
1661 ;  (X-Win-p src-win 'XWarpPointer)
1662 ;  (X-Win-p dst-win 'XWarpPointer)
1663
1664   (let* ((srcid (or (and (X-Win-p src-win) (X-Win-id src-win)) src-win))
1665          (dstid (or (and (X-Win-p dst-win) (X-Win-id dst-win)) dst-win))
1666          (ListOfFields
1667           (list [1 41]                  ; opcode
1668                 [1 nil]                 ; unused
1669                 [2 6]                   ; length
1670                 (vector 4 srcid)        ; source window
1671                 (vector 4 dstid)        ; dst window
1672                 [2 src-x]               ;
1673                 [2 src-y]               ;
1674                 [2 src-width]
1675                 [2 src-height]
1676                 [2 dest-x]
1677                 [2 dest-y]))
1678          (msg (X-Create-message ListOfFields)))
1679     (X-Dpy-send xdpy msg)))
1680
1681 ;;; Grabbing
1682 (defun XGrabServer (xdpy)
1683   "Grabs X server on display XDPY"
1684   (X-Dpy-p xdpy 'XGrabServer)
1685
1686   (let* ((ListOfFields
1687           (list [1 36]                  ;opcode
1688                 [1 nil]                 ;unused
1689                 [2 1]))                 ;length
1690          (msg (X-Create-message ListOfFields)))
1691     (X-Dpy-send xdpy msg)))
1692
1693 (defun XUngrabServer (xdpy)
1694   "Ungrab X server on display XDPY."
1695   (X-Dpy-p xdpy 'XUngrabServer)
1696
1697   (let* ((ListOfFields
1698           (list [1 37]                  ;opcode
1699                 [1 nil]                 ;unused
1700                 [2 1]))                 ;length
1701          (msg (X-Create-message ListOfFields)))
1702     (X-Dpy-send xdpy msg)))
1703
1704 (defun XQueryPointer (xdpy xwin)
1705   "In display XDPY and window XWIN query pointer position."
1706   (X-Dpy-p xdpy 'XQueryPointer)
1707
1708   (let* ((ListOfFields
1709           (list [1 38]                  ; opcode
1710                 [1 nil]                 ; unused
1711                 [2 2]                   ; length
1712                 [4 (X-Win-id xwin)]))
1713          (msg (X-Create-message ListOfFields))
1714          (ReceiveFields
1715           (list [1 success]             ;success field
1716                 nil
1717                 (list [1 integerp]      ; same-screen
1718                       [2 integerp]      ; sequence
1719                       [4 nil]           ; length
1720                       [4 :X-Win]        ; root
1721                       [4 :X-Win]        ; child
1722                       [2 integerp]      ; root-x
1723                       [2 integerp]      ; root-y
1724                       [2 integerp]      ; win-x
1725                       [2 integerp]      ; win-y
1726                       [2 integerp]      ; mask
1727                       [6 nil]))))
1728     (X-Dpy-send-read xdpy msg ReceiveFields)))
1729
1730 (defun XGrabKeyboard (xdpy grab-win &optional owe pmode kmode time)
1731   "On display XDPY in window GRAB-WIN start grabbing keyboard.
1732 OWE - owner events (default `nil')
1733 PMODE - Pointer grabbing mode (default `X-GrabModeAsync')
1734 KMODE - Keyboard grabbing mode (default `X-GrabModeAsync')
1735 TIME - Time when start to grab (default `X-CurrentTime')"
1736   (X-Dpy-p xdpy 'XGrabKeyboard)
1737   (X-Win-p grab-win 'XGrabKeyboard)
1738
1739   (let* ((ListOfFields
1740           (list [1 31]                  ; opcode
1741                 [1 owe]                 ; owner_events
1742                 [2 4]                   ; length
1743                 [4 (X-Win-id grab-win)] ; grab window
1744                 [4 (or time X-CurrentTime)] ; time
1745                 [1 (or pmode X-GrabModeAsync)] ; pointer mode
1746                 [1 (or kmode X-GrabModeAsync)] ; keyboard mode
1747                 [2 nil]))               ; pad
1748          (msg (X-Create-message ListOfFields))
1749          (ReceiveFields
1750           (list [1 success]             ;success field
1751                 nil
1752                 (list [1 integerp]      ;status
1753                       [2 integerp]      ;sequence
1754                       [4 integerp]      ;length . Hmm length-1
1755                       [24 nil]))))      ;pad
1756 ;                     [length-1
1757 ;                      ([4 nil]) ]))))  ;pad
1758     (X-Dpy-send-read xdpy msg ReceiveFields)))
1759
1760 (defun XUngrabKeyboard (xdpy &optional time)
1761   "On display XDPY at TIME stop grabbing keyboard.
1762 Default TIME is `X-CurrentTime'."
1763   (X-Dpy-p xdpy 'XUngrabKeyboard)
1764
1765   (let* ((ListOfFields
1766           (list [1 32]                  ; opcode
1767                 [1 nil]                 ; owner_events
1768                 [2 2]                   ;length
1769                 [4 (if time time X-CurrentTime)]))
1770          (msg (X-Create-message ListOfFields)))
1771     (X-Dpy-send xdpy msg)))
1772
1773 (defun XGrabPointer (xdpy grab-win ev-mask &optional cursor owe pmode kmode confto-win time)
1774   "On display XDPY in window GRAB-WIN start grabbing pointer.
1775 CURSOR - Cursor to use while grabbing.
1776 EV-MASK - Mask for events to receive. Result of `Xmask-or'.
1777 OWE - owner events (default `nil')
1778 PMODE - Pointer grabbing mode (default `X-GrabModeAsync')
1779 KMODE - Keyboard grabbing mode (default `X-GrabModeAsync')
1780 CONFTO-WIN - Confine to window (default `nil'
1781 TIME - Time when start to grab (default `X-CurrentTime')"
1782   (X-Dpy-p xdpy 'XGrabPointer)
1783   (X-Win-p grab-win 'XGrabPointer)
1784
1785   (let* ((ListOfFields
1786           (list [1 26]                  ;opcode
1787                 [1 owe]
1788                 [2 6]
1789                 [4 (X-Win-id grab-win)] ;grab window
1790                 [2 ev-mask]             ;event mask
1791                 [1 (or pmode X-GrabModeAsync)] ;pointerMode
1792                 [1 (or kmode X-GrabModeAsync)] ;keyboardMode
1793                 [4 (if confto-win (X-Win-id confto-win) 0.0)] ;confineTo window
1794                 [4 (if cursor (X-Cursor-id cursor) 0.0)] ;Cursor
1795                 [4 (or time X-CurrentTime)]))
1796          (msg (X-Create-message ListOfFields))
1797          (ReceiveFields
1798           (list [1 success]
1799                 nil
1800                 (list [1 nil]           ;unsed
1801                       [2 integerp]      ;sequence
1802                       [28 nil]))))      ;padding
1803     (X-Dpy-send-read xdpy msg ReceiveFields)))
1804
1805 (defun XUngrabPointer (xdpy &optional time)
1806   "On display XDPY at TIME, stop grabbing pointer."
1807   (X-Dpy-p xdpy 'XUngrabPointer)
1808
1809   (let* ((ListOfFields
1810           (list [1 27]                  ;opcode
1811                 [1 nil]
1812                 [2 2]
1813                 [4 (or time X-CurrentTime)]))
1814          (msg (X-Create-message ListOfFields)))
1815     (X-Dpy-send xdpy msg)))
1816
1817 (defun XGrabButton (xdpy button mods grab-win ev-mask &optional cursor owe pmode kmode conf-to)
1818   "On display XDPY in window GRAB-WIN, start grabbing for BUTTON with MODS.
1819 TODO: Describe optional arguments."
1820   (X-Dpy-p xdpy 'XGrabButton)
1821   (X-Win-p grab-win 'XGrabButton)
1822
1823   (let* ((ListOfFields
1824           (list [1 28]                  ; opcode
1825                 [1 (if owe owe nil)]
1826                 [2 6]
1827                 [4 (X-Win-id grab-win)]
1828                 [2 ev-mask]
1829                 [1 (or pmode X-GrabModeAsync)]
1830                 [1 (or kmode X-GrabModeAsync)]
1831                 [4 (if conf-to (X-Win-id conf-to) 0.0)]
1832                 [4 (if cursor (X-Cursor-id cursor) 0.0)]
1833                 [1 button]
1834                 [1 nil]                 ; pad
1835                 [2 mods]))
1836          (msg (X-Create-message ListOfFields)))
1837     (X-Dpy-send xdpy msg)))
1838
1839 (defun XUngrabButton (xdpy button mods grab-win)
1840   "On display XDPY in window GRAB-WIN stop grabbing for BUTTON with MODS."
1841   (X-Dpy-p xdpy 'XUngrabButton)
1842   (X-Win-p grab-win 'XUngrabButton)
1843
1844   (let* ((ListOfFields
1845           (list [1 29]                  ; opcode
1846                 [1 button]
1847                 [2 3]                   ; length
1848                 [4 (X-Win-id grab-win)]
1849                 [2 mods]
1850                 [2 nil]))               ; pad
1851          (msg (X-Create-message ListOfFields)))
1852     (X-Dpy-send xdpy msg)))
1853
1854 (defun XGrabKey (xdpy keycode mods grab-win &optional owe pmode kmode)
1855   "On display XDPY in window GRAB-WIN start grabbing for KEYCODE with MODS.
1856 TODO: Description for OWE, PMODE and KMODE."
1857   (X-Dpy-p xdpy 'XGrabKey)
1858   (X-Win-p grab-win 'XGrabKey)
1859
1860   (let ((ListOfFields `([1 33]          ; opcode
1861                         [1 ,owe]       ; owner_events
1862                         [2 4]          ; length
1863                         [4 ,(X-Win-id grab-win)] ; grab window
1864                         [2 ,mods]      ; modifiers
1865                         [1 ,keycode]   ; key
1866                         [1 ,(or pmode X-GrabModeAsync)] ; pointer mode
1867                         [1 ,(or kmode X-GrabModeAsync)] ; keyboard mode
1868                         [3 nil])))      ; pad
1869     (X-Dpy-send xdpy (X-Create-message ListOfFields))))
1870
1871 (defun XUngrabKey (xdpy keycode mods grab-win)
1872   "On display XDPY in window GRAB-WIN stop grabbing KEYCODE with MODS."
1873   (X-Dpy-p xdpy 'XUngrabKey)
1874   (X-Win-p grab-win 'XUngrabKey)
1875
1876   (let* ((ListOfFields
1877           (list [1 34]                  ; opcode
1878                 [1 keycode]             ; keycode
1879                 [2 3]                   ; length
1880                 [4 (X-Win-id grab-win)] ; grab window
1881                 [2 mods]                ; modifiers
1882                 [2 nil]))               ; pad
1883          (msg (X-Create-message ListOfFields)))
1884     (X-Dpy-send xdpy msg)))
1885
1886 (defun XAllowEvents (xdpy mode &optional time)
1887   "On display XDPY allow events in MODE."
1888   (X-Dpy-p xdpy 'XAllowEvents)
1889
1890   (let* ((ListOfFields
1891           (list [1 35]
1892                 [1 mode]
1893                 [2 2]
1894                 [4 (or time X-CurrentTime)]))
1895          (msg (X-Create-message ListOfFields)))
1896     (X-Dpy-send xdpy msg)))
1897
1898
1899 ;;; Focusing
1900 (defun XGetInputFocus (xdpy)
1901   "On display XDPY get curret input focus."
1902   (X-Dpy-p xdpy 'XGetInputFocus)
1903
1904   (let* ((ListOfFields
1905           (list [1 43]                  ;opcode
1906                 [1 nil]                 ;unused
1907                 [2 1]))                 ;length
1908          (msg (X-Create-message ListOfFields))
1909          (ReceiveFields
1910           (list [1 success]
1911                 nil
1912                 (list [1 integerp]      ;revertTo
1913                       [2 integerp]      ;sequence
1914                       [4 nil]           ;length
1915                       [4 integerp]      ;focus win
1916                       [20 nil])))       ;pad
1917          r thing)
1918     (setq r (X-Dpy-send-read xdpy msg ReceiveFields))
1919
1920     (when (car r)
1921       (if (member (nth 3 r) (list X-PointerRoot X-None))
1922           (setq thing (nth 3 r))
1923         (setq thing (X-Win-find xdpy (nth 3 r)))))
1924     thing))
1925
1926 (defun XSetInputFocus (xdpy win-or-val rev-to &optional time)
1927   "On display XDPY set input focus to window WIN-OR-VAL.
1928 REV-TO - Focus revert to when WIN-OR-VAL will lost input focus.
1929 TIME - Set input focus at this time (default `X-CurrentTime')"
1930   (X-Dpy-p xdpy 'XSetInputFocus)
1931
1932   (let* ((ListOfFields
1933           (list [1 42]                  ; opcode
1934                 [1 rev-to]              ; Revert to
1935                 [2 3]                   ; length
1936                 [4 (cond ((integerp win-or-val) win-or-val) ;X-PointerRoot, X-None, etc
1937                          ((X-Win-p win-or-val) (X-Win-id win-or-val)) ;window
1938                          (t nil))]      ; X-None
1939                 [4 time]))              ; time
1940          (msg (X-Create-message ListOfFields)))
1941     (X-Dpy-send xdpy msg)))
1942
1943 ;;; Misc requests
1944 (defun XReparentWindow (xdpy win parwin x y)
1945   "On display XDPY reparent window WIN to PARWIN at X Y."
1946   (X-Dpy-p xdpy 'XReparentWindow)
1947   (X-Win-p win 'XReparentWindow)
1948   (X-Win-p parwin 'XReparentWindow)
1949
1950   (let* ((ListOfFields
1951           (list [1 7]                   ;opcode
1952                 [1 nil]                 ;pad
1953                 [2 4]                   ;length
1954                 [4 (X-Win-id win)]      ;win
1955                 [4 (X-Win-id parwin)]   ;parent window
1956                 [2 x]                   ;x
1957                 [2 y]))                 ;y
1958          (msg (X-Create-message ListOfFields)))
1959     (X-Dpy-send xdpy msg)))
1960
1961 (defun XGetGeometry (xdpy d)
1962   "On display XDPY return geomtry for drawable D.
1963 Side effect of this function is to set 'xdepth property in drawable
1964 D."
1965   (X-Dpy-p xdpy 'XGetGeometry)
1966   (X-Drawable-p d 'XGetGeometry)
1967
1968   (let* ((ListOfFields
1969           (list [1 14]                  ;opcode
1970                 [1 nil]                 ;pad
1971                 [2 2]                   ;length
1972                 [4 (X-Drawable-id d)])) ;chars in string
1973          (msg (X-Create-message ListOfFields))
1974          (ReceiveFields
1975           (list [1 success]
1976                 nil
1977                 (list [1 integerp]      ;depth
1978                       [2 integerp]      ;sequence
1979                       [4 nil]           ;length
1980                       [4 integerp]      ;root
1981                       [2 integerp]      ;x
1982                       [2 integerp]      ;y
1983                       [2 integerp]      ;width
1984                       [2 integerp]      ;height
1985                       [2 integerp]      ;border width
1986                       [10 nil])))       ;pad
1987          r rgeom)
1988     (setq r (X-Dpy-send-read xdpy msg ReceiveFields))
1989     (when (car r)
1990       (if (X-Win-p d)
1991           (X-Win-put-prop d 'xdepth (nth 1 r))
1992         (X-Pixmap-put-prop d 'xdepth (nth 1 r)))
1993       (setq rgeom (make-X-Geom :x (nth 4 r)
1994                                :y (nth 5 r)
1995                                :width (nth 6 r)
1996                                :height (nth 7 r)
1997                                :border-width (nth 8 r))))
1998     rgeom))
1999
2000 (defun XGetDepth (xdpy d)
2001   "On display xdpy return drawable's D depth."
2002   (or (if (X-Win-p d)
2003           (X-Win-get-prop d 'xdepth)
2004         (X-Pixmap-get-prop d 'xdepth))
2005       (progn
2006         (XGetGeometry xdpy d)
2007         (if (X-Win-p d)
2008             (X-Win-get-prop d 'xdepth)
2009           (X-Pixmap-get-prop d 'xdepth)))))
2010
2011 ;; TODO: XTranslateCoordinates
2012 (defun XTranslateCoordinates (xdpy src-win dst-win src-x src-y)
2013   "On display XDPY translate SCR-X SCR-y coordinates to coordinates on DST-WIN."
2014   (X-Dpy-p xdpy 'XTranslateCoordinates)
2015   (X-Win-p src-win 'XTranslateCoordinates)
2016   (X-Win-p dst-win 'XTranslateCoordinates)
2017
2018   (let* ((ListOfFields
2019           (list [1 40]                  ;opcode
2020                 [1 nil]                 ;pad
2021                 [2 4]                   ;length
2022                 [4 (X-Win-id src-win)]  ;source win
2023                 [4 (X-Win-id dst-win)]  ;destination win
2024                 [2 src-x]
2025                 [2 src-y]))
2026          (msg (X-Create-message ListOfFields))
2027          (ReceiveFields
2028           (list [1 success]
2029                 nil
2030                 (list [1 booleanp]      ;same-screen
2031                       [2 integerp]      ;sequence
2032                       [4 nil]           ;length
2033                       [4 :X-Win]        ;child
2034                       [2 integerp]      ;dst-x
2035                       [2 integerp]      ;dst-y
2036                       [16 nil])))       ;pad
2037          r)
2038     (setq r (X-Dpy-send-read xdpy msg ReceiveFields))
2039     (if (car r)
2040         (cons (cons (nth 4 r) (nth 5 r)) (nth 3 r))
2041       nil)))
2042
2043 (defun XChangeSaveSet (xdpy win change-mode)
2044   "On display XDPY change SaveSet according to CHANGE-MODE."
2045   (X-Dpy-p xdpy 'XChangeSaveSet)
2046   (X-Win-p win 'XChangeSaveSet)
2047
2048   (let* ((ListOfFields
2049           (list [1 6]                   ; opcode
2050                 [1 change-mode]
2051                 [2 2]                   ;length
2052                 [4 (X-Win-id win)]))
2053          (msg (X-Create-message ListOfFields)))
2054     (X-Dpy-send xdpy msg)))
2055
2056 (defun XSendEvent (xdpy win propogate ev_mask xevent)
2057   "WIN is X11 window or one of X-InputFocus, X-XXXxxxXXX.
2058 Evil hack, do not use this function."
2059   (X-Dpy-p xdpy 'XSendEvent)
2060
2061   (let* ((ListOfFields
2062           (list [1 25]                  ; opcode
2063                 [1 propogate]
2064                 [2 11] ;(+ 3 (X-padlen xevent))] ;length
2065                 [4 (if (X-Win-p win) (X-Win-id win) win)]
2066                 [4 ev_mask]))           ;event mask
2067          (padding (make-string (- 44 12 (length xevent)) 0))
2068          (msg (concat (X-Create-message ListOfFields) xevent padding)))
2069     (X-Dpy-send xdpy msg)))
2070
2071
2072 ;;; Keyboard mapping
2073 (defun XQueryKeymap (xdpy)
2074   "On display XDPY query keyboard mapping."
2075   (X-Dpy-p xdpy 'XQueryKeymap)
2076
2077   (let* ((ListOfFields
2078           (list [1 44]                  ;opcode
2079                 [1 nil]                 ;pad
2080                 [2 1]))                 ;length
2081          (msg (X-Create-message ListOfFields))
2082          (ReceiveFields
2083           (list [1 success]
2084                 nil
2085                 (list [1 nil]           ;unused
2086                       [2 integerp]      ;sequence
2087                       [4 integerp]      ;length
2088                       [32 nil]))))      ;unknown
2089
2090     (X-Dpy-send-read xdpy msg ReceiveFields)))
2091
2092 (defun XGetKeyboardMapping (xdpy keycode count)
2093   "On display XDPY get keyboard mapping."
2094   (X-Dpy-p xdpy 'XGetKeyboardMapping)
2095
2096   (let* ((ListOfFields
2097           (list [1 101]                 ;opcode
2098                 [1 nil]                 ;pad
2099                 [2 2]                   ;length
2100                 [1 keycode]             ;first_keycode
2101                 [1 count]               ;count
2102                 [2 nil]))               ;pad
2103          (msg (X-Create-message ListOfFields))
2104          (ReceiveFields
2105           (list [1 success]
2106                 nil
2107                 (list [1 length-1]      ;keySymsPerKeyCode
2108                       [2 integerp]      ;sequence
2109                       [4 length-2]      ;length
2110                       [24 nil]          ;pad
2111                       [count            ;list of the children
2112                        (make-list length-1 [4 integerp])]))))
2113
2114     (X-Dpy-send-read xdpy msg ReceiveFields)))
2115
2116 (defun XGetModifierMapping (xdpy)
2117   "On display XDPY get modifiers mapping."
2118   (X-Dpy-p xdpy 'XGetModifierMapping)
2119
2120   (let* ((ListOfFields
2121           (list [1 119]                 ;opcode
2122                 [1 nil]                 ;pad
2123                 [2 1]))                 ;length
2124          (msg (X-Create-message ListOfFields))
2125          (ReceiveFields
2126           (list [1 success]
2127                 nil
2128                 (list [1 length-2]      ;numKeyPerModifier
2129                       [2 integerp]      ;sequence
2130                       [4 length-1]      ;length
2131                       [4 integerp]      ;pad
2132                       [4 integerp]      ;pad
2133                       [4 integerp]      ;pad
2134                       [4 integerp]      ;pad
2135                       [4 integerp]      ;pad
2136                       [4 integerp]      ;pad
2137                       [(/ (* length-1 4) length-2) ;list of the children
2138                        (make-list length-2 [1 integerp])]))))
2139
2140     (X-Dpy-send-read xdpy msg ReceiveFields)))
2141
2142 ;;; Fonts supoprt
2143 (defun XOpenFont (xdpy font)
2144   "On display XDPY open FONT, created using `X-Font'."
2145   (X-Dpy-p xdpy 'XOpenFont)
2146   (X-Font-p font 'XOpenFont)
2147
2148   (let* ((name (X-Font-name font))
2149          (ListOfFields
2150           (list [1 45]                  ; opcode
2151                 [1 nil]                 ;pad
2152                 [2 (+ 3 (X-padlen name))] ;length
2153                 [4 (X-Font-id font)]
2154                 [2 (length name)]
2155                 [2 nil]))               ;pad
2156          (msg (concat (X-Create-message ListOfFields) name (make-string (- (* 4 (X-padlen name)) (length name)) ?\0))))
2157     (X-Dpy-send xdpy msg)))
2158
2159 (defun XQueryFont (xdpy font)
2160   "On display XDPY query for FONT."
2161   (X-Dpy-p xdpy 'XQueryFont)
2162
2163   (let* ((ListOfFields
2164           (list [1 47]                  ; opcode
2165                 [1 nil]
2166                 [2 2]                   ;length
2167                 [4 (X-Font-id font)]))
2168          (msg (X-Create-message ListOfFields))
2169          (ReceiveFields
2170           (list [1 success]             ;success field
2171                 nil
2172                 (list [1 nil]           ;unused
2173                       [2 integerp]      ;sequence
2174                       [4 length-1]      ;length
2175
2176                       ;; xCharInfo minBounds and maxBounds
2177                       [2 ([2 integerp]  ;leftSideBearing
2178                           [2 integerp]  ;rightSideBearing
2179                           [2 integerp]  ;characterWidth
2180                           [2 integerp]  ;ascent
2181                           [2 integerp]  ;descent
2182                           [2 integerp]  ;attributes
2183                           [4 nil])]     ;walign
2184
2185                       [2 integerp]      ;minCharOrByte2
2186                       [2 integerp]      ;maxCharOrByte2
2187                       [2 integerp]      ;defaultChar
2188                       [2 length-2]      ;nFontProps
2189                       [1 integerp]      ;drawDirection
2190                       [1 integerp]      ;minByte1
2191                       [1 integerp]      ;maxByte1
2192                       [1 booleanp]      ;allCharsExist
2193                       [2 integerp]      ;fontAscent
2194                       [2 integerp]      ;fontDescent
2195                       [4 length-3]      ;nCharInfos
2196
2197                       ;; FontProps
2198                       [length-2 ([4 integerp] ;atom name
2199                                  [4 integerp])] ;value
2200
2201                       ;; Character info
2202                       [length-3 ([2 integerp] ; leftSideBearing
2203                                  [2 integerp] ; rightSideBearing
2204                                  [2 integerp] ; characterWidth
2205                                  [2 integerp] ; ascent
2206                                  [2 integerp] ; descent
2207                                  [2 integerp])] ; attributes
2208                       )))
2209          r)
2210     (setq r (X-Dpy-send-read xdpy msg ReceiveFields))
2211
2212     (if (car r)
2213         (let ((bounds (nth 2 r))
2214               (props (nth 12 r))
2215               (chinfo (nth 13 r)))
2216
2217           (setf (X-Font-minb font) (vconcat (nth 0 bounds)))
2218           (setf (X-Font-maxb font) (vconcat (nth 1 bounds)))
2219           (setf (X-Font-micob font) (nth 3 r))
2220           (setf (X-Font-macob font) (nth 4 r))
2221           (setf (X-Font-defchar font) (nth 5 r))
2222           (setf (X-Font-nprops font) (length props))
2223           (setf (X-Font-dd font) (nth 6 r))
2224           (setf (X-Font-minbyte font) (nth 7 r))
2225           (setf (X-Font-maxbyte font) (nth 8 r))
2226           (setf (X-Font-allce font) (nth 9 r))
2227           (setf (X-Font-fontascent font) (nth 10 r))
2228           (setf (X-Font-fontdescent font) (nth 11 r))
2229           (setf (X-Font-ncinfo font) (length chinfo))
2230           (setf (X-Font-props font) (vconcat (mapcar 'vconcat props)))
2231           (setf (X-Font-chinfo font) (vconcat (mapcar 'vconcat chinfo)))
2232           t)
2233       nil)))
2234
2235 (defun XQueryTextExtents (xdpy font string)
2236   "On display XDPY fetch FONT's info for STRING."
2237   (X-Dpy-p xdpy 'XQueryTextExtents)
2238   (X-Font-p font 'XQueryTextExtents)
2239
2240   (let* ((ListOfFields
2241           (list [1 48]                  ; opcode
2242                 [1 (% (length string) 2)] ;oddLength
2243                 [2 (+ 2 (X-padlen (concat string string)))] ;length
2244                 [4 (X-Font-id font)]))
2245          (msg (concat (X-Create-message ListOfFields)
2246                       (apply 'concat
2247                              (mapcar #'(lambda (c) (string ?\0 c)) string))
2248                       (when (> (% (length string) 2) 0) (make-string 2 ?\0))
2249                       ))
2250          (ReceiveFields
2251           (list [1 success]             ;success field
2252                 nil
2253                 (list [1 integerp]      ;draw direction (> 0 - left to right, < - right to left)
2254                       [2 integerp]      ;sequence
2255                       [4 nil]           ;length
2256                       [2 integerp]      ;font ascent
2257                       [2 integerp]      ;font descent
2258                       [2 integerp]      ;over all ascent
2259                       [2 integerp]      ;over all descont
2260                       [4 numberp]       ;over all width
2261                       [4 numberp]       ;over all left
2262                       [4 numberp]       ;over all right
2263                       [4 nil]))))       ;pad
2264
2265     (X-Dpy-send-read xdpy msg ReceiveFields)))
2266
2267 ;; Pixmaps
2268
2269 (defun XCreatePixmap (xdpy pixmap d depth width height)
2270   "On display XDPY create PIXMAP using drawable D.
2271 Return X-Pixmap structure."
2272   (X-Dpy-p xdpy 'XCreatePixmap)
2273   (X-Pixmap-p pixmap 'XCreatePixmap)
2274   (X-Drawable-p d)
2275
2276   (setf (X-Pixmap-width pixmap) width)
2277   (setf (X-Pixmap-height pixmap) height)
2278   (setf (X-Pixmap-depth pixmap) depth)
2279
2280   ;; Set pixmap's drawable
2281   (setf (X-Pixmap-d pixmap) d)
2282
2283   (let* ((ListOfFields
2284           (list [1 53]                  ; opcode
2285                 [1 depth]
2286                 [2 4]                   ; length
2287                 [4 (X-Pixmap-id pixmap)]
2288                 [4 (X-Drawable-id d)]
2289                 [2 width]
2290                 [2 height]))
2291          (msg (X-Create-message ListOfFields)))
2292     (X-Dpy-send xdpy msg)
2293     pixmap))
2294
2295 (defun XFreePixmap (xdpy pixmap)
2296   "On display XDPY free pixmap."
2297   (X-Dpy-p xdpy 'XFreePixmap)
2298   (X-Pixmap-p pixmap 'XFreePixmap)
2299
2300   (let* ((ListOfFields
2301           (list [1 54]                  ; opcode
2302                 [1 nil]
2303                 [2 2]
2304                 [4 (X-Pixmap-id pixmap)]))
2305          (msg (X-Create-message ListOfFields)))
2306     (X-Dpy-send xdpy msg)
2307
2308     ;; Invalidate pixmap
2309     (X-invalidate-cl-struct pixmap)
2310     ))
2311
2312 ;; Cursoring
2313 (defun XCreateCursor (xdpy type)
2314   "On display XDPY create cursor of TYPE."
2315   (X-Dpy-p xdpy 'XCreateCursor)
2316
2317   (let* ((ListOfFields
2318           (list [1 93]                  ;opcode
2319                 [1 type]
2320                 [2 2]                   ;length
2321                 [4 nil]))
2322          (msg (X-Create-message ListOfFields)))
2323     (X-Dpy-send xdpy msg)))
2324
2325 (defun XCreateGlyphCursor (xdpy cursor)
2326   "On display XDPY create CURSOR.
2327 CURSOR is `X-Cursor' structure."
2328   (X-Dpy-p xdpy 'XCreateGlyphCursor)
2329   (X-Cursor-p cursor 'XCreateGlyphCursor)
2330
2331   (unless (X-Cursor-id cursor)
2332     (setf (X-Cursor-id cursor) (X-Dpy-get-id xdpy)))
2333
2334   (let* ((attrmsg (X-Cursor-message cursor))
2335          (ListOfFields
2336           (list [1 94]                  ;opcode
2337                 [1 nil]                 ;pad
2338                 [2 (+ 2 (/ (length attrmsg) 4))] ;length
2339                 [4 (X-Cursor-id cursor)])) ;cursor id
2340          (msg (concat (X-Create-message ListOfFields) attrmsg)))
2341     (X-Dpy-send xdpy msg)))
2342
2343 (defun XFreeCursor (xdpy cursor)
2344   "On display XDPY free resources associated with CURSOR."
2345   (let ((ListOfFields
2346          (list [1 95]                   ;opcode
2347                [1 nil]                  ;pad
2348                [2 2]
2349                [4 (X-Cursor-id cursor)]))) ;cursor id
2350     (X-Dpy-send xdpy (X-Create-message ListOfFields)))
2351   (X-invalidate-cl-struct cursor))
2352
2353 (defun XRecolorCursor (xdpy cursor fore-red fore-green fore-blue &optional back-red back-green back-blue)
2354   "On display XDPY recolorize CURSOR."
2355   (when fore-red
2356     (setf (X-Cursor-fgred cursor) fore-red))
2357   (when fore-green
2358     (setf (X-Cursor-fggreen cursor) fore-green))
2359   (when fore-blue
2360     (setf (X-Cursor-fgblue cursor) fore-blue))
2361   (when back-red
2362     (setf (X-Cursor-bgred cursor) back-red))
2363   (when back-green
2364     (setf (X-Cursor-bggreen cursor) back-green))
2365   (when back-blue
2366     (setf (X-Cursor-bgblue cursor) back-blue))
2367
2368   (let ((ListOfFields
2369          (list [1 96]                   ;opcode
2370                [1 nil]                  ;pad
2371                [2 5]
2372                [4 (X-Cursor-id cursor)] ;cursor id
2373                [2 (X-Cursor-fgred cursor)]
2374                [2 (X-Cursor-fggreen cursor)]
2375                [2 (X-Cursor-fgblue cursor)]
2376                [2 (X-Cursor-bgred cursor)]
2377                [2 (X-Cursor-bggreen cursor)]
2378                [2 (X-Cursor-bgblue cursor)])))
2379     (X-Dpy-send xdpy (X-Create-message ListOfFields))))
2380
2381 (defun XChangeActivePointerGrab (xdpy cursor ev-mask &optional time)
2382   "Change active pointer grabbing."
2383   (X-Dpy-p xdpy 'XChangeActivePointerGrab)
2384   (X-Cursor-p cursor 'XChangeActivePointerGrab)
2385
2386   (let* ((ListOfFields
2387           (list [1 30]                  ;opcode
2388                 [1 nil]                 ;pad
2389                 [2 4]                   ;length
2390                 [4 (X-Cursor-id cursor)] ;cursor
2391                 [4 (or time X-CurrentTime)]
2392                 [2 ev-mask]
2393                 [2 nil]))               ;pad
2394          (msg (X-Create-message ListOfFields)))
2395     (X-Dpy-send xdpy msg)))
2396
2397 ;;; Extensions support
2398
2399 (defun XQueryExtension (xdpy name)
2400   "On display XDPY query for extension with NAME."
2401   (X-Dpy-p xdpy 'XQueryExtension)
2402
2403   (let* ((ListOfFields
2404           (list [1 98]                  ;opcode
2405                 [1 nil]                 ;pad
2406                 [2 (+ 2 (X-padlen name))] ;length
2407                 [2 (length name)]       ;chars in string
2408                 [2 nil]))               ;pad
2409          (msg (concat (X-Create-message ListOfFields)
2410                       name
2411                       (make-string (- (* 4 (X-padlen name)) (length name)) 0)))
2412          (ReceiveFields
2413           (list [1 success]
2414                 nil
2415                 (list [1 nil]           ;unused
2416                       [2 integerp]      ;sequence
2417                       [4 nil]           ;length
2418                       [1 booleanp]      ;present
2419                       [1 integerp]      ;major_opcode
2420                       [1 integerp]      ;first_event
2421                       [1 integerp]      ;first_error
2422                       [20 nil])))       ;padding
2423          r)
2424
2425     (setq r (X-Dpy-send-read xdpy msg ReceiveFields))
2426     (X-Dpy-log xdpy 'x-misc "Get reply for query ext: %s" 'r)
2427
2428     (if (and (car r)
2429              (nth 2 r))                 ; present field
2430         (pushnew (cons name r) (X-Dpy-extensions xdpy))
2431       nil)))
2432
2433 (defun X-Dpy-get-extension (xdpy extname &optional sig)
2434   "On display XDPY get extension with EXTNAME.
2435 If SIG, then signal an error if extension is not available."
2436   (let ((ext (or (assoc extname (X-Dpy-extensions xdpy))
2437                  (car (XQueryExtension xdpy extname)))))
2438     (if (and (null ext) sig)
2439         (signal 'search-failed (list sig 'X-Dpy-get-extension extname))
2440       ext)))
2441
2442 ;; Screen saver support
2443 (defun XSetScreenSaver (xdpy timeout interval prefer-blacking allow-exposures)
2444   "On dispay XDPY set screen saver parameters."
2445   (X-Dpy-p xdpy 'XSetScreenSaver)
2446
2447   (let* ((ListOfFields
2448           (list [1 107]         ; opcode
2449                 [1 nil]
2450                 [2 3]
2451                 [2 timeout]
2452                 [2 interval]
2453                 [1 prefer-blacking]
2454                 [1 allow-exposures]
2455                 [2 nil]))
2456          (msg (X-Create-message ListOfFields)))
2457     (X-Dpy-send xdpy msg)))
2458
2459 (defun XGetScreenSaver (xdpy)
2460   "On display XDPY get info about screen saver."
2461   (X-Dpy-p xdpy 'XGetScreenSaver)
2462
2463   (let* ((ListOfFields
2464           (list [1 108]                 ;opcode
2465                 [1 nil]                 ; unused
2466                 [2 1]))
2467          (msg (X-Create-message ListOfFields))
2468          (ReceiveFields
2469           (list [1 success]
2470                 nil
2471                 (list [1 nil]
2472                       [2 nil]
2473                       [4 nil]
2474                       [2 integerp]      ; timeout
2475                       [2 integerp]      ; interval
2476                       [1 booleanp]      ; prefer-blacking
2477                       [1 booleanp]      ; allow-exposures
2478                       [18 nil]))))
2479     (X-Dpy-send-read xdpy msg ReceiveFields)))
2480
2481 (defun XKillClient (xdpy resource)
2482   "On display XDPY kill client RESOURCE."
2483   (X-Dpy-p xdpy 'XKillClient)
2484
2485   (let* ((ListOfFields
2486           (list [1 113]                 ; opcode
2487                 [1 nil]                 ; unused
2488                 [2 2]                   ; length
2489                 [4 resource]))          ; resource ID
2490          (msg (X-Create-message ListOfFields)))
2491     (X-Dpy-send xdpy msg)))
2492
2493 (defun XForceScreenSaver (xdpy &optional mode)
2494   "On display XDPY force screen saver in mode."
2495   (X-Dpy-p xdpy 'XForceScreenSaver)
2496
2497   (let* ((ListOfFields
2498           (list [1 115]                 ; opcode
2499                 [1 mode]
2500                 [2 1]))
2501          (msg (X-Create-message ListOfFields)))
2502     (X-Dpy-send xdpy msg)))
2503
2504 ;; Additional events queue operations
2505 (defun XNextEvent (xdpy &optional timeout predict)
2506   "On display XDPY get next X Event.
2507 Optionally you can specify TIMEOUT.
2508 If TIMEOUT specified and no event arrived in TIMEOUT period, return nil.
2509 If PREDICT is non-nil return only events which on which PREDICT returns non-nil,
2510 others(not matched) events continue processing normally."
2511   (let ((timo (and timeout (add-timeout timeout nil 'XNextEvent-timeout)))
2512         done ret)
2513
2514     (while (not done)
2515       (let* ((nev (next-event))
2516              (type (event-type nev))
2517              obj)
2518         (setq ret (cond ((and (eq type 'timeout)
2519                               (eq (event-object nev) 'XNextEvent-timeout))
2520                          (setq timo nil) ; unset it
2521                          (setq done t)
2522                          nil)
2523                         ((and (eq type 'eval)
2524                               (X-Event-p (setq obj (event-object nev)))
2525                               (or (null predict)
2526                                   (funcall predict obj)))
2527                          (setq done t)
2528                          obj)
2529                         (t (dispatch-event nev) nil)))))
2530
2531     (when timo
2532       (disable-timeout timo))
2533     ret))
2534
2535 (defun XIfEvent (xdpy predict)
2536   "Return next X event on XDPY, who match PREDICT."
2537   (XNextEvent xdpy nil predict))
2538
2539 (defun XSyncEvents (xdpy)
2540   "Syncronize events ready for XDPY."
2541   (funcall (X-Dpy-parse-guess-dispatcher xdpy) xdpy))
2542
2543 (defun XSync (xdpy &optional discard)
2544   "Sync with server.
2545 When DISCARD is non nil, remove all events in events queue, even these
2546 who was before entering `XSync'."
2547   (XGetInputFocus xdpy))
2548
2549 (defun XSetFont (xdpy gc font)
2550   "On display XDPY for GC set FONT."
2551   (X-Dpy-p xdpy 'XSetFont)
2552   (X-Gc-p gc 'XSetFont)
2553   (X-Font-p font 'XSetFont)
2554
2555   (setf (X-Gc-font gc) font)
2556   (XChangeGC xdpy gc))
2557
2558 (defalias 'XFlush 'X-Dpy-send-flush)
2559
2560 \f
2561 (provide 'xlib-xlib)
2562
2563 ;;; xlib-xlib.el ends here