src/xlib-util.lisp

   1 ;;; --------------------------------------------------------------------------
   2 ;;; CLFSWM - FullScreen Window Manager
   3 ;;;
   4 ;;; --------------------------------------------------------------------------
   5 ;;; Documentation: Utility functions
   6 ;;; --------------------------------------------------------------------------
   7 ;;;
   8 ;;; (C) 2005-2015 Philippe Brochard <pbrochard@common-lisp.net>
   9 ;;;
  10 ;;; This program is free software; you can redistribute it and/or modify
  11 ;;; it under the terms of the GNU General Public License as published by
  12 ;;; the Free Software Foundation; either version 3 of the License, or
  13 ;;; (at your option) any later version.
  14 ;;;
  15 ;;; This program is distributed in the hope that it will be useful,
  16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;;; GNU General Public License for more details.
  19 ;;;
  20 ;;; You should have received a copy of the GNU General Public License
  21 ;;; along with this program; if not, write to the Free Software
  22 ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  23 ;;;
  24 ;;; --------------------------------------------------------------------------
  25
  26
  27 (in-package :clfswm)
  28
  29
  30 ;; Window states
  31 (defconstant +withdrawn-state+ 0)
  32 (defconstant +normal-state+ 1)
  33 (defconstant +iconic-state+ 3)
  34
  35
  36 (defparameter *window-events* '(:structure-notify
  37                                 :property-change
  38                                 :colormap-change
  39                                 :focus-change
  40                                 :enter-window
  41                                 :leave-window
  42                                 :pointer-motion
  43                                 :exposure)
  44   "The events to listen for on managed windows.")
  45
  46
  47 (defparameter +netwm-supported+
  48   '(:_NET_SUPPORTING_WM_CHECK
  49     :_NET_NUMBER_OF_DESKTOPS
  50     :_NET_DESKTOP_GEOMETRY
  51     :_NET_DESKTOP_VIEWPORT
  52     :_NET_CURRENT_DESKTOP
  53     :_NET_WM_WINDOW_TYPE
  54     :_NET_CLIENT_LIST)
  55   "Supported NETWM properties.
  56 Window types are in +WINDOW-TYPES+.")
  57
  58 (defparameter +netwm-window-types+
  59   '((:_NET_WM_WINDOW_TYPE_DESKTOP . :desktop)
  60     (:_NET_WM_WINDOW_TYPE_DOCK . :dock)
  61     (:_NET_WM_WINDOW_TYPE_TOOLBAR . :toolbar)
  62     (:_NET_WM_WINDOW_TYPE_MENU . :menu)
  63     (:_NET_WM_WINDOW_TYPE_UTILITY . :utility)
  64     (:_NET_WM_WINDOW_TYPE_SPLASH . :splash)
  65     (:_NET_WM_WINDOW_TYPE_DIALOG . :dialog)
  66     (:_NET_WM_WINDOW_TYPE_NORMAL . :normal))
  67   "Alist mapping NETWM window types to keywords.")
  68
  69
  70
  71
  72 (defparameter *x-error-count* 0)
  73 (defparameter *max-x-error-count* 10000)
  74 (defparameter *clfswm-x-error-filename* "/tmp/clfswm-backtrace.error")
  75
  76
  77 (defmacro with-xlib-protect ((&optional name tag) &body body)
  78   "Ignore Xlib errors in body."
  79   `(handler-case
  80        (with-simple-restart (top-level "Return to clfswm's top level")
  81          ,@body)
  82      (xlib::x-error (c)
  83        (incf *x-error-count*)
  84        (when (> *x-error-count* *max-x-error-count*)
  85          (format t "Xlib error: ~A ~A: ~A~%" ,name (if ,tag ,tag ',body) c)
  86          (force-output)
  87          (write-backtrace *clfswm-x-error-filename*
  88                           (format nil "~%------- Additional information ---------
  89 Xlib error: ~A ~A: ~A
  90 Body: ~A
  91
  92 Features: ~A"
  93                                   ,name ,tag c ',body
  94                                   *features*))
  95          (error "Too many X errors: ~A (logged in ~A)" c *clfswm-x-error-filename*))
  96        #+:xlib-debug
  97        (progn
  98          (format t "Xlib error: ~A ~A: ~A~%" ,name (if ,tag ,tag ',body) c)
  99          (force-output)))))
 100
 101
 102 ;;(defmacro with-xlib-protect ((&optional name tag) &body body)
 103 ;;  `(progn
 104 ;;     ,@body))
 105
 106
 107 (declaim (inline screen-width screen-height))
 108 (defun screen-width ()
 109   ;;(xlib:screen-width *screen*))
 110   (x-drawable-width *root*))
 111
 112 (defun screen-height ()
 113   ;;(xlib:screen-height *screen*))
 114   (x-drawable-height *root*))
 115
 116
 117 (defmacro with-x-pointer (&body body)
 118   "Bind (x y) to mouse pointer positions"
 119   `(multiple-value-bind (x y)
 120        (xlib:query-pointer *root*)
 121      ,@body))
 122
 123
 124
 125 (declaim (inline window-x2 window-y2))
 126 (defun window-x2 (window)
 127   (+ (x-drawable-x window) (x-drawable-width window)))
 128
 129 (defun window-y2 (window)
 130   (+ (x-drawable-y window) (x-drawable-height window)))
 131
 132
 133
 134 ;;;
 135 ;;; Events management functions.
 136 ;;;
 137 (defparameter *unhandled-events* nil)
 138 (defparameter *current-event-mode* nil)
 139
 140 (eval-when (:compile-toplevel :load-toplevel :execute)
 141   (defun keyword->handle-event (mode keyword)
 142     (create-symbol 'handle-event-fun "-" mode "-" keyword)))
 143
 144 (defun handle-event->keyword (symbol)
 145   (let* ((name (string-downcase (symbol-name symbol)))
 146          (pos (search "handle-event-fun-" name)))
 147     (when (and pos (zerop pos))
 148       (let ((pos-mod (search "mode" name)))
 149         (when pos-mod
 150           (intern (string-upcase (subseq name (+ pos-mod 5))) :keyword))))))
 151 ;;        (values (intern (string-upcase (subseq name (+ pos-mod 5))) :keyword)
 152 ;;                (subseq name (length "handle-event-fun-") (1- pos-mod))))))))
 153
 154 (defparameter *handle-event-fun-symbols* nil)
 155
 156 (defun fill-handle-event-fun-symbols ()
 157   (with-all-internal-symbols (symbol :clfswm)
 158     (let ((pos (symbol-search "handle-event-fun-" symbol)))
 159       (when (and pos (zerop pos))
 160         (pushnew symbol *handle-event-fun-symbols*)))))
 161
 162
 163 (defmacro with-handle-event-symbol ((mode) &body body)
 164   "Bind symbol to all handle event functions available in mode"
 165   `(let ((pattern (format nil "handle-event-fun-~A" ,mode)))
 166      (dolist (symbol *handle-event-fun-symbols*)
 167        (let ((pos (symbol-search pattern symbol)))
 168          (when (and pos (zerop pos))
 169            ,@body)))))
 170
 171
 172 (defun find-handle-event-function (&optional (mode ""))
 173   "Print all handle event functions available in mode"
 174   (with-handle-event-symbol (mode)
 175     (print symbol)))
 176
 177 (defun assoc-keyword-handle-event (mode)
 178   "Associate all keywords in mode to their corresponding handle event functions.
 179 For example: main-mode :key-press is bound to handle-event-fun-main-mode-key-press"
 180   (setf *current-event-mode* mode)
 181   (with-handle-event-symbol (mode)
 182     (let ((keyword (handle-event->keyword symbol)))
 183       (when (fboundp symbol)
 184         #+:event-debug
 185         (progn
 186           (format t "~&Associating: ~S with ~S~%" symbol keyword)
 187           (force-output))
 188         (setf (symbol-function keyword) (symbol-function symbol))))))
 189
 190 (defun unassoc-keyword-handle-event (&optional (mode ""))
 191   "Unbound all keywords from their corresponding handle event functions."
 192   (setf *current-event-mode* nil)
 193   (with-handle-event-symbol (mode)
 194     (let ((keyword (handle-event->keyword symbol)))
 195       (when (fboundp keyword)
 196         #+:event-debug
 197         (progn
 198           (format t "~&Unassociating: ~S  ~S~%" symbol keyword)
 199           (force-output))
 200         (fmakunbound keyword)))))
 201
 202 (defmacro define-handler (mode keyword args &body body)
 203   "Like a defun but with a name expanded as handle-event-fun-'mode'-'keyword'
 204 For example (define-handler main-mode :key-press (args) ...)
 205 Expand in handle-event-fun-main-mode-key-press"
 206   `(defun ,(keyword->handle-event mode keyword) (&rest event-slots &key #+:event-debug event-key ,@args &allow-other-keys)
 207      (declare (ignorable event-slots))
 208      #+:event-debug (print (list *current-event-mode* event-key))
 209      ,@body))
 210
 211
 212 (defun event-hook-name (event-keyword)
 213   (create-symbol-in-package :clfswm '*event- event-keyword '-hook*))
 214
 215 (let ((event-hook-list nil))
 216   (defun get-event-hook-list ()
 217     event-hook-list)
 218
 219   (defmacro use-event-hook (event-keyword)
 220     (let ((symb (event-hook-name event-keyword)))
 221       (pushnew symb event-hook-list)
 222       `(defvar ,symb nil)))
 223
 224   (defun unuse-event-hook (event-keyword)
 225     (let ((symb (event-hook-name event-keyword)))
 226       (setf event-hook-list (remove symb event-hook-list))
 227       (makunbound symb)))
 228
 229   (defmacro add-event-hook (name &rest value)
 230     (let ((symb (event-hook-name name)))
 231       `(add-hook ,symb ,@value)))
 232
 233   (defmacro remove-event-hook (name &rest value)
 234     (let ((symb (event-hook-name name)))
 235       `(remove-hook ,symb ,@value)))
 236
 237   (defun clear-event-hooks ()
 238     (dolist (symb event-hook-list)
 239       (makunbound symb)))
 240
 241
 242   (defun optimize-event-hook ()
 243     "Remove unused event hooks"
 244     (dolist (symb event-hook-list)
 245       (when (and (boundp symb)
 246                  (null (symbol-value symb)))
 247         (makunbound symb)
 248         (setf event-hook-list (remove symb event-hook-list))))))
 249
 250
 251
 252 (defmacro define-event-hook (event-keyword args &body body)
 253   (let ((event-fun (gensym)))
 254     `(let ((,event-fun (lambda (&rest event-slots &key #+:event-debug event-key ,@args &allow-other-keys)
 255                          (declare (ignorable event-slots))
 256                          #+:event-debug (print (list ,event-keyword event-key))
 257                          ,@body)))
 258        (add-event-hook ,event-keyword ,event-fun)
 259        ,event-fun)))
 260
 261
 262 (defmacro event-defun (name args &body body)
 263   `(defun ,name (&rest event-slots &key #+:event-debug event-key ,@args &allow-other-keys)
 264      (declare (ignorable event-slots))
 265      #+:event-debug (print (list ,event-keyword event-key))
 266      ,@body))
 267
 268 (defun exit-handle-event ()
 269   (throw 'exit-handle-event nil))
 270
 271
 272 (defun handle-event (&rest event-slots &key event-key &allow-other-keys)
 273   (labels ((make-xlib-window (xobject)
 274              "For some reason the clx xid cache screws up returns pixmaps when
 275 they should be windows. So use this function to make a window out of them."
 276              ;; Workaround for pixmap error taken from STUMPWM - thanks:
 277              ;; XXX: In both the clisp and sbcl clx libraries, sometimes what
 278              ;; should be a window will be a pixmap instead. In this case, we
 279              ;; need to manually translate it to a window to avoid breakage
 280              ;; in stumpwm. So far the only slot that seems to be affected is
 281              ;; the :window slot for configure-request and reparent-notify
 282              ;; events. It appears as though the hash table of XIDs and clx
 283              ;; structures gets out of sync with X or perhaps X assigns a
 284              ;; duplicate ID for a pixmap and a window.
 285              #+clisp (make-instance 'xlib:window :id (slot-value xobject 'xlib::id) :display *display*)
 286              #+(or sbcl ecl openmcl) (xlib::make-window :id (slot-value xobject 'xlib::id) :display *display*)
 287              #-(or sbcl clisp ecl openmcl)
 288              (error 'not-implemented)))
 289     (handler-case
 290         (catch 'exit-handle-event
 291           (let ((win (getf event-slots :window)))
 292             (when (and win (not (xlib:window-p win)))
 293               (dbg "Pixmap Workaround! Should be a window: " win)
 294               (setf (getf event-slots :window) (make-xlib-window win))))
 295           (let ((hook-symbol (event-hook-name event-key)))
 296             (when (boundp hook-symbol)
 297               (apply #'call-hook (symbol-value hook-symbol) event-slots)))
 298           (if (fboundp event-key)
 299               (apply event-key event-slots)
 300               #+:event-debug (pushnew (list *current-event-mode* event-key) *unhandled-events* :test #'equal))
 301           (xlib:display-finish-output *display*))
 302       ((or xlib:window-error xlib:drawable-error) (c)
 303         #-xlib-debug (declare (ignore c))
 304         #+xlib-debug (format t "Ignore Xlib synchronous error: ~a~%" c)))
 305     t))
 306
 307
 308
 309
 310
 311 (defun parse-display-string (display)
 312   "Parse an X11 DISPLAY string and return the host and display from it."
 313   (let* ((colon (position #\: display))
 314          (host (subseq display 0 colon))
 315          (rest (subseq display (1+ colon)))
 316          (dot (position #\. rest))
 317          (num (parse-integer (subseq rest 0 dot))))
 318     (values host num)))
 319
 320
 321 ;;; Transparency support
 322 (let ((opaque #xFFFFFFFF))
 323   (defun window-transparency (window)
 324     "Return the window transparency"
 325     (float (/ (or (first (xlib:get-property window :_NET_WM_WINDOW_OPACITY)) opaque)  opaque)))
 326
 327   (defun set-window-transparency (window value)
 328     "Set the window transparency"
 329     (when (numberp value)
 330       (xlib:change-property window :_NET_WM_WINDOW_OPACITY
 331                             (list (max (min (round (* opaque (if (equal *transparent-background* t) value 1)))
 332                                             opaque)
 333                                        0))
 334                             :cardinal 32)))
 335
 336   (defsetf window-transparency set-window-transparency))
 337
 338
 339
 340 (defun maxmin-size-equal-p (window)
 341   (when (xlib:window-p window)
 342     (let ((hints (xlib:wm-normal-hints window)))
 343       (when hints
 344         (let ((hint-x (xlib:wm-size-hints-x hints))
 345               (hint-y (xlib:wm-size-hints-y hints))
 346               (user-specified-position-p (xlib:wm-size-hints-user-specified-position-p hints))
 347               (min-width (xlib:wm-size-hints-min-width hints))
 348               (min-height (xlib:wm-size-hints-min-height hints))
 349               (max-width (xlib:wm-size-hints-max-width hints))
 350               (max-height (xlib:wm-size-hints-max-height hints)))
 351           (and hint-x hint-y min-width max-width min-height max-height
 352                user-specified-position-p
 353                (= hint-x 0) (= hint-y 0)
 354                (= min-width max-width)
 355                (= min-height max-height)))))))
 356
 357 (defun maxmin-size-equal-window-in-tree ()
 358   (dolist (win (xlib:query-tree *root*))
 359     (when (maxmin-size-equal-p win)
 360       (return win))))
 361
 362
 363
 364
 365 (defun window-state (win)
 366   "Get the state (iconic, normal, withdrawn) of a window."
 367   (first (xlib:get-property win :WM_STATE)))
 368
 369
 370 (defun set-window-state (win state)
 371   "Set the state (iconic, normal, withdrawn) of a window."
 372   (xlib:change-property win
 373                         :WM_STATE
 374                         (list state)
 375                         :WM_STATE
 376                         32))
 377
 378 (defsetf window-state set-window-state)
 379
 380
 381
 382 (defun window-hidden-p (window)
 383   (eql (window-state window) +iconic-state+))
 384
 385
 386 (defun window-transient-for (window)
 387   (first (xlib:get-property window :WM_TRANSIENT_FOR)))
 388
 389 (defun window-leader (window)
 390   (when (xlib:window-p window)
 391     (or (first (xlib:get-property window :WM_CLIENT_LEADER))
 392         (let ((id (window-transient-for window)))
 393           (when id
 394             (window-leader id))))))
 395
 396
 397
 398 (defun unhide-window (window)
 399   (when window
 400     (when (window-hidden-p window)
 401       (xlib:map-window window)
 402       (setf (window-state window) +normal-state+
 403             (xlib:window-event-mask window) *window-events*))))
 404
 405
 406 (defun map-window (window)
 407   (when window
 408     (xlib:map-window window)))
 409
 410
 411 (defun delete-window (window)
 412   (send-client-message window :WM_PROTOCOLS
 413                        (xlib:intern-atom *display* :WM_DELETE_WINDOW)))
 414
 415 (defun destroy-window (window)
 416   (xlib:kill-client *display* (xlib:window-id window)))
 417
 418
 419 ;;(defconstant +exwm-atoms+
 420 ;;  (list "_NET_SUPPORTED"              "_NET_CLIENT_LIST"
 421 ;;      "_NET_CLIENT_LIST_STACKING"   "_NET_NUMBER_OF_DESKTOPS"
 422 ;;      "_NET_CURRENT_DESKTOP"        "_NET_DESKTOP_GEOMETRY"
 423 ;;      "_NET_DESKTOP_VIEWPORT"       "_NET_DESKTOP_NAMES"
 424 ;;      "_NET_ACTIVE_WINDOW"          "_NET_WORKAREA"
 425 ;;      "_NET_SUPPORTING_WM_CHECK"    "_NET_VIRTUAL_ROOTS"
 426 ;;      "_NET_DESKTOP_LAYOUT"
 427 ;;
 428 ;;        "_NET_RESTACK_WINDOW"         "_NET_REQUEST_FRAME_EXTENTS"
 429 ;;        "_NET_MOVERESIZE_WINDOW"      "_NET_CLOSE_WINDOW"
 430 ;;        "_NET_WM_MOVERESIZE"
 431 ;;
 432 ;;      "_NET_WM_SYNC_REQUEST"        "_NET_WM_PING"
 433 ;;
 434 ;;      "_NET_WM_NAME"                "_NET_WM_VISIBLE_NAME"
 435 ;;      "_NET_WM_ICON_NAME"           "_NET_WM_VISIBLE_ICON_NAME"
 436 ;;      "_NET_WM_DESKTOP"             "_NET_WM_WINDOW_TYPE"
 437 ;;      "_NET_WM_STATE"               "_NET_WM_STRUT"
 438 ;;      "_NET_WM_ICON_GEOMETRY"       "_NET_WM_ICON"
 439 ;;      "_NET_WM_PID"                 "_NET_WM_HANDLED_ICONS"
 440 ;;      "_NET_WM_USER_TIME"           "_NET_FRAME_EXTENTS"
 441 ;;        ;; "_NET_WM_MOVE_ACTIONS"
 442 ;;
 443 ;;      "_NET_WM_WINDOW_TYPE_DESKTOP" "_NET_WM_STATE_MODAL"
 444 ;;      "_NET_WM_WINDOW_TYPE_DOCK"    "_NET_WM_STATE_STICKY"
 445 ;;      "_NET_WM_WINDOW_TYPE_TOOLBAR" "_NET_WM_STATE_MAXIMIZED_VERT"
 446 ;;      "_NET_WM_WINDOW_TYPE_MENU"    "_NET_WM_STATE_MAXIMIZED_HORZ"
 447 ;;      "_NET_WM_WINDOW_TYPE_UTILITY" "_NET_WM_STATE_SHADED"
 448 ;;      "_NET_WM_WINDOW_TYPE_SPLASH"  "_NET_WM_STATE_SKIP_TASKBAR"
 449 ;;      "_NET_WM_WINDOW_TYPE_DIALOG"  "_NET_WM_STATE_SKIP_PAGER"
 450 ;;      "_NET_WM_WINDOW_TYPE_NORMAL"  "_NET_WM_STATE_HIDDEN"
 451 ;;                                    "_NET_WM_STATE_FULLSCREEN"
 452 ;;                                    "_NET_WM_STATE_ABOVE"
 453 ;;                                    "_NET_WM_STATE_BELOW"
 454 ;;                                    "_NET_WM_STATE_DEMANDS_ATTENTION"
 455 ;;
 456 ;;      "_NET_WM_ALLOWED_ACTIONS"
 457 ;;      "_NET_WM_ACTION_MOVE"
 458 ;;      "_NET_WM_ACTION_RESIZE"
 459 ;;      "_NET_WM_ACTION_SHADE"
 460 ;;      "_NET_WM_ACTION_STICK"
 461 ;;      "_NET_WM_ACTION_MAXIMIZE_HORZ"
 462 ;;      "_NET_WM_ACTION_MAXIMIZE_VERT"
 463 ;;      "_NET_WM_ACTION_FULLSCREEN"
 464 ;;      "_NET_WM_ACTION_CHANGE_DESKTOP"
 465 ;;      "_NET_WM_ACTION_CLOSE"
 466 ;;
 467 ;;      ))
 468 ;;
 469 ;;
 470 ;;(defun intern-atoms (display)
 471 ;;  (declare (type xlib:display display))
 472 ;;  (mapcar #'(lambda (atom-name) (xlib:intern-atom display atom-name))
 473 ;;        +exwm-atoms+)
 474 ;;  (values))
 475 ;;
 476 ;;
 477 ;;
 478 ;;(defun get-atoms-property (window property-atom atom-list-p)
 479 ;;  "Returns a list of atom-name (if atom-list-p is t) otherwise returns
 480 ;;   a list of atom-id."
 481 ;;  (xlib:get-property window property-atom
 482 ;;                   :transform (when atom-list-p
 483 ;;                                (lambda (id)
 484 ;;                                  (xlib:atom-name (xlib:drawable-display window) id)))))
 485 ;;
 486 ;;(defun set-atoms-property (window atoms property-atom &key (mode :replace))
 487 ;;  "Sets the property designates by `property-atom'. ATOMS is a list of atom-id
 488 ;;   or a list of keyword atom-names."
 489 ;;  (xlib:change-property window property-atom atoms :ATOM 32
 490 ;;                      :mode mode
 491 ;;                      :transform (unless (integerp (car atoms))
 492 ;;                                   (lambda (atom-key)
 493 ;;                                     (xlib:find-atom (xlib:drawable-display window) atom-key)))))
 494 ;;
 495 ;;
 496 ;;
 497 ;;
 498 ;;(defun net-wm-state (window)
 499 ;;  (get-atoms-property window :_NET_WM_STATE t))
 500 ;;
 501 ;;(defsetf net-wm-state (window &key (mode :replace)) (states)
 502 ;;  `(set-atoms-property ,window ,states :_NET_WM_STATE :mode ,mode))
 503
 504
 505 (defun hide-window (window)
 506   (when window
 507     (setf (window-state window) +iconic-state+
 508           (xlib:window-event-mask window) (remove :structure-notify *window-events*))
 509     (xlib:unmap-window window)
 510     (setf (xlib:window-event-mask window) *window-events*)))
 511
 512
 513
 514 (defun window-type (window)
 515   "Return one of :desktop, :dock, :toolbar, :utility, :splash,
 516 :dialog, :transient, :maxsize and :normal."
 517   (when (xlib:window-p window)
 518     (or (and (let ((hints (xlib:wm-normal-hints window)))
 519                (and hints (or (and (xlib:wm-size-hints-max-width hints)
 520                                    (< (xlib:wm-size-hints-max-width hints) (x-drawable-width *root*)))
 521                               (and (xlib:wm-size-hints-max-height hints)
 522                                    (< (xlib:wm-size-hints-max-height hints) (x-drawable-height *root*)))
 523                               (xlib:wm-size-hints-min-aspect hints)
 524                               (xlib:wm-size-hints-max-aspect hints))))
 525              :maxsize)
 526         (let ((net-wm-window-type (xlib:get-property window :_NET_WM_WINDOW_TYPE)))
 527           (when net-wm-window-type
 528             (dolist (type-atom net-wm-window-type)
 529               (when (assoc (xlib:atom-name *display* type-atom) +netwm-window-types+)
 530                 (return (cdr (assoc (xlib:atom-name *display* type-atom) +netwm-window-types+)))))))
 531         (and (xlib:get-property window :WM_TRANSIENT_FOR)
 532              :transient)
 533         :normal)))
 534
 535
 536
 537
 538 ;;; Stolen from Eclipse
 539 (defun send-configuration-notify (window x y w h bw)
 540   "Send a synthetic configure notify event to the given window (ICCCM 4.1.5)"
 541   (xlib:send-event window :configure-notify (xlib:make-event-mask :structure-notify)
 542                    :event-window window
 543                    :window window
 544                    :x x :y y
 545                    :width w
 546                    :height h
 547                    :border-width bw
 548                    :propagate-p nil))
 549
 550
 551
 552 (defun send-client-message (window type &rest data)
 553   "Send a client message to a client's window."
 554   (xlib:send-event window
 555                    :client-message nil
 556                    :window window
 557                    :type type
 558                    :format 32
 559                    :data data))
 560
 561
 562
 563
 564
 565 (defun raise-window (window)
 566   "Map the window if needed and bring it to the top of the stack. Does not affect focus."
 567   (when (xlib:window-p window)
 568     (when (window-hidden-p window)
 569       (unhide-window window))
 570     (setf (xlib:window-priority window) :above)))
 571
 572
 573 (let ((focused-window nil))
 574   (defun no-focus ()
 575     "don't focus any window but still read keyboard events."
 576     (xlib:set-input-focus *display* *no-focus-window* :pointer-root)
 577     (setf focused-window nil))
 578
 579   (defun focus-window (window)
 580     "Give the window focus."
 581     (no-focus)
 582     (when (xlib:window-p window)
 583       (xlib:set-input-focus *display* window :parent)
 584       (setf focused-window window)))
 585
 586   (defun focused-window ()
 587     focused-window))
 588
 589
 590
 591 (defun raise-and-focus-window (window)
 592   "Raise and focus."
 593   (raise-window window)
 594   (focus-window window))
 595
 596
 597 (defun lower-window (window sibling)
 598   "Map the window if needed and bring it just above sibling. Does not affect focus."
 599   (when (xlib:window-p window)
 600     (when (window-hidden-p window)
 601       (unhide-window window))
 602     (setf (xlib:window-priority window sibling) :below)))
 603
 604
 605
 606
 607 (let ((cursor-font nil)
 608       (cursor nil)
 609       (pointer-grabbed nil))
 610   (defun free-grab-pointer ()
 611     (when cursor
 612       (xlib:free-cursor cursor)
 613       (setf cursor nil))
 614     (when cursor-font
 615       (xlib:close-font cursor-font)
 616       (setf cursor-font nil)))
 617
 618   (defun xgrab-init-pointer ()
 619     (setf pointer-grabbed nil))
 620
 621     (defun xgrab-pointer-p ()
 622       pointer-grabbed)
 623
 624     (defun xgrab-pointer (root cursor-char cursor-mask-char
 625                           &optional (pointer-mask '(:enter-window :pointer-motion
 626                                                     :button-press :button-release)) owner-p)
 627       "Grab the pointer and set the pointer shape."
 628       (when pointer-grabbed
 629         (xungrab-pointer))
 630       (setf pointer-grabbed t)
 631       (let* ((white (xlib:make-color :red 1.0 :green 1.0 :blue 1.0))
 632              (black (xlib:make-color :red 0.0 :green 0.0 :blue 0.0)))
 633         (cond (cursor-char
 634                (setf cursor-font (xlib:open-font *display* "cursor")
 635                      cursor (xlib:create-glyph-cursor :source-font cursor-font
 636                                                       :source-char (or cursor-char 68)
 637                                                       :mask-font cursor-font
 638                                                       :mask-char (or cursor-mask-char 69)
 639                                                       :foreground black
 640                                                       :background white))
 641                (xlib:grab-pointer root pointer-mask
 642                                        :owner-p owner-p  :sync-keyboard-p nil :sync-pointer-p nil :cursor cursor))
 643               (t
 644                (xlib:grab-pointer root pointer-mask
 645                                        :owner-p owner-p  :sync-keyboard-p nil :sync-pointer-p nil)))))
 646
 647     (defun xungrab-pointer ()
 648       "Remove the grab on the cursor and restore the cursor shape."
 649       (setf pointer-grabbed nil)
 650       (xlib:ungrab-pointer *display*)
 651       (xlib:display-finish-output *display*)
 652       (free-grab-pointer)))
 653
 654
 655 (let ((keyboard-grabbed nil))
 656   (defun xgrab-init-keyboard ()
 657     (setf keyboard-grabbed nil))
 658
 659   (defun xgrab-keyboard-p ()
 660     keyboard-grabbed)
 661
 662   (defun xgrab-keyboard (root)
 663     (setf keyboard-grabbed t)
 664     (xlib:grab-keyboard root :owner-p nil :sync-keyboard-p nil :sync-pointer-p nil))
 665
 666
 667   (defun xungrab-keyboard ()
 668     (setf keyboard-grabbed nil)
 669     (xlib:ungrab-keyboard *display*)))
 670
 671
 672
 673
 674
 675
 676 (defun ungrab-all-buttons (window)
 677   (xlib:ungrab-button window :any :modifiers :any))
 678
 679 (defun grab-all-buttons (window)
 680   (ungrab-all-buttons window)
 681   (xlib:grab-button window :any '(:button-press :button-release :pointer-motion)
 682                     :modifiers :any
 683                     :owner-p nil
 684                     :sync-pointer-p t
 685                     :sync-keyboard-p nil))
 686
 687 (defun ungrab-all-keys (window)
 688   (xlib:ungrab-key window :any :modifiers :any))
 689
 690
 691
 692 (defmacro with-grab-keyboard-and-pointer ((cursor mask old-cursor old-mask &optional ungrab-main) &body body)
 693   `(let ((pointer-grabbed (xgrab-pointer-p))
 694          (keyboard-grabbed (xgrab-keyboard-p)))
 695      (xgrab-pointer *root* ,cursor ,mask)
 696      (unless keyboard-grabbed
 697        (when ,ungrab-main
 698          (ungrab-main-keys))
 699        (xgrab-keyboard *root*))
 700      (unwind-protect
 701           (progn
 702             ,@body)
 703        (progn
 704          (if pointer-grabbed
 705              (xgrab-pointer *root* ,old-cursor ,old-mask)
 706              (xungrab-pointer))
 707          (unless keyboard-grabbed
 708            (when ,ungrab-main
 709              (grab-main-keys))
 710            (xungrab-keyboard))))))
 711
 712
 713 (defmacro with-grab-pointer ((&optional cursor-char cursor-mask-char) &body body)
 714   `(let ((pointer-grabbed-p (xgrab-pointer-p)))
 715      (unless pointer-grabbed-p
 716        (xgrab-pointer *root* ,cursor-char ,cursor-mask-char))
 717      (unwind-protect
 718           (progn
 719             ,@body)
 720        (unless pointer-grabbed-p
 721          (xungrab-pointer)))))
 722
 723
 724
 725
 726
 727 (defun stop-button-event ()
 728   (xlib:allow-events *display* :sync-pointer))
 729
 730 (defun replay-button-event ()
 731   (xlib:allow-events *display* :replay-pointer))
 732
 733
 734
 735
 736
 737
 738
 739
 740
 741 ;;; Mouse action on window
 742 (let (add-fn add-arg dx dy window)
 743   (define-handler move-window-mode :motion-notify (root-x root-y)
 744     (unless (compress-motion-notify)
 745       (if add-fn
 746           (multiple-value-bind (move-x move-y)
 747               (apply add-fn add-arg)
 748             (when move-x
 749               (setf (x-drawable-x window) (+ root-x dx)))
 750             (when move-y
 751               (setf (x-drawable-y window) (+ root-y dy))))
 752           (setf (x-drawable-x window) (+ root-x dx)
 753                 (x-drawable-y window) (+ root-y dy)))))
 754
 755   (define-handler move-window-mode :key-release ()
 756     (throw 'exit-move-window-mode nil))
 757
 758   (define-handler move-window-mode :button-release ()
 759     (throw 'exit-move-window-mode nil))
 760
 761   (defun move-window (orig-window orig-x orig-y &optional additional-fn additional-arg)
 762     (setf window orig-window
 763           add-fn additional-fn
 764           add-arg additional-arg
 765           dx (- (x-drawable-x window) orig-x)
 766           dy (- (x-drawable-y window) orig-y)
 767           (xlib:window-border window) (get-color *color-move-window*))
 768     (raise-window window)
 769     (with-grab-pointer ()
 770       (when additional-fn
 771         (apply additional-fn additional-arg))
 772       (generic-mode 'move-window-mode 'exit-move-window-mode
 773                     :original-mode '(main-mode)))))
 774
 775
 776 (let (add-fn add-arg window
 777              o-x o-y
 778              orig-width orig-height
 779              min-width max-width
 780              min-height max-height)
 781   (define-handler resize-window-mode :motion-notify (root-x root-y)
 782     (unless (compress-motion-notify)
 783       (if add-fn
 784           (multiple-value-bind (resize-w resize-h)
 785               (apply add-fn add-arg)
 786             (when resize-w
 787               (setf (x-drawable-width window) (min (max (+ orig-width (- root-x o-x)) 10 min-width) max-width)))
 788             (when resize-h
 789               (setf (x-drawable-height window) (min (max (+ orig-height (- root-y o-y)) 10 min-height) max-height))))
 790           (setf (x-drawable-width window) (min (max (+ orig-width (- root-x o-x)) 10 min-width) max-width)
 791                 (x-drawable-height window) (min (max (+ orig-height (- root-y o-y)) 10 min-height) max-height)))))
 792
 793   (define-handler resize-window-mode :key-release ()
 794     (throw 'exit-resize-window-mode nil))
 795
 796   (define-handler resize-window-mode :button-release ()
 797     (throw 'exit-resize-window-mode nil))
 798
 799   (defun resize-window (orig-window orig-x orig-y &optional additional-fn additional-arg)
 800     (let* ((hints (xlib:wm-normal-hints orig-window)))
 801       (setf window orig-window
 802             add-fn additional-fn
 803             add-arg additional-arg
 804             o-x orig-x
 805             o-y orig-y
 806             orig-width (x-drawable-width window)
 807             orig-height (x-drawable-height window)
 808             min-width (or (and hints (xlib:wm-size-hints-min-width hints)) 0)
 809             min-height (or (and hints (xlib:wm-size-hints-min-height hints)) 0)
 810             max-width (or (and hints (xlib:wm-size-hints-max-width hints)) most-positive-fixnum)
 811             max-height (or (and hints (xlib:wm-size-hints-max-height hints)) most-positive-fixnum)
 812             (xlib:window-border window) (get-color *color-move-window*))
 813       (raise-window window)
 814       (with-grab-pointer ()
 815         (when additional-fn
 816           (apply additional-fn additional-arg))
 817         (generic-mode 'resize-window-mode 'exit-resize-window-mode
 818                       :original-mode '(main-mode))))))
 819
 820
 821
 822 (define-handler wait-mouse-button-release-mode :button-release ()
 823   (throw 'exit-wait-mouse-button-release-mode nil))
 824
 825 (defun wait-mouse-button-release (&optional cursor-char cursor-mask-char)
 826   (with-grab-pointer (cursor-char cursor-mask-char)
 827     (generic-mode 'wait-mouse-button-release 'exit-wait-mouse-button-release-mode)))
 828
 829
 830
 831
 832
 833 (let ((color-hash (make-hash-table :test 'equal)))
 834   (defun get-color (color)
 835     (multiple-value-bind (val foundp)
 836         (gethash color color-hash)
 837       (if foundp
 838           val
 839           (setf (gethash color color-hash)
 840                 (xlib:alloc-color (xlib:screen-default-colormap *screen*) color))))))
 841
 842
 843
 844 (defgeneric ->color (color))
 845
 846 (defmethod ->color ((color-name string))
 847   color-name)
 848
 849 (defmethod ->color ((color integer))
 850   (labels ((hex->float (color)
 851              (/ (logand color #xFF) 256.0)))
 852     (xlib:make-color :blue (hex->float color)
 853                      :green (hex->float (ash color -8))
 854                      :red (hex->float  (ash color -16)))))
 855
 856 (defmethod ->color ((color list))
 857   (destructuring-bind (red green blue) color
 858     (xlib:make-color :blue red :green green :red blue)))
 859
 860 (defmethod ->color ((color xlib:color))
 861   color)
 862
 863 (defmethod ->color (color)
 864   (format t "Wrong color type: ~A~%" color)
 865   "White")
 866
 867
 868 (defun color->rgb (color)
 869   (multiple-value-bind (r g b)
 870       (xlib:color-rgb color)
 871     (+ (ash (round (* 256 r)) +16)
 872        (ash (round (* 256 g)) +8)
 873        (round (* 256 b)))))
 874
 875
 876
 877
 878
 879 (defmacro my-character->keysyms (ch)
 880   "Convert a char to a keysym"
 881   ;; XLIB:CHARACTER->KEYSYMS should probably be implemented in NEW-CLX
 882   ;; some day.  Or just copied from MIT-CLX or some other CLX
 883   ;; implementation (see translate.lisp and keysyms.lisp).  For now,
 884   ;; we do like this.  It suffices for modifiers and ASCII symbols.
 885   (if (fboundp 'xlib:character->keysyms)
 886       `(xlib:character->keysyms ,ch)
 887       `(list
 888        (case ,ch
 889          (:character-set-switch #xFF7E)
 890          (:left-shift #xFFE1)
 891          (:right-shift #xFFE2)
 892          (:left-control #xFFE3)
 893          (:right-control #xFFE4)
 894          (:caps-lock #xFFE5)
 895          (:shift-lock #xFFE6)
 896          (:left-meta #xFFE7)
 897          (:right-meta #xFFE8)
 898          (:left-alt #xFFE9)
 899          (:right-alt #xFFEA)
 900          (:left-super #xFFEB)
 901          (:right-super #xFFEC)
 902          (:left-hyper #xFFED)
 903          (:right-hyper #xFFEE)
 904          (t
 905           (etypecase ,ch
 906             (character
 907              ;; Latin-1 characters have their own value as keysym
 908              (if (< 31 (char-code ,ch) 256)
 909                  (char-code ,ch)
 910                  (error "Don't know how to get keysym from ~A" ,ch)))))))))
 911
 912
 913
 914
 915 (defun char->keycode (char)
 916   "Convert a character to a keycode"
 917   (xlib:keysym->keycodes *display* (first (my-character->keysyms char))))
 918
 919
 920 (defun keycode->char (code state)
 921   (xlib:keysym->character *display* (xlib:keycode->keysym *display* code 0) state))
 922
 923 (defun modifiers->state (modifier-list)
 924   (apply #'xlib:make-state-mask modifier-list))
 925
 926 (defun state->modifiers (state)
 927   (xlib:make-state-keys state))
 928
 929 (defun keycode->keysym (code modifiers)
 930   (xlib:keycode->keysym *display* code (cond ((member :shift modifiers) 1)
 931                                              ((member :mod-5 modifiers) 4)
 932                                              (t 0))))
 933
 934
 935
 936
 937
 938 (let ((modifier-list nil))
 939   (defun init-modifier-list ()
 940     (dolist (name '("Shift_L" "Shift_R" "Control_L" "Control_R"
 941                     "Alt_L" "Alt_R" "Meta_L" "Meta_R" "Hyper_L" "Hyper_R"
 942                     "Mode_switch" "script_switch" "ISO_Level3_Shift"
 943                     "Caps_Lock" "Scroll_Lock" "Num_Lock"))
 944       (awhen (xlib:keysym->keycodes *display* (keysym-name->keysym name))
 945         (push it modifier-list))))
 946
 947   (defun modifier-p (code)
 948     (member code modifier-list)))
 949
 950 (defun wait-no-key-or-button-press ()
 951   (with-grab-keyboard-and-pointer (66 67 66 67)
 952     (loop
 953        (let ((key (loop for k across (xlib:query-keymap *display*)
 954                      for code from 0
 955                      when (and (plusp k) (not (modifier-p code)))
 956                      return t))
 957              (button (loop for b in (xlib:make-state-keys (nth-value 4 (xlib:query-pointer *root*)))
 958                         when (member b '(:button-1 :button-2 :button-3 :button-4 :button-5))
 959                         return t)))
 960          (when (and (not key) (not button))
 961            (loop while (xlib:event-case (*display* :discard-p t :peek-p nil :timeout 0)
 962                          (:motion-notify () t)
 963                          (:key-press () t)
 964                          (:key-release () t)
 965                          (:button-press () t)
 966                          (:button-release () t)
 967                          (t nil)))
 968            (return))))))
 969
 970
 971 (defun wait-a-key-or-button-press ()
 972   (with-grab-keyboard-and-pointer (24 25 66 67)
 973     (loop
 974      (let ((key (loop for k across (xlib:query-keymap *display*)
 975                       unless (zerop k) return t))
 976            (button (loop for b in (xlib:make-state-keys (nth-value 4 (xlib:query-pointer *root*)))
 977                          when (member b '(:button-1 :button-2 :button-3 :button-4 :button-5))
 978                          return t)))
 979        (when (or key button)
 980          (return))))))
 981
 982
 983
 984 (defun compress-motion-notify ()
 985   (when *have-to-compress-notify*
 986     (loop while (xlib:event-cond (*display* :timeout 0)
 987                   (:motion-notify () t)))))
 988
 989
 990 (defun display-all-cursors (&optional (display-time 1))
 991   "Display all X11 cursors for display-time seconds"
 992   (loop for i from 0 to 152 by 2
 993      do (xgrab-pointer *root* i (1+ i))
 994        (dbg i)
 995        (sleep display-time)
 996        (xungrab-pointer)))
 997
 998
 999
1000 ;;; Double buffering tools
1001 (defun clear-pixmap-buffer (window gc)
1002   (if (equal *transparent-background* :pseudo)
1003       (xlib:copy-area *background-image* *background-gc*
1004                       (x-drawable-x window) (x-drawable-y window)
1005                       (x-drawable-width window) (x-drawable-height window)
1006                       *pixmap-buffer* 0 0)
1007       (xlib:with-gcontext (gc :foreground (xlib:gcontext-background gc)
1008                               :background (xlib:gcontext-foreground gc))
1009         (xlib:draw-rectangle *pixmap-buffer* gc
1010                              0 0 (x-drawable-width window) (x-drawable-height window)
1011                              t))))
1012
1013
1014
1015 (defun copy-pixmap-buffer (window gc)
1016   (xlib:copy-area *pixmap-buffer* gc
1017                   0 0 (x-drawable-width window) (x-drawable-height window)
1018                   window 0 0))
1019
1020
1021
1022 (defun is-a-key-pressed-p ()
1023   (loop for k across (xlib:query-keymap *display*)
1024      when (plusp k)
1025      return t))
1026
1027 ;;; Windows wm class and name tests
1028 (defmacro defun-equal-wm-class (symbol class)
1029   `(defun ,symbol (window)
1030      (when (xlib:window-p window)
1031        (string-equal (xlib:get-wm-class window) ,class))))
1032
1033
1034 (defmacro defun-equal-wm-name (symbol name)
1035   `(defun ,symbol (window)
1036      (when (xlib:window-p window)
1037        (string-equal (xlib:wm-name window) ,name))))