src/xlib-util.lisp

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