1 ;;; --------------------------------------------------------------------------
2 ;;; CLFSWM - FullScreen Window Manager
4 ;;; --------------------------------------------------------------------------
5 ;;; Documentation: Utility functions
6 ;;; --------------------------------------------------------------------------
8 ;;; (C) 2005-2013 Philippe Brochard <pbrochard@common-lisp.net>
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.
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.
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.
24 ;;; --------------------------------------------------------------------------
31 (defconstant +withdrawn-state
+ 0)
32 (defconstant +normal-state
+ 1)
33 (defconstant +iconic-state
+ 3)
36 (defparameter *window-events
* '(:structure-notify
44 "The events to listen for on managed windows.")
47 (defparameter +netwm-supported
+
48 '(:_NET_SUPPORTING_WM_CHECK
49 :_NET_NUMBER_OF_DESKTOPS
50 :_NET_DESKTOP_GEOMETRY
51 :_NET_DESKTOP_VIEWPORT
55 "Supported NETWM properties.
56 Window types are in +WINDOW-TYPES+.")
58 (defparameter +netwm-window-types
+
59 '((:_NET_WM_WINDOW_TYPE_DESKTOP .
:desktop
)
60 (:_NET_WM_WINDOW_TYPE_DOCK .
:dock
)
61 (:_NET_WM_WINDOW_TYPE_TOOLBAR .
:toolbar
)
62 (:_NET_WM_WINDOW_TYPE_MENU .
:menu
)
63 (:_NET_WM_WINDOW_TYPE_UTILITY .
:utility
)
64 (:_NET_WM_WINDOW_TYPE_SPLASH .
:splash
)
65 (:_NET_WM_WINDOW_TYPE_DIALOG .
:dialog
)
66 (:_NET_WM_WINDOW_TYPE_NORMAL .
:normal
))
67 "Alist mapping NETWM window types to keywords.")
72 (defparameter *x-error-count
* 0)
73 (defparameter *max-x-error-count
* 10000)
74 (defparameter *clfswm-x-error-filename
* "/tmp/clfswm-backtrace.error")
77 (defmacro with-xlib-protect
((&optional name tag
) &body body
)
78 "Ignore Xlib errors in body."
80 (with-simple-restart (top-level "Return to clfswm's top level")
83 (incf *x-error-count
*)
84 (when (> *x-error-count
* *max-x-error-count
*)
85 (format t
"Xlib error: ~A ~A: ~A~%" ,name
(if ,tag
,tag
',body
) c
)
87 (write-backtrace *clfswm-x-error-filename
*
88 (format nil
"~%------- Additional information ---------
95 (error "Too many X errors: ~A (logged in ~A)" c
*clfswm-x-error-filename
*))
98 (format t
"Xlib error: ~A ~A: ~A~%" ,name
(if ,tag
,tag
',body
) c
)
102 ;;(defmacro with-xlib-protect ((&optional name tag) &body body)
106 (declaim (inline screen-width screen-height
))
107 (defun screen-width ()
108 ;;(xlib:screen-width *screen*))
109 (x-drawable-width *root
*))
111 (defun screen-height ()
112 ;;(xlib:screen-height *screen*))
113 (x-drawable-height *root
*))
116 (defmacro with-x-pointer
(&body body
)
117 "Bind (x y) to mouse pointer positions"
118 `(multiple-value-bind (x y
)
119 (xlib:query-pointer
*root
*)
124 (declaim (inline window-x2 window-y2
))
125 (defun window-x2 (window)
126 (+ (x-drawable-x window
) (x-drawable-width window
)))
128 (defun window-y2 (window)
129 (+ (x-drawable-y window
) (x-drawable-height window
)))
134 ;;; Events management functions.
136 (defparameter *unhandled-events
* nil
)
137 (defparameter *current-event-mode
* nil
)
139 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
140 (defun keyword->handle-event
(mode keyword
)
141 (create-symbol 'handle-event-fun
"-" mode
"-" keyword
)))
143 (defun handle-event->keyword
(symbol)
144 (let* ((name (string-downcase (symbol-name symbol
)))
145 (pos (search "handle-event-fun-" name
)))
146 (when (and pos
(zerop pos
))
147 (let ((pos-mod (search "mode" name
)))
149 (intern (string-upcase (subseq name
(+ pos-mod
5))) :keyword
))))))
150 ;; (values (intern (string-upcase (subseq name (+ pos-mod 5))) :keyword)
151 ;; (subseq name (length "handle-event-fun-") (1- pos-mod))))))))
153 (defparameter *handle-event-fun-symbols
* nil
)
155 (defun fill-handle-event-fun-symbols ()
156 (with-all-internal-symbols (symbol :clfswm
)
157 (let ((pos (symbol-search "handle-event-fun-" symbol
)))
158 (when (and pos
(zerop pos
))
159 (pushnew symbol
*handle-event-fun-symbols
*)))))
162 (defmacro with-handle-event-symbol
((mode) &body body
)
163 "Bind symbol to all handle event functions available in mode"
164 `(let ((pattern (format nil
"handle-event-fun-~A" ,mode
)))
165 (dolist (symbol *handle-event-fun-symbols
*)
166 (let ((pos (symbol-search pattern symbol
)))
167 (when (and pos
(zerop pos
))
171 (defun find-handle-event-function (&optional
(mode ""))
172 "Print all handle event functions available in mode"
173 (with-handle-event-symbol (mode)
176 (defun assoc-keyword-handle-event (mode)
177 "Associate all keywords in mode to their corresponding handle event functions.
178 For example: main-mode :key-press is bound to handle-event-fun-main-mode-key-press"
179 (setf *current-event-mode
* mode
)
180 (with-handle-event-symbol (mode)
181 (let ((keyword (handle-event->keyword symbol
)))
182 (when (fboundp symbol
)
185 (format t
"~&Associating: ~S with ~S~%" symbol keyword
)
187 (setf (symbol-function keyword
) (symbol-function symbol
))))))
189 (defun unassoc-keyword-handle-event (&optional
(mode ""))
190 "Unbound all keywords from their corresponding handle event functions."
191 (setf *current-event-mode
* nil
)
192 (with-handle-event-symbol (mode)
193 (let ((keyword (handle-event->keyword symbol
)))
194 (when (fboundp keyword
)
197 (format t
"~&Unassociating: ~S ~S~%" symbol keyword
)
199 (fmakunbound keyword
)))))
201 (defmacro define-handler
(mode keyword args
&body body
)
202 "Like a defun but with a name expanded as handle-event-fun-'mode'-'keyword'
203 For example (define-handler main-mode :key-press (args) ...)
204 Expand in handle-event-fun-main-mode-key-press"
205 `(defun ,(keyword->handle-event mode keyword
) (&rest event-slots
&key
#+:event-debug event-key
,@args
&allow-other-keys
)
206 (declare (ignorable event-slots
))
207 #+:event-debug
(print (list *current-event-mode
* event-key
))
211 (defun event-hook-name (event-keyword)
212 (create-symbol-in-package :clfswm
'*event- event-keyword
'-hook
*))
214 (let ((event-hook-list nil
))
215 (defun get-event-hook-list ()
218 (defmacro use-event-hook
(event-keyword)
219 (let ((symb (event-hook-name event-keyword
)))
220 (pushnew symb event-hook-list
)
221 `(defvar ,symb nil
)))
223 (defun unuse-event-hook (event-keyword)
224 (let ((symb (event-hook-name event-keyword
)))
225 (setf event-hook-list
(remove symb event-hook-list
))
228 (defmacro add-event-hook
(name &rest value
)
229 (let ((symb (event-hook-name name
)))
230 `(add-hook ,symb
,@value
)))
232 (defmacro remove-event-hook
(name &rest value
)
233 (let ((symb (event-hook-name name
)))
234 `(remove-hook ,symb
,@value
)))
236 (defun clear-event-hooks ()
237 (dolist (symb event-hook-list
)
241 (defun optimize-event-hook ()
242 "Remove unused event hooks"
243 (dolist (symb event-hook-list
)
244 (when (and (boundp symb
)
245 (null (symbol-value symb
)))
247 (setf event-hook-list
(remove symb event-hook-list
))))))
251 (defmacro define-event-hook
(event-keyword args
&body body
)
252 (let ((event-fun (gensym)))
253 `(let ((,event-fun
(lambda (&rest event-slots
&key
#+:event-debug event-key
,@args
&allow-other-keys
)
254 (declare (ignorable event-slots
))
255 #+:event-debug
(print (list ,event-keyword event-key
))
257 (add-event-hook ,event-keyword
,event-fun
)
261 (defmacro event-defun
(name args
&body body
)
262 `(defun ,name
(&rest event-slots
&key
#+:event-debug event-key
,@args
&allow-other-keys
)
263 (declare (ignorable event-slots
))
264 #+:event-debug
(print (list ,event-keyword event-key
))
267 (defun exit-handle-event ()
268 (throw 'exit-handle-event nil
))
271 (defun handle-event (&rest event-slots
&key event-key
&allow-other-keys
)
272 (labels ((make-xlib-window (xobject)
273 "For some reason the clx xid cache screws up returns pixmaps when
274 they should be windows. So use this function to make a window out of them."
275 ;; Workaround for pixmap error taken from STUMPWM - thanks:
276 ;; XXX: In both the clisp and sbcl clx libraries, sometimes what
277 ;; should be a window will be a pixmap instead. In this case, we
278 ;; need to manually translate it to a window to avoid breakage
279 ;; in stumpwm. So far the only slot that seems to be affected is
280 ;; the :window slot for configure-request and reparent-notify
281 ;; events. It appears as though the hash table of XIDs and clx
282 ;; structures gets out of sync with X or perhaps X assigns a
283 ;; duplicate ID for a pixmap and a window.
284 #+clisp
(make-instance 'xlib
:window
:id
(slot-value xobject
'xlib
::id
) :display
*display
*)
285 #+(or sbcl ecl openmcl
) (xlib::make-window
:id
(slot-value xobject
'xlib
::id
) :display
*display
*)
286 #-
(or sbcl clisp ecl openmcl
)
287 (error 'not-implemented
)))
289 (catch 'exit-handle-event
290 (let ((win (getf event-slots
:window
)))
291 (when (and win
(not (xlib:window-p win
)))
292 (dbg "Pixmap Workaround! Should be a window: " win
)
293 (setf (getf event-slots
:window
) (make-xlib-window win
))))
294 (let ((hook-symbol (event-hook-name event-key
)))
295 (when (boundp hook-symbol
)
296 (apply #'call-hook
(symbol-value hook-symbol
) event-slots
)))
297 (if (fboundp event-key
)
298 (apply event-key event-slots
)
299 #+:event-debug
(pushnew (list *current-event-mode
* event-key
) *unhandled-events
* :test
#'equal
))
300 (xlib:display-finish-output
*display
*))
301 ((or xlib
:window-error xlib
:drawable-error
) (c)
302 #-xlib-debug
(declare (ignore c
))
303 #+xlib-debug
(format t
"Ignore Xlib synchronous error: ~a~%" c
)))
310 (defun parse-display-string (display)
311 "Parse an X11 DISPLAY string and return the host and display from it."
312 (let* ((colon (position #\
: display
))
313 (host (subseq display
0 colon
))
314 (rest (subseq display
(1+ colon
)))
315 (dot (position #\. rest
))
316 (num (parse-integer (subseq rest
0 dot
))))
320 ;;; Transparency support
321 (let ((opaque #xFFFFFFFF
))
322 (defun window-transparency (window)
323 "Return the window transparency"
324 (float (/ (or (first (xlib:get-property window
:_NET_WM_WINDOW_OPACITY
)) opaque
) opaque
)))
326 (defun set-window-transparency (window value
)
327 "Set the window transparency"
328 (when (numberp value
)
329 (xlib:change-property window
:_NET_WM_WINDOW_OPACITY
330 (list (max (min (round (* opaque
(if (equal *transparent-background
* t
) value
1)))
335 (defsetf window-transparency set-window-transparency
))
339 (defun maxmin-size-equal-p (window)
340 (when (xlib:window-p window
)
341 (let ((hints (xlib:wm-normal-hints window
)))
343 (let ((hint-x (xlib:wm-size-hints-x hints
))
344 (hint-y (xlib:wm-size-hints-y hints
))
345 (user-specified-position-p (xlib:wm-size-hints-user-specified-position-p hints
))
346 (min-width (xlib:wm-size-hints-min-width hints
))
347 (min-height (xlib:wm-size-hints-min-height hints
))
348 (max-width (xlib:wm-size-hints-max-width hints
))
349 (max-height (xlib:wm-size-hints-max-height hints
)))
350 (and hint-x hint-y min-width max-width min-height max-height
351 user-specified-position-p
352 (= hint-x
0) (= hint-y
0)
353 (= min-width max-width
)
354 (= min-height max-height
)))))))
356 (defun maxmin-size-equal-window-in-tree ()
357 (dolist (win (xlib:query-tree
*root
*))
358 (when (maxmin-size-equal-p win
)
364 (defun window-state (win)
365 "Get the state (iconic, normal, withdrawn) of a window."
366 (first (xlib:get-property win
:WM_STATE
)))
369 (defun set-window-state (win state
)
370 "Set the state (iconic, normal, withdrawn) of a window."
371 (xlib:change-property win
377 (defsetf window-state set-window-state
)
381 (defun window-hidden-p (window)
382 (eql (window-state window
) +iconic-state
+))
385 (defun window-transient-for (window)
386 (first (xlib:get-property window
:WM_TRANSIENT_FOR
)))
388 (defun window-leader (window)
389 (when (xlib:window-p window
)
390 (or (first (xlib:get-property window
:WM_CLIENT_LEADER
))
391 (let ((id (window-transient-for window
)))
393 (window-leader id
))))))
397 (defun unhide-window (window)
399 (when (window-hidden-p window
)
400 (xlib:map-window window
)
401 (setf (window-state window
) +normal-state
+
402 (xlib:window-event-mask window
) *window-events
*))))
405 (defun map-window (window)
407 (xlib:map-window window
)))
410 (defun delete-window (window)
411 (send-client-message window
:WM_PROTOCOLS
412 (xlib:intern-atom
*display
* :WM_DELETE_WINDOW
)))
414 (defun destroy-window (window)
415 (xlib:kill-client
*display
* (xlib:window-id window
)))
418 ;;(defconstant +exwm-atoms+
419 ;; (list "_NET_SUPPORTED" "_NET_CLIENT_LIST"
420 ;; "_NET_CLIENT_LIST_STACKING" "_NET_NUMBER_OF_DESKTOPS"
421 ;; "_NET_CURRENT_DESKTOP" "_NET_DESKTOP_GEOMETRY"
422 ;; "_NET_DESKTOP_VIEWPORT" "_NET_DESKTOP_NAMES"
423 ;; "_NET_ACTIVE_WINDOW" "_NET_WORKAREA"
424 ;; "_NET_SUPPORTING_WM_CHECK" "_NET_VIRTUAL_ROOTS"
425 ;; "_NET_DESKTOP_LAYOUT"
427 ;; "_NET_RESTACK_WINDOW" "_NET_REQUEST_FRAME_EXTENTS"
428 ;; "_NET_MOVERESIZE_WINDOW" "_NET_CLOSE_WINDOW"
429 ;; "_NET_WM_MOVERESIZE"
431 ;; "_NET_WM_SYNC_REQUEST" "_NET_WM_PING"
433 ;; "_NET_WM_NAME" "_NET_WM_VISIBLE_NAME"
434 ;; "_NET_WM_ICON_NAME" "_NET_WM_VISIBLE_ICON_NAME"
435 ;; "_NET_WM_DESKTOP" "_NET_WM_WINDOW_TYPE"
436 ;; "_NET_WM_STATE" "_NET_WM_STRUT"
437 ;; "_NET_WM_ICON_GEOMETRY" "_NET_WM_ICON"
438 ;; "_NET_WM_PID" "_NET_WM_HANDLED_ICONS"
439 ;; "_NET_WM_USER_TIME" "_NET_FRAME_EXTENTS"
440 ;; ;; "_NET_WM_MOVE_ACTIONS"
442 ;; "_NET_WM_WINDOW_TYPE_DESKTOP" "_NET_WM_STATE_MODAL"
443 ;; "_NET_WM_WINDOW_TYPE_DOCK" "_NET_WM_STATE_STICKY"
444 ;; "_NET_WM_WINDOW_TYPE_TOOLBAR" "_NET_WM_STATE_MAXIMIZED_VERT"
445 ;; "_NET_WM_WINDOW_TYPE_MENU" "_NET_WM_STATE_MAXIMIZED_HORZ"
446 ;; "_NET_WM_WINDOW_TYPE_UTILITY" "_NET_WM_STATE_SHADED"
447 ;; "_NET_WM_WINDOW_TYPE_SPLASH" "_NET_WM_STATE_SKIP_TASKBAR"
448 ;; "_NET_WM_WINDOW_TYPE_DIALOG" "_NET_WM_STATE_SKIP_PAGER"
449 ;; "_NET_WM_WINDOW_TYPE_NORMAL" "_NET_WM_STATE_HIDDEN"
450 ;; "_NET_WM_STATE_FULLSCREEN"
451 ;; "_NET_WM_STATE_ABOVE"
452 ;; "_NET_WM_STATE_BELOW"
453 ;; "_NET_WM_STATE_DEMANDS_ATTENTION"
455 ;; "_NET_WM_ALLOWED_ACTIONS"
456 ;; "_NET_WM_ACTION_MOVE"
457 ;; "_NET_WM_ACTION_RESIZE"
458 ;; "_NET_WM_ACTION_SHADE"
459 ;; "_NET_WM_ACTION_STICK"
460 ;; "_NET_WM_ACTION_MAXIMIZE_HORZ"
461 ;; "_NET_WM_ACTION_MAXIMIZE_VERT"
462 ;; "_NET_WM_ACTION_FULLSCREEN"
463 ;; "_NET_WM_ACTION_CHANGE_DESKTOP"
464 ;; "_NET_WM_ACTION_CLOSE"
469 ;;(defun intern-atoms (display)
470 ;; (declare (type xlib:display display))
471 ;; (mapcar #'(lambda (atom-name) (xlib:intern-atom display atom-name))
477 ;;(defun get-atoms-property (window property-atom atom-list-p)
478 ;; "Returns a list of atom-name (if atom-list-p is t) otherwise returns
479 ;; a list of atom-id."
480 ;; (xlib:get-property window property-atom
481 ;; :transform (when atom-list-p
483 ;; (xlib:atom-name (xlib:drawable-display window) id)))))
485 ;;(defun set-atoms-property (window atoms property-atom &key (mode :replace))
486 ;; "Sets the property designates by `property-atom'. ATOMS is a list of atom-id
487 ;; or a list of keyword atom-names."
488 ;; (xlib:change-property window property-atom atoms :ATOM 32
490 ;; :transform (unless (integerp (car atoms))
491 ;; (lambda (atom-key)
492 ;; (xlib:find-atom (xlib:drawable-display window) atom-key)))))
497 ;;(defun net-wm-state (window)
498 ;; (get-atoms-property window :_NET_WM_STATE t))
500 ;;(defsetf net-wm-state (window &key (mode :replace)) (states)
501 ;; `(set-atoms-property ,window ,states :_NET_WM_STATE :mode ,mode))
504 (defun hide-window (window)
506 (setf (window-state window
) +iconic-state
+
507 (xlib:window-event-mask window
) (remove :structure-notify
*window-events
*))
508 (xlib:unmap-window window
)
509 (setf (xlib:window-event-mask window
) *window-events
*)))
513 (defun window-type (window)
514 "Return one of :desktop, :dock, :toolbar, :utility, :splash,
515 :dialog, :transient, :maxsize and :normal."
516 (when (xlib:window-p window
)
517 (or (and (let ((hints (xlib:wm-normal-hints window
)))
518 (and hints
(or (and (xlib:wm-size-hints-max-width hints
)
519 (< (xlib:wm-size-hints-max-width hints
) (x-drawable-width *root
*)))
520 (and (xlib:wm-size-hints-max-height hints
)
521 (< (xlib:wm-size-hints-max-height hints
) (x-drawable-height *root
*)))
522 (xlib:wm-size-hints-min-aspect hints
)
523 (xlib:wm-size-hints-max-aspect hints
))))
525 (let ((net-wm-window-type (xlib:get-property window
:_NET_WM_WINDOW_TYPE
)))
526 (when net-wm-window-type
527 (dolist (type-atom net-wm-window-type
)
528 (when (assoc (xlib:atom-name
*display
* type-atom
) +netwm-window-types
+)
529 (return (cdr (assoc (xlib:atom-name
*display
* type-atom
) +netwm-window-types
+)))))))
530 (and (xlib:get-property window
:WM_TRANSIENT_FOR
)
537 ;;; Stolen from Eclipse
538 (defun send-configuration-notify (window x y w h bw
)
539 "Send a synthetic configure notify event to the given window (ICCCM 4.1.5)"
540 (xlib:send-event window
:configure-notify
(xlib:make-event-mask
:structure-notify
)
551 (defun send-client-message (window type
&rest data
)
552 "Send a client message to a client's window."
553 (xlib:send-event window
564 (defun raise-window (window)
565 "Map the window if needed and bring it to the top of the stack. Does not affect focus."
566 (when (xlib:window-p window
)
567 (when (window-hidden-p window
)
568 (unhide-window window
))
569 (setf (xlib:window-priority window
) :above
)))
573 "don't focus any window but still read keyboard events."
574 (xlib:set-input-focus
*display
* *no-focus-window
* :pointer-root
))
576 (defun focus-window (window)
577 "Give the window focus."
579 (when (xlib:window-p window
)
580 (xlib:set-input-focus
*display
* window
:parent
)))
582 (defun raise-and-focus-window (window)
584 (raise-window window
)
585 (focus-window window
))
588 (defun lower-window (window sibling
)
589 "Map the window if needed and bring it just above sibling. Does not affect focus."
590 (when (xlib:window-p window
)
591 (when (window-hidden-p window
)
592 (unhide-window window
))
593 (setf (xlib:window-priority window sibling
) :below
)))
598 (let ((cursor-font nil
)
600 (pointer-grabbed nil
))
601 (defun free-grab-pointer ()
603 (xlib:free-cursor cursor
)
606 (xlib:close-font cursor-font
)
607 (setf cursor-font nil
)))
609 (defun xgrab-init-pointer ()
610 (setf pointer-grabbed nil
))
612 (defun xgrab-pointer-p ()
615 (defun xgrab-pointer (root cursor-char cursor-mask-char
616 &optional
(pointer-mask '(:enter-window
:pointer-motion
617 :button-press
:button-release
)) owner-p
)
618 "Grab the pointer and set the pointer shape."
619 (when pointer-grabbed
621 (setf pointer-grabbed t
)
622 (let* ((white (xlib:make-color
:red
1.0 :green
1.0 :blue
1.0))
623 (black (xlib:make-color
:red
0.0 :green
0.0 :blue
0.0)))
625 (setf cursor-font
(xlib:open-font
*display
* "cursor")
626 cursor
(xlib:create-glyph-cursor
:source-font cursor-font
627 :source-char
(or cursor-char
68)
628 :mask-font cursor-font
629 :mask-char
(or cursor-mask-char
69)
632 (xlib:grab-pointer root pointer-mask
633 :owner-p owner-p
:sync-keyboard-p nil
:sync-pointer-p nil
:cursor cursor
))
635 (xlib:grab-pointer root pointer-mask
636 :owner-p owner-p
:sync-keyboard-p nil
:sync-pointer-p nil
)))))
638 (defun xungrab-pointer ()
639 "Remove the grab on the cursor and restore the cursor shape."
640 (setf pointer-grabbed nil
)
641 (xlib:ungrab-pointer
*display
*)
642 (xlib:display-finish-output
*display
*)
643 (free-grab-pointer)))
646 (let ((keyboard-grabbed nil
))
647 (defun xgrab-init-keyboard ()
648 (setf keyboard-grabbed nil
))
650 (defun xgrab-keyboard-p ()
653 (defun xgrab-keyboard (root)
654 (setf keyboard-grabbed t
)
655 (xlib:grab-keyboard root
:owner-p nil
:sync-keyboard-p nil
:sync-pointer-p nil
))
658 (defun xungrab-keyboard ()
659 (setf keyboard-grabbed nil
)
660 (xlib:ungrab-keyboard
*display
*)))
667 (defun ungrab-all-buttons (window)
668 (xlib:ungrab-button window
:any
:modifiers
:any
))
670 (defun grab-all-buttons (window)
671 (ungrab-all-buttons window
)
672 (xlib:grab-button window
:any
'(:button-press
:button-release
:pointer-motion
)
676 :sync-keyboard-p nil
))
678 (defun ungrab-all-keys (window)
679 (xlib:ungrab-key window
:any
:modifiers
:any
))
683 (defmacro with-grab-keyboard-and-pointer
((cursor mask old-cursor old-mask
&optional ungrab-main
) &body body
)
684 `(let ((pointer-grabbed (xgrab-pointer-p))
685 (keyboard-grabbed (xgrab-keyboard-p)))
686 (xgrab-pointer *root
* ,cursor
,mask
)
687 (unless keyboard-grabbed
690 (xgrab-keyboard *root
*))
696 (xgrab-pointer *root
* ,old-cursor
,old-mask
)
698 (unless keyboard-grabbed
701 (xungrab-keyboard))))))
704 (defmacro with-grab-pointer
((&optional cursor-char cursor-mask-char
) &body body
)
705 `(let ((pointer-grabbed-p (xgrab-pointer-p)))
706 (unless pointer-grabbed-p
707 (xgrab-pointer *root
* ,cursor-char
,cursor-mask-char
))
711 (unless pointer-grabbed-p
712 (xungrab-pointer)))))
718 (defun stop-button-event ()
719 (xlib:allow-events
*display
* :sync-pointer
))
721 (defun replay-button-event ()
722 (xlib:allow-events
*display
* :replay-pointer
))
732 ;;; Mouse action on window
733 (let (add-fn add-arg dx dy window
)
734 (define-handler move-window-mode
:motion-notify
(root-x root-y
)
735 (unless (compress-motion-notify)
737 (multiple-value-bind (move-x move-y
)
738 (apply add-fn add-arg
)
740 (setf (x-drawable-x window
) (+ root-x dx
)))
742 (setf (x-drawable-y window
) (+ root-y dy
))))
743 (setf (x-drawable-x window
) (+ root-x dx
)
744 (x-drawable-y window
) (+ root-y dy
)))))
746 (define-handler move-window-mode
:key-release
()
747 (throw 'exit-move-window-mode nil
))
749 (define-handler move-window-mode
:button-release
()
750 (throw 'exit-move-window-mode nil
))
752 (defun move-window (orig-window orig-x orig-y
&optional additional-fn additional-arg
)
753 (setf window orig-window
755 add-arg additional-arg
756 dx
(- (x-drawable-x window
) orig-x
)
757 dy
(- (x-drawable-y window
) orig-y
)
758 (xlib:window-border window
) (get-color *color-move-window
*))
759 (raise-window window
)
760 (with-grab-pointer ()
762 (apply additional-fn additional-arg
))
763 (generic-mode 'move-window-mode
'exit-move-window-mode
764 :original-mode
'(main-mode)))))
767 (let (add-fn add-arg window
769 orig-width orig-height
771 min-height max-height
)
772 (define-handler resize-window-mode
:motion-notify
(root-x root-y
)
773 (unless (compress-motion-notify)
775 (multiple-value-bind (resize-w resize-h
)
776 (apply add-fn add-arg
)
778 (setf (x-drawable-width window
) (min (max (+ orig-width
(- root-x o-x
)) 10 min-width
) max-width
)))
780 (setf (x-drawable-height window
) (min (max (+ orig-height
(- root-y o-y
)) 10 min-height
) max-height
))))
781 (setf (x-drawable-width window
) (min (max (+ orig-width
(- root-x o-x
)) 10 min-width
) max-width
)
782 (x-drawable-height window
) (min (max (+ orig-height
(- root-y o-y
)) 10 min-height
) max-height
)))))
784 (define-handler resize-window-mode
:key-release
()
785 (throw 'exit-resize-window-mode nil
))
787 (define-handler resize-window-mode
:button-release
()
788 (throw 'exit-resize-window-mode nil
))
790 (defun resize-window (orig-window orig-x orig-y
&optional additional-fn additional-arg
)
791 (let* ((hints (xlib:wm-normal-hints orig-window
)))
792 (setf window orig-window
794 add-arg additional-arg
797 orig-width
(x-drawable-width window
)
798 orig-height
(x-drawable-height window
)
799 min-width
(or (and hints
(xlib:wm-size-hints-min-width hints
)) 0)
800 min-height
(or (and hints
(xlib:wm-size-hints-min-height hints
)) 0)
801 max-width
(or (and hints
(xlib:wm-size-hints-max-width hints
)) most-positive-fixnum
)
802 max-height
(or (and hints
(xlib:wm-size-hints-max-height hints
)) most-positive-fixnum
)
803 (xlib:window-border window
) (get-color *color-move-window
*))
804 (raise-window window
)
805 (with-grab-pointer ()
807 (apply additional-fn additional-arg
))
808 (generic-mode 'resize-window-mode
'exit-resize-window-mode
809 :original-mode
'(main-mode))))))
813 (define-handler wait-mouse-button-release-mode
:button-release
()
814 (throw 'exit-wait-mouse-button-release-mode nil
))
816 (defun wait-mouse-button-release (&optional cursor-char cursor-mask-char
)
817 (with-grab-pointer (cursor-char cursor-mask-char
)
818 (generic-mode 'wait-mouse-button-release
'exit-wait-mouse-button-release-mode
)))
824 (let ((color-hash (make-hash-table :test
'equal
)))
825 (defun get-color (color)
826 (multiple-value-bind (val foundp
)
827 (gethash color color-hash
)
830 (setf (gethash color color-hash
)
831 (xlib:alloc-color
(xlib:screen-default-colormap
*screen
*) color
))))))
835 (defgeneric -
>color
(color))
837 (defmethod ->color
((color-name string
))
840 (defmethod ->color
((color integer
))
841 (labels ((hex->float
(color)
842 (/ (logand color
#xFF
) 256.0)))
843 (xlib:make-color
:blue
(hex->float color
)
844 :green
(hex->float
(ash color -
8))
845 :red
(hex->float
(ash color -
16)))))
847 (defmethod ->color
((color list
))
848 (destructuring-bind (red green blue
) color
849 (xlib:make-color
:blue red
:green green
:red blue
)))
851 (defmethod ->color
((color xlib
:color
))
854 (defmethod ->color
(color)
855 (format t
"Wrong color type: ~A~%" color
)
859 (defun color->rgb
(color)
860 (multiple-value-bind (r g b
)
861 (xlib:color-rgb color
)
862 (+ (ash (round (* 256 r
)) +16)
863 (ash (round (* 256 g
)) +8)
870 (defmacro my-character-
>keysyms
(ch)
871 "Convert a char to a keysym"
872 ;; XLIB:CHARACTER->KEYSYMS should probably be implemented in NEW-CLX
873 ;; some day. Or just copied from MIT-CLX or some other CLX
874 ;; implementation (see translate.lisp and keysyms.lisp). For now,
875 ;; we do like this. It suffices for modifiers and ASCII symbols.
876 (if (fboundp 'xlib
:character-
>keysyms
)
877 `(xlib:character-
>keysyms
,ch
)
880 (:character-set-switch
#xFF7E
)
882 (:right-shift
#xFFE2
)
883 (:left-control
#xFFE3
)
884 (:right-control
#xFFE4
)
892 (:right-super
#xFFEC
)
894 (:right-hyper
#xFFEE
)
898 ;; Latin-1 characters have their own value as keysym
899 (if (< 31 (char-code ,ch
) 256)
901 (error "Don't know how to get keysym from ~A" ,ch
)))))))))
906 (defun char->keycode
(char)
907 "Convert a character to a keycode"
908 (xlib:keysym-
>keycodes
*display
* (first (my-character->keysyms char
))))
911 (defun keycode->char
(code state
)
912 (xlib:keysym-
>character
*display
* (xlib:keycode-
>keysym
*display
* code
0) state
))
914 (defun modifiers->state
(modifier-list)
915 (apply #'xlib
:make-state-mask modifier-list
))
917 (defun state->modifiers
(state)
918 (xlib:make-state-keys state
))
920 (defun keycode->keysym
(code modifiers
)
921 (xlib:keycode-
>keysym
*display
* code
(cond ((member :shift modifiers
) 1)
922 ((member :mod-5 modifiers
) 4)
929 (let ((modifier-list nil
))
930 (defun init-modifier-list ()
931 (dolist (name '("Shift_L" "Shift_R" "Control_L" "Control_R"
932 "Alt_L" "Alt_R" "Meta_L" "Meta_R" "Hyper_L" "Hyper_R"
933 "Mode_switch" "script_switch" "ISO_Level3_Shift"
934 "Caps_Lock" "Scroll_Lock" "Num_Lock"))
935 (awhen (xlib:keysym-
>keycodes
*display
* (keysym-name->keysym name
))
936 (push it modifier-list
))))
938 (defun modifier-p (code)
939 (member code modifier-list
)))
941 (defun wait-no-key-or-button-press ()
942 (with-grab-keyboard-and-pointer (66 67 66 67)
944 (let ((key (loop for k across
(xlib:query-keymap
*display
*)
946 when
(and (plusp k
) (not (modifier-p code
)))
948 (button (loop for b in
(xlib:make-state-keys
(nth-value 4 (xlib:query-pointer
*root
*)))
949 when
(member b
'(:button-1
:button-2
:button-3
:button-4
:button-5
))
951 (when (and (not key
) (not button
))
952 (loop while
(xlib:event-case
(*display
* :discard-p t
:peek-p nil
:timeout
0)
953 (:motion-notify
() t
)
957 (:button-release
() t
)
962 (defun wait-a-key-or-button-press ()
963 (with-grab-keyboard-and-pointer (24 25 66 67)
965 (let ((key (loop for k across
(xlib:query-keymap
*display
*)
966 unless
(zerop k
) return t
))
967 (button (loop for b in
(xlib:make-state-keys
(nth-value 4 (xlib:query-pointer
*root
*)))
968 when
(member b
'(:button-1
:button-2
:button-3
:button-4
:button-5
))
970 (when (or key button
)
975 (defun compress-motion-notify ()
976 (when *have-to-compress-notify
*
977 (loop while
(xlib:event-cond
(*display
* :timeout
0)
978 (:motion-notify
() t
)))))
981 (defun display-all-cursors (&optional
(display-time 1))
982 "Display all X11 cursors for display-time seconds"
983 (loop for i from
0 to
152 by
2
984 do
(xgrab-pointer *root
* i
(1+ i
))
991 ;;; Double buffering tools
992 (defun clear-pixmap-buffer (window gc
)
993 (if (equal *transparent-background
* :pseudo
)
994 (xlib:copy-area
*background-image
* *background-gc
*
995 (x-drawable-x window
) (x-drawable-y window
)
996 (x-drawable-width window
) (x-drawable-height window
)
998 (xlib:with-gcontext
(gc :foreground
(xlib:gcontext-background gc
)
999 :background
(xlib:gcontext-foreground gc
))
1000 (xlib:draw-rectangle
*pixmap-buffer
* gc
1001 0 0 (x-drawable-width window
) (x-drawable-height window
)
1005 (defun copy-pixmap-buffer (window gc
)
1006 (xlib:copy-area
*pixmap-buffer
* gc
1007 0 0 (x-drawable-width window
) (x-drawable-height window
)
1012 (defun is-a-key-pressed-p ()
1013 (loop for k across
(xlib:query-keymap
*display
*)
1017 ;;; Windows wm class and name tests
1018 (defmacro defun-equal-wm-class
(symbol class
)
1019 `(defun ,symbol
(window)
1020 (when (xlib:window-p window
)
1021 (string-equal (xlib:get-wm-class window
) ,class
))))
1023 (defmacro defun-equal-wm-name
(symbol name
)
1024 `(defun ,symbol
(window)
1025 (when (xlib:window-p window
)
1026 (string-equal (xlib:wm-name window
) ,name
))))