src/xlib-util.lisp

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