src/xlib-util.lisp

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