diff options
author | Shawn <sabetts@juicebox> | 2008-05-02 17:21:01 -0700 |
---|---|---|
committer | Shawn <sabetts@juicebox> | 2008-05-02 17:21:01 -0700 |
commit | c81a732f02986e542a17bc1e41447dba0f42e751 (patch) | |
tree | 016884737d568511b7421b7ddf077f75b340c19b /core.lisp | |
parent | 5ef6c3ccb9d809f2ac0b248e377f7681b423666d (diff) |
restructure almost all the code in core.lisp into seperate files.
Also update the copyright.
Diffstat (limited to 'core.lisp')
-rw-r--r-- | core.lisp | 3369 |
1 files changed, 1 insertions, 3368 deletions
@@ -1,4 +1,4 @@ -;; Copyright (C) 2003 Shawn Betts +;; Copyright (C) 2003-2008 Shawn Betts ;; ;; This file is part of stumpwm. ;; @@ -26,41 +26,6 @@ (in-package :stumpwm) -(export '(*top-map* - current-group - current-screen - current-srceen - current-window - def-window-attr - echo-string - err - get-x-selection - message - save-frame-excursion - screen-current-window - set-normal-gravity - set-maxsize-gravity - set-transient-gravity - set-window-geometry - set-fg-color - set-bg-color - set-border-color - set-win-bg-color - set-focus-color - set-unfocus-color - set-msg-border-width - set-frame-outline-width - set-font - set-x-selection - window-send-string)) - -;; Do it this way so its easier to wipe the map and get a clean one. -(when (null *top-map*) - (setf *top-map* - (let ((m (make-sparse-keymap))) - (define-key m (kbd "C-t") '*root-map*) - m))) - ;; Wow, is there an easier way to do this? (defmacro def-thing-attr-macro (thing hash-slot) (let ((attr (gensym "ATTR")) @@ -76,2649 +41,6 @@ (defun (setf ,(intern (format nil ,(format nil "~a-~~a" thing) ,attr))) (,,val ,,obj) (setf (gethash ,,attr (,(quote ,hash-slot) ,,obj))) ,,val)))))) -;; Screen helper functions - -(defun translate-id (src src-start src-end font dst dst-start) - "A simple replacement for xlib:translate-default. just the -identity with a range check." - (let ((min (xlib:font-min-char font)) - (max (xlib:font-max-char font))) - (decf src-end) - (if (stringp src) ; clx does this test so i guess it's needed - (loop for i from src-start to src-end - for j from dst-start - as c = (char-code (char src i)) - if (<= min c max) do (setf (aref dst j) c) - ;; replace unknown characters with question marks - else do (setf (aref dst j) (char-code #\?)) - finally (return i)) - (loop for i from src-start to src-end - for j from dst-start - as c = (elt src i) - as n = (if (characterp c) (char-code c) c) - if (and (integerp n) (<= min n max)) do (setf (aref dst j) n) - ;; ditto - else do (setf (aref dst j) (char-code #\?)) - finally (return i))))) - -(defun screen-x (screen) - (declare (ignore screen)) - 0) - -(defun screen-y (screen) - (declare (ignore screen)) - 0) - -(defun screen-height (screen) - (let ((root (screen-root screen))) - (xlib:drawable-height root))) - -(defun screen-true-height (screen) - "Return the height of the screen regardless of the modeline" - (let ((root (screen-root screen))) - (xlib:drawable-height root))) - -(defun screen-width (screen) - (let ((root (screen-root screen))) - (xlib:drawable-width root))) - -(defun find-screen (root) - "Return the screen containing the root window." - (find-if (lambda (s) - (xlib:window-equal (screen-root s) root)) - *screen-list*)) - -(defun screen-windows (screen) - (mapcan (lambda (g) (copy-list (group-windows g))) (screen-groups screen))) - - -;;; Group function - -(defun current-group (&optional (screen (current-screen))) - "Return the current group for the current screen, unless -otherwise specified." - (screen-current-group screen)) - -(defun move-group-to-head (screen group) - "Move window to the head of the group's window list." - ;(assert (member window (screen-mapped-windows screen))) - (setf (screen-groups screen) (delete group (screen-groups screen))) - (push group (screen-groups screen))) - -(defun sort-groups (screen) - "Return a copy of the screen's group list sorted by number." - (sort1 (screen-groups screen) '< :key 'group-number)) - -(defun fmt-group-status (group) - (let ((screen (group-screen group))) - (cond ((eq group (screen-current-group screen)) - #\*) - ((and (typep (second (screen-groups screen)) 'group) - (eq group (second (screen-groups screen)))) - #\+) - (t #\-)))) - -(defun find-free-group-number (screen) - "Return a free group number in SCREEN." - (find-free-number (mapcar 'group-number (screen-groups screen)) 1)) - -(defun find-free-hidden-group-number (screen) - "Return a free hidden group number for SCREEN. Hidden group numbers -start at -1 and go down." - (find-free-number (mapcar 'group-number (screen-groups screen)) -1 :negative)) - -(defun group-current-window (group) - (frame-window (tile-group-current-frame group))) - -(defun non-hidden-groups (groups) - "Return only those groups that are not hidden." - (remove-if (lambda (g) - (< (group-number g) 1)) - groups)) - -(defun netwm-group-id (group) - "netwm specifies that desktop/group numbers are contiguous and start -at 0. Return a netwm compliant group id." - (let ((screen (group-screen group))) - (position group (sort-groups screen)))) - -(defun switch-to-group (new-group) - (let* ((screen (group-screen new-group)) - (old-group (screen-current-group screen))) - (unless (eq new-group old-group) - ;; restore the visible windows - (dolist (w (group-windows new-group)) - (when (eq (window-state w) +normal-state+) - (xwin-unhide (window-xwin w) (window-parent w)))) - (dolist (w (reverse (group-windows old-group))) - (when (eq (window-state w) +normal-state+) - (xwin-hide w))) - (setf (screen-current-group screen) new-group) - (move-group-to-head screen new-group) - ;; restore the focus - (setf (screen-focus screen) nil) - (focus-frame new-group (tile-group-current-frame new-group)) - (xlib:change-property (screen-root screen) :_NET_CURRENT_DESKTOP - (list (netwm-group-id new-group)) - :cardinal 32) - (run-hook-with-args *focus-group-hook* new-group old-group))) - (show-frame-indicator new-group)) - -(defun move-window-to-group (window to-group) - (labels ((really-move-window (window to-group) - (unless (eq (window-group window) to-group) - (let ((old-group (window-group window)) - (old-frame (window-frame window))) - (hide-window window) - ;; house keeping - (setf (group-windows (window-group window)) - (remove window (group-windows (window-group window)))) - (setf (window-frame window) (tile-group-current-frame to-group) - (window-group window) to-group - (window-number window) (find-free-window-number to-group)) - ;; try to put the window in the appropriate frame for the group - (multiple-value-bind (placed-group frame raise) (get-window-placement (window-screen window) window) - (declare (ignore placed-group)) - (when frame - (setf (window-frame window) frame) - (when raise - (setf (tile-group-current-frame to-group) frame - (frame-window frame) nil)))) - (push window (group-windows to-group)) - (sync-frame-windows to-group (tile-group-current-frame to-group)) - ;; maybe pick a new window for the old frame - (when (eq (frame-window old-frame) window) - (setf (frame-window old-frame) (first (frame-windows old-group old-frame))) - (focus-frame old-group old-frame)) - ;; maybe show the window in its new frame - (when (null (frame-window (window-frame window))) - (frame-raise-window (window-group window) (window-frame window) window)) - (xlib:change-property (window-xwin window) :_NET_WM_DESKTOP - (list (netwm-group-id to-group)) - :cardinal 32))))) - ;; When a modal window is moved, all the windows it shadows must be moved - ;; as well. When a shadowed window is moved, the modal shadowing it must - ;; be moved. - (cond - ((window-modal-p window) - (mapc (lambda (w) - (really-move-window w to-group)) - (append (list window) (shadows-of window)))) - ((modals-of window) - (mapc (lambda (w) - (move-window-to-group w to-group)) - (modals-of window))) - (t - (really-move-window window to-group))))) - -(defun next-group (current &optional (list (screen-groups (group-screen current)))) - ;; ditch the negative groups - (setf list (non-hidden-groups list)) - (let* ((matches (member current list))) - (if (null (cdr matches)) - ;; If the last one in the list is current, then - ;; use the first one. - (car list) - ;; Otherwise, use the next one in the list. - (cadr matches)))) - -(defun merge-groups (from-group to-group) - "Merge all windows in FROM-GROUP into TO-GROUP." - (dolist (window (group-windows from-group)) - (move-window-to-group window to-group))) - -(defun netwm-update-groups (screen) - "update all windows to reflect a change in the group list." - ;; FIXME: This could be optimized only to update windows when there - ;; is a need. - (loop for i from 0 - for group in (sort-groups screen) - do (dolist (w (group-windows group)) - (xlib:change-property (window-xwin w) :_NET_WM_DESKTOP - (list i) - :cardinal 32)))) - -(defun kill-group (group to-group) - (when (> (length (screen-groups (group-screen group))) 1) - (let ((screen (group-screen group))) - (merge-groups group to-group) - (setf (screen-groups screen) (remove group (screen-groups screen))) - (netwm-update-groups screen)))) - -(defun netwm-set-group-properties (screen) - "Set NETWM properties regarding groups of SCREEN. -Groups are known as \"virtual desktops\" in the NETWM standard." - (let ((root (screen-root screen))) - ;; _NET_NUMBER_OF_DESKTOPS - (xlib:change-property root :_NET_NUMBER_OF_DESKTOPS - (list (length (screen-groups screen))) - :cardinal 32) - (unless *initializing* - ;; _NET_CURRENT_DESKTOP - (xlib:change-property root :_NET_CURRENT_DESKTOP - (list (netwm-group-id (screen-current-group screen))) - :cardinal 32)) - ;; _NET_DESKTOP_NAMES - (xlib:change-property root :_NET_DESKTOP_NAMES - (let ((names (mapcan - (lambda (group) - (list (string-to-utf8 (group-name group)) - '(0))) - (sort-groups screen)))) - (apply #'concatenate 'list names)) - :UTF8_STRING 8))) - -(defun add-group (screen name) - "Create a new group in SCREEN with the supplied name. group names - starting with a . are considered hidden groups. Hidden groups are - skipped by gprev and gnext and do not show up in the group - listings (unless *list-hidden-groups* is T). They also use negative - numbers." - (check-type screen screen) - (check-type name string) - (unless (or (string= name "") - (string= name ".")) - (or (find-group screen name) - (let* ((heads (copy-heads screen)) - (ng (make-tile-group - :frame-tree heads - :current-frame (first heads) - :screen screen - :number (if (char= (char name 0) #\.) - (find-free-hidden-group-number screen) - (find-free-group-number screen)) - :name name))) - (setf (screen-groups screen) (append (screen-groups screen) (list ng))) - (netwm-set-group-properties screen) - (netwm-update-groups screen) - ng)))) - -(defun find-group (screen name) - "Return the group with the name, NAME. Or NIL if none exists." - (find name (screen-groups screen) :key 'group-name :test 'string=)) - - -;;; Window functions - - -;; Since StumpWM already uses the term 'group' to refer to Virtual Desktops, -;; we'll call the grouped windows of an application a 'gang' - -;; maybe follow transient_for to find leader. -(defun window-leader (window) - (when window - (or (first (window-property window :WM_CLIENT_LEADER)) - (let ((id (window-transient-for window))) - (when id - (window-leader (window-by-id id))))))) - -;; A modal dialog can either shadow a single window, or all windows -;; in its gang, depending on the value of WM_TRANSIENT_FOR - -;; If a window is shadowed by a modal dialog, so are any other -;; transients belonging to that window. - -(defun window-transient-for (window) - (first (window-property window :WM_TRANSIENT_FOR))) - -(defun window-modal-p (window) - (find-wm-state (window-xwin window) :_NET_WM_STATE_MODAL)) - -(defun window-transient-p (window) - (find (window-type window) '(:transient :dialog))) - -;; FIXME: use WM_HINTS.group_leader -(defun window-gang (window) - "Return a list of other windows in WINDOW's gang." - (let ((leader (window-leader window)) - (screen (window-screen window))) - (when leader - (loop for w in (screen-windows screen) - as l = (window-leader w) - if (and (not (eq w window)) l (= leader l)) - collect w)))) - -(defun only-modals (windows) - "Out of WINDOWS, return a list of those which are modal." - (remove-if-not 'window-modal-p (copy-list windows))) - -(defun x-of (window filter) - (let* ((root (screen-root (window-screen window))) - (root-id (xlib:drawable-id root)) - (win-id (xlib:window-id (window-xwin window)))) - (loop for w in (funcall filter (window-gang window)) - as tr = (window-transient-for w) - when (or (not tr) ; modal for group - (eq tr root-id) ; ditto - (eq tr win-id)) ; modal for win - collect w))) - - -;; The modals of a transient are the modals of the window -;; the transient belongs to. -(defun modals-of (window) - "Given WINDOW return the modal dialogs which are shadowing it, if any." - (loop for m in (only-modals (window-gang window)) - when (find window (shadows-of m)) - collect m)) - -(defun transients-of (window) - "Return the transient dialogs belonging to WINDOW" - (x-of window 'only-transients)) - -(defun shadows-of (window) - "Given modal window WINDOW return the list of windows in its shadow." - (let* ((root (screen-root (window-screen window))) - (root-id (xlib:drawable-id root)) - (tr (window-transient-for window))) - (cond - ((or (not tr) - (eq tr root-id)) - (window-gang window)) - (t - (let ((w (window-by-id tr))) - (append (list w) (transients-of w))))))) - -(defun only-transients (windows) - "Out of WINDOWS, return a list of those which are transient." - (remove-if-not 'window-transient-p (copy-list windows))) - -(defun really-raise-window (window) - (frame-raise-window (window-group window) (window-frame window) window)) - -(defun raise-modals-of (window) - (mapc 'really-raise-window (modals-of window))) - -(defun raise-modals-of-gang (window) - (mapc 'really-raise-window (only-modals (window-gang window)))) - -(defun raise-transients-of-gang (window) - (mapc 'really-raise-window (only-transients (window-gang window)))) - -(defun all-windows () - (mapcan (lambda (s) (copy-list (screen-windows s))) *screen-list*)) - -(defun visible-windows () - "Return a list of visible windows (on all screens)" - (loop for s in *screen-list* - nconc (delete-if 'window-hidden-p (copy-list (group-windows (screen-current-group s)))))) - -(defun top-windows () - "Return a list of windows on top (on all screen)" - (loop for s in *screen-list* - nconc (mapcar 'frame-window (group-frames (screen-current-group s))))) - -(defun window-name (window) - (or (window-user-title window) - (case *window-name-source* - (:resource-name (window-res window)) - (:class (window-class window)) - (t (window-title window))))) - -(defun window-id (window) - (xlib:window-id (window-xwin window))) - -(defun window-in-current-group-p (window) - (eq (window-group window) - (screen-current-group (window-screen window)))) - -(defun window-screen (window) - (group-screen (window-group window))) - -(defun update-window-border (window) - ;; give it a colored border but only if there are more than 1 frames. - (let* ((group (window-group window)) - (screen (group-screen group))) - (let ((c (if (and (> (length (group-frames group)) 1) - (eq (group-current-window group) window)) - (screen-focus-color screen) - (screen-unfocus-color screen)))) - (setf (xlib:window-border (window-parent window)) c - ;; windows that dont fill the entire screen have a transparent background. - (xlib:window-background (window-parent window)) - (if (eq (window-type window) :normal) - (if (eq *window-border-style* :thick) - c - (screen-unfocus-color screen)) - :none)) - ;; get the background updated - (xlib:clear-area (window-parent window))))) - -(defun send-client-message (window type &rest data) - "Send a client message to a client's window." - (xlib:send-event (window-xwin window) - :client-message nil - :window (window-xwin window) - :type type - :format 32 - :data data)) - -(defun fmt-window-status (window) - (let ((group (window-group window))) - (cond ((eq window (group-current-window group)) - #\*) - ((and (typep (second (group-windows group)) 'window) - (eq window (second (group-windows group)))) - #\+) - (t #\-)))) - -(defun fmt-window-marked (window) - (if (window-marked window) - #\# - #\Space)) - -;; (defun update-window-mark (window) -;; "Called when we need to draw or clear the mark." -;; ;; FIXME: This doesn't work at all. I'd like to have little squares -;; ;; that look like clamps on the corners of the window, likes its -;; ;; sorta grabbed. But i dunno how to properly draw them. -;; (let* ((screen (window-screen window))) -;; (if (window-marked window) -;; (xlib:draw-rectangle (window-parent window) (screen-marked-gc (window-screen window)) -;; 0 0 300 200 t) -;; (xlib:clear-area (window-parent window))))) - -(defun xwin-net-wm-name (win) - "Return the netwm wm name" - (let ((name (xlib:get-property win :_NET_WM_NAME))) - (when name - (utf8-to-string name)))) - -(defun xwin-name (win) - (or - (xwin-net-wm-name win) - (xlib:wm-name win))) - -;; FIXME: should we raise the winodw or its parent? -(defun raise-window (win) - "Map the window if needed and bring it to the top of the stack. Does not affect focus." - (when (window-hidden-p win) - (unhide-window win) - (update-configuration win)) - (when (window-in-current-group-p win) - (setf (xlib:window-priority (window-parent win)) :top-if))) - -;; some handy wrappers - -(defun true-height (win) - (xlib:with-state (win) - (+ (xlib:drawable-height win) (* (xlib:drawable-border-width win) 2)))) - -(defun true-width (win) - (xlib:with-state (win) - (+ (xlib:drawable-width win) (* (xlib:drawable-border-width win) 2)))) - -(defun xwin-border-width (win) - (xlib:drawable-border-width win)) - -(defun (setf xwin-border-width) (width win) - (setf (xlib:drawable-border-width win) width)) - -(defun default-border-width-for-type (type) - (ecase type - (:dock 0) - (:normal *normal-border-width*) - (:maxsize *maxsize-border-width*) - ((:transient :dialog) *transient-border-width*))) - -(defun xwin-class (win) - (multiple-value-bind (res class) (xlib:get-wm-class win) - (declare (ignore res)) - class)) - -(defun xwin-res-name (win) - (multiple-value-bind (res class) (xlib:get-wm-class win) - (declare (ignore class)) - res)) - -(defun xwin-role (win) - "Return WM_WINDOW_ROLE" - (let ((name (xlib:get-property win :WM_WINDOW_ROLE))) - (dformat 10 "role: ~a~%" name) - (if name - (utf8-to-string name) - ""))) - -(defmacro def-window-attr (attr) - "Create a new window attribute and corresponding get/set functions." - (let ((win (gensym)) - (val (gensym))) - `(progn - (defun ,(intern (format nil "WINDOW-~a" attr)) (,win) - (gethash ,attr (window-plist ,win))) - (defun (setf ,(intern (format nil "WINDOW-~a" attr))) (,val ,win) - (setf (gethash ,attr (window-plist ,win))) ,val)))) - -(defun sort-windows (group) - "Return a copy of the screen's window list sorted by number." - (sort1 (group-windows group) '< :key 'window-number)) - -(defun marked-windows (group) - "Return the marked windows in the specified group." - (loop for i in (sort-windows group) - when (window-marked i) - collect i)) - -(defun clear-window-marks (group &optional (windows (group-windows group))) - (dolist (w windows) - (setf (window-marked w) nil))) - -(defun (setf xwin-state) (state xwin) - "Set the state (iconic, normal, withdrawn) of a window." - (xlib:change-property xwin - :WM_STATE - (list state) - :WM_STATE - 32)) - -(defun xwin-state (xwin) - "Get the state (iconic, normal, withdraw of a window." - (first (xlib:get-property xwin :WM_STATE))) - -(defun window-hidden-p (window) - (eql (window-state window) +iconic-state+)) - -(defun add-wm-state (xwin state) - (xlib:change-property xwin :_NET_WM_STATE - (list (xlib:find-atom *display* state)) - :atom 32 - :mode :append)) - -(defun remove-wm-state (xwin state) - (xlib:change-property xwin :_NET_WM_STATE - (delete (xlib:find-atom *display* state) (xlib:get-property xwin :_NET_WM_STATE)) - :atom 32)) - -(defun window-property (window prop) - (xlib:get-property (window-xwin window) prop)) - -(defun find-wm-state (xwin state) - (find (xlib:find-atom *display* state) (xlib:get-property xwin :_NET_WM_STATE) :test #'=)) - -(defun xwin-unhide (xwin parent) - (xlib:map-subwindows parent) - (xlib:map-window parent) - (setf (xwin-state xwin) +normal-state+)) - -(defun unhide-window (window) - (when (window-in-current-group-p window) - (xwin-unhide (window-xwin window) (window-parent window))) - (setf (window-state window) +normal-state+) - ;; Mark window as unhiden - (remove-wm-state (window-xwin window) :_NET_WM_STATE_HIDDEN)) - -;; Despite the naming convention, this function takes a window struct, -;; not an xlib:window. -(defun xwin-hide (window) - (declare (type window window)) - (unless (eq (xlib:window-map-state (window-xwin window)) :unmapped) - (setf (xwin-state (window-xwin window)) +iconic-state+) - (incf (window-unmap-ignores window)) - (xlib:unmap-window (window-parent window)) - (xlib:unmap-subwindows (window-parent window)))) - -(defun hide-window (window) - (dformat 2 "hide window: ~s~%" window) - (unless (eql (window-state window) +iconic-state+) - (setf (window-state window) +iconic-state+) - ;; Mark window as hidden - (add-wm-state (window-xwin window) :_NET_WM_STATE_HIDDEN) - (when (window-in-current-group-p window) - (xwin-hide window) - (when (eq window (current-window)) - ;; If this window had the focus, try to avoid losing it. - (let ((group (window-group window)) - (frame (window-frame window))) - (setf (frame-window frame) - (first (remove-if 'window-hidden-p (frame-windows group frame)))) - (focus-frame group (tile-group-current-frame group))))))) - -(defun xwin-type (win) - "Return one of :desktop, :dock, :toolbar, :utility, :splash, -:dialog, :transient, :maxsize and :normal. Right now -only :dialog, :normal, :maxsize and :transient are -actually returned; see +NETWM-WINDOW-TYPES+." - (or (and (let ((hints (xlib:wm-normal-hints win))) - (and hints (or (xlib:wm-size-hints-max-width hints) - (xlib:wm-size-hints-max-height hints) - (xlib:wm-size-hints-min-aspect hints) - (xlib:wm-size-hints-max-aspect hints)))) - :maxsize) - (let ((net-wm-window-type (xlib:get-property win :_NET_WM_WINDOW_TYPE))) - (when net-wm-window-type - (dolist (type-atom net-wm-window-type) - (when (assoc (xlib:atom-name *display* type-atom) +netwm-window-types+) - (return (cdr (assoc (xlib:atom-name *display* type-atom) +netwm-window-types+))))))) - (and (xlib:get-property win :WM_TRANSIENT_FOR) - :transient) - :normal)) - -(defun xwin-strut (screen win) - "Return the area that the window wants to reserve along the edges of the screen. -Values are left, right, top, bottom, left_start_y, left_end_y, -right_start_y, right_end_y, top_start_x, top_end_x, bottom_start_x -and bottom_end_x." - (let ((net-wm-strut-partial (xlib:get-property win :_NET_WM_STRUT_PARTIAL))) - (if (= (length net-wm-strut-partial) 12) - (apply 'values net-wm-strut-partial) - (let ((net-wm-strut (xlib:get-property win :_NET_WM_STRUT))) - (if (= (length net-wm-strut) 4) - (apply 'values (concatenate 'list net-wm-strut - (list 0 (screen-height screen) - 0 (screen-height screen) - 0 (screen-width screen) - 0 (screen-width screen)))) - (values 0 0 0 0 0 0 0 0 0 0 0 0)))))) - -;; Stolen from Eclipse -(defun xwin-send-configuration-notify (xwin x y w h bw) - "Send a synthetic configure notify event to the given window (ICCCM 4.1.5)" - (xlib:send-event xwin :configure-notify nil - :event-window xwin - :window xwin - :x x :y y - :width w - :height h - :border-width bw - :propagate-p nil)) - -(defun update-window-gravity () - (dolist (s *screen-list*) - (dolist (g (screen-groups s)) - (mapc 'maximize-window (group-windows g))))) - -(defun set-normal-gravity (gravity) - "Set the default gravity for normal windows. Possible values are -@code{:center} @code{:top} @code{:left} @code{:right} @code{:bottom} -@code{:top-left} @code{:top-right} @code{:bottom-left} and -@code{:bottom-right}." - (setf *normal-gravity* gravity) - (update-window-gravity)) - -(defun set-maxsize-gravity (gravity) - "Set the default gravity for maxsize windows." - (setf *maxsize-gravity* gravity) - (update-window-gravity)) - -(defun set-transient-gravity (gravity) - "Set the default gravity for transient/pop-up windows." - (setf *transient-gravity* gravity) - (update-window-gravity)) - -(defun gravity-for-window (win) - (or (window-gravity win) - (ecase (window-type win) - (:dock *normal-gravity*) - (:normal *normal-gravity*) - (:maxsize *maxsize-gravity*) - ((:transient :dialog) *transient-gravity*)))) - -(defun geometry-hints (win) - "Return hints for max width and height and increment hints. These -hints have been modified to always be defined and never be greater -than the root window's width and height." - (let* ((f (window-frame win)) - (x (frame-x f)) - (y (frame-display-y (window-group win) f)) - (border (xlib:drawable-border-width (window-parent win))) - (fwidth (- (frame-width f) (* 2 border))) - (fheight (- (frame-display-height (window-group win) f) - (* 2 border))) - (width fwidth) - (height fheight) - (hints (window-normal-hints win)) - (hints-min-width (and hints (xlib:wm-size-hints-min-width hints))) - (hints-min-height (and hints (xlib:wm-size-hints-min-height hints))) - (hints-max-width (and hints (xlib:wm-size-hints-max-width hints))) - (hints-max-height (and hints (xlib:wm-size-hints-max-height hints))) - (hints-width (and hints (xlib:wm-size-hints-base-width hints))) - (hints-height (and hints (xlib:wm-size-hints-base-height hints))) - (hints-inc-x (and hints (xlib:wm-size-hints-width-inc hints))) - (hints-inc-y (and hints (xlib:wm-size-hints-height-inc hints))) - (hints-min-aspect (and hints (xlib:wm-size-hints-min-aspect hints))) - (hints-max-aspect (and hints (xlib:wm-size-hints-max-aspect hints))) - center) - ;; (dformat 4 "hints: ~s~%" hints) - ;; determine what the width and height should be - (cond - ;; handle specially fullscreen windows. - ((window-fullscreen win) - (let ((head (frame-head (window-group win) f))) - (setf x (frame-x head) - y (frame-y head) - width (frame-width head) - height (frame-height head) - (xlib:window-priority (window-parent win)) :above - (xlib:drawable-border-width (window-parent win)) 0)) - (return-from geometry-hints (values x y 0 0 width height t))) - ;; Adjust the defaults if the window is a transient_for window. - ((find (window-type win) '(:transient :dialog)) - (setf center t - width (min (max (or hints-width 0) - (or hints-min-width 0) - (window-width win)) - width) - height (min (max (or hints-height 0) - (or hints-min-height 0) - (window-height win)) - height))) - ;; aspect hints are handled similar to max size hints - ((and hints-min-aspect hints-max-aspect) - (let ((ratio (/ width height))) - (cond ((< ratio hints-min-aspect) - (setf height (ceiling width hints-min-aspect))) - ((> ratio hints-max-aspect) - (setf width (ceiling (* height hints-max-aspect))))) - (setf center t))) - ;; Update our defaults if the window has the maxsize hints - ((or hints-max-width hints-max-height) - (when (and hints-max-width - (< hints-max-width width)) - (setf width hints-max-width)) - (when (and hints-max-height - (< hints-max-height height)) - (setf height hints-max-height)) - (setf center t)) - (t - ;; if they have inc hints then start with the size and adjust - ;; based on those increments until the window fits in the frame - (when hints-inc-x - (let ((w (or hints-width (window-width win)))) - (setf width (+ w (* hints-inc-x - (+ (floor (- fwidth w) hints-inc-x))))))) - (when hints-inc-y - (let ((h (or hints-height (window-height win)))) - (setf height (+ h (* hints-inc-y - (+ (floor (- fheight h -1) hints-inc-y))))))))) - ;; adjust for gravity - (multiple-value-bind (wx wy) (get-gravity-coords (gravity-for-window win) - width height - 0 0 - fwidth fheight) - (when (or center - (find *window-border-style* '(:tight :none))) - (setf x (+ wx (frame-x f)) - y (+ wy (frame-display-y (window-group win) f)) - wx 0 wy 0)) - ;; Now return our findings - (values x y wx wy width height center)))) - -(defun set-window-geometry (win &key x y width height border-width) - (macrolet ((update (xfn wfn v) - `(when ,v ;; (/= (,wfn win) ,v)) - (setf (,xfn (window-xwin win)) ,v) - ,(when wfn `(setf (,wfn win) ,v))))) - (xlib:with-state ((window-xwin win)) - (update xlib:drawable-x nil x) - (update xlib:drawable-y nil y) - (update xlib:drawable-width window-width width) - (update xlib:drawable-height window-height height) - (update xlib:drawable-border-width nil border-width) - ))) - -(defun maximize-window (win) - "Maximize the window." - (multiple-value-bind (x y wx wy width height stick) - (geometry-hints win) - (dformat 4 "maximize window ~a x: ~d y: ~d width: ~d height: ~d stick: ~s~%" win x y width height stick) - ;; Move the parent window - (xlib:with-state ((window-parent win)) - (setf (xlib:drawable-x (window-parent win)) x - (xlib:drawable-y (window-parent win)) y)) - ;; This is the only place a window's geometry should change - (set-window-geometry win :x wx :y wy :width width :height height :border-width 0) - (xlib:with-state ((window-parent win)) - ;; FIXME: updating the border doesn't need to be run everytime - ;; the window is maximized, but only when the border style or - ;; window type changes. The overhead is probably minimal, - ;; though. - (setf (xlib:drawable-border-width (window-parent win)) - (case *window-border-style* - (:none 0) - (t (default-border-width-for-type (window-type win))))) - ;; the parent window should stick to the size of the window - ;; unless it isn't being maximized to fill the frame. - (if (or stick - (find *window-border-style* '(:tight :none))) - (setf (xlib:drawable-width (window-parent win)) (window-width win) - (xlib:drawable-height (window-parent win)) (window-height win)) - (let ((frame (window-frame win))) - (setf (xlib:drawable-width (window-parent win)) (- (frame-width frame) - (* 2 (xlib:drawable-border-width (window-parent win)))) - (xlib:drawable-height (window-parent win)) (- (frame-display-height (window-group win) frame) - (* 2 (xlib:drawable-border-width (window-parent win)))))))))) - -(defun find-free-window-number (group) - "Return a free window number for GROUP." - (find-free-number (mapcar 'window-number (group-windows group)))) - -(defun reparent-window (window) - ;; apparently we need to grab the server so the client doesn't get - ;; the mapnotify event before the reparent event. that's what fvwm - ;; says. - (xlib:with-server-grabbed (*display*) - (let* ((screen (window-screen window)) - (master-window (xlib:create-window - :parent (screen-root screen) - :x (xlib:drawable-x (window-xwin window)) :y (xlib:drawable-y (window-xwin window)) - :width (window-width window) - :height (window-height window) - ;; normal windows get a black background - :background (if (eq (window-type window) :normal) - (screen-bg-color screen) - :none) - :border (screen-unfocus-color screen) - :border-width (default-border-width-for-type (window-type window)) - :event-mask *window-parent-events*))) - (unless (eq (xlib:window-map-state (window-xwin window)) :unmapped) - (incf (window-unmap-ignores window))) - (xlib:reparent-window (window-xwin window) master-window 0 0) - (xwin-grab-buttons master-window) - ;; ;; we need to update these values since they get set to 0,0 on reparent - ;; (setf (window-x window) 0 - ;; (window-y window) 0) - (xlib:add-to-save-set (window-xwin window)) - (setf (window-parent window) master-window)))) - -(defun process-existing-windows (screen) - "Windows present when stumpwm starts up must be absorbed by stumpwm." - (let ((children (xlib:query-tree (screen-root screen))) - (*processing-existing-windows* t) - (stacking (xlib:get-property (screen-root screen) :_NET_CLIENT_LIST_STACKING :type :window))) - (when stacking - (dformat 3 "Using window stacking: ~{~X ~}~%" stacking) - ;; sort by _NET_CLIENT_LIST_STACKING - (setf children (stable-sort children #'< :key - (lambda (xwin) - (or (position (xlib:drawable-id xwin) stacking :test #'=) 0))))) - (dolist (win children) - (let ((map-state (xlib:window-map-state win)) - (wm-state (xwin-state win))) - ;; Don't process override-redirect windows. - (unless (or (eq (xlib:window-override-redirect win) :on) - (internal-window-p screen win)) - (if (eq (xwin-type win) :dock) - (progn - (dformat 1 "Window ~S is dock-type. Placing in mode-line.~%" win) - (place-mode-line-window screen win)) - (if (or (eql map-state :viewable) - (eql wm-state +iconic-state+)) - (progn - (dformat 1 "Processing ~S ~S~%" (xwin-name win) win) - (process-mapped-window screen win)))))))) - (dolist (w (screen-windows screen)) - (setf (window-state w) +normal-state+) - (xwin-hide w))) - -(defun xwin-grab-keys (win) - (labels ((grabit (w key) - (let ((code (xlib:keysym->keycodes *display* (key-keysym key)))) - ;; some keysyms aren't mapped to keycodes so just ignore them. - (when code - (xlib:grab-key w code - :modifiers (x11-mods key) :owner-p t - :sync-pointer-p nil :sync-keyboard-p nil) - ;; Ignore numlock by also grabbing the keycombo with - ;; numlock on. - (when (modifiers-numlock *modifiers*) - (xlib:grab-key w code - :modifiers (x11-mods key t) :owner-p t - :sync-pointer-p nil :sync-keyboard-p nil)))))) - (maphash (lambda (k v) - (declare (ignore v)) - (grabit win k)) - *top-map*))) - -(defun grab-keys-on-window (win) - (xwin-grab-keys (window-xwin win))) - -(defun xwin-ungrab-keys (win) - (xlib:ungrab-key win :any :modifiers :any)) - -(defun ungrab-keys-on-window (win) - (xwin-ungrab-keys (window-xwin win))) - -(defun xwin-grab-buttons (win) - ;; FIXME: Why doesn't grabbing button :any work? We have to - ;; grab them one by one instead. - (xwin-ungrab-buttons win) - (loop for i from 1 to 7 - do (xlib:grab-button win i '(:button-press) - :modifiers :any - :owner-p nil - :sync-pointer-p t - :sync-keyboard-p nil))) - - -(defun xwin-ungrab-buttons (win) - (xlib:ungrab-button win :any :modifiers :any)) - -(defun sync-keys () - "Any time *top-map* is modified this must be called." - (loop for i in *screen-list* - do (xwin-ungrab-keys (screen-focus-window i)) - do (loop for j in (screen-mapped-windows i) - do (xwin-ungrab-keys j)) - do (xlib:display-finish-output *display*) - do (loop for j in (screen-mapped-windows i) - do (xwin-grab-keys j)) - do (xwin-grab-keys (screen-focus-window i))) - (xlib:display-finish-output *display*)) - - -;;; Window placement routines - -(defun xwin-to-window (xwin) - "Build a window for XWIN" - (make-window - :xwin xwin - :width (xlib:drawable-width xwin) :height (xlib:drawable-height xwin) - :x (xlib:drawable-x xwin) :y (xlib:drawable-y xwin) - :title (xwin-name xwin) - :class (xwin-class xwin) - :res (xwin-res-name xwin) - :role (xwin-role xwin) - :type (xwin-type xwin) - :normal-hints (xlib:wm-normal-hints xwin) - :state +iconic-state+ - :plist (make-hash-table) - :unmap-ignores 0)) - -(defun string-match (string pat) - (let ((l (length pat))) - (when (> l 0) - (if (and (> l 3) (equal (subseq pat 0 3) "...")) - (search (subseq pat 3 l) string) - (equal string pat))))) - -(defun window-matches-properties-p (window &key class instance type role title) - "Returns T if window matches all the given properties" - (and - (if class (equal (window-class window) class) t) - (if instance (equal (window-res window) instance) t) - (if type (equal (window-type window) type) t) - (if role (string-match (window-role window) role) t) - (if title (string-match (window-title window) title) t) t)) - -(defun window-matches-rule-p (w rule) - "Returns T if window matches rule" - (destructuring-bind (group-name frame raise lock &rest props) rule - (declare (ignore frame raise)) - (if (or lock - (equal group-name (group-name (or (window-group w) (current-group))))) - (apply 'window-matches-properties-p w props)))) - -;; TODO: add rules allowing matched windows to create their own groups/frames - -(defun rule-matching-window (window) - (dolist (rule *window-placement-rules*) - (when (window-matches-rule-p window rule) (return rule)))) - -(defun get-window-placement (screen window) - "Returns the ideal group and frame that WINDOW should belong to and whether - the window should be raised." - (let ((match (rule-matching-window window))) - (if match - (destructuring-bind (group-name frame raise lock &rest props) match - (declare (ignore lock props)) - (let ((group (find-group screen group-name))) - (if group - (values group (frame-by-number group frame) raise) - (progn - (message "^B^1*Error placing window, group \"^b~a^B\" does not exist." group-name) - (values))))) - (values)))) - -(defun sync-window-placement () - "Re-arrange existing windows according to placement rules" - (dolist (screen *screen-list*) - (dolist (window (screen-windows screen)) - (multiple-value-bind (to-group frame raise) (get-window-placement screen window) - (declare (ignore raise)) - (when to-group - (unless (eq (window-group window) to-group) - (move-window-to-group window to-group)) - (unless (eq (window-frame window) frame) - (pull-window window frame))))))) - -(defun assign-window (window group frame &optional (where :tail)) - (setf (window-group window) group - (window-number window) (find-free-window-number group) - (window-frame window) (or frame (pick-prefered-frame window))) - (if (eq where :head) - (push window (group-windows group)) - (setf (group-windows group) (append (group-windows group) (list window))))) - -(defun place-existing-window (screen xwin) - "Called for windows existing at startup." - (let* ((window (xwin-to-window xwin)) - (netwm-id (first (xlib:get-property xwin :_NET_WM_DESKTOP))) - (group (if (and netwm-id (< netwm-id (length (screen-groups screen)))) - (elt (sort-groups screen) netwm-id) - (screen-current-group screen)))) - (dformat 3 "Assigning pre-existing window ~S to group ~S~%" (window-name window) (group-name group)) - (assign-window window group (find-frame group (xlib:drawable-x xwin) (xlib:drawable-y xwin)) :head) - (setf (frame-window (window-frame window)) window) - window)) - -(defun place-window (screen xwin) - "Pick a group and frame for XWIN." - (let* ((window (xwin-to-window xwin)) - (group (screen-current-group screen)) - (frame nil) - (raise nil)) - (multiple-value-bind (to-group to-frame to-raise) (get-window-placement screen window) - (setf group (or to-group group) - frame to-frame - raise to-raise)) - (assign-window window group frame) - (setf (xwin-state xwin) +iconic-state+) - (xlib:change-property xwin :_NET_WM_DESKTOP - (list (netwm-group-id group)) - :cardinal 32) - (when frame - (unless (eq (current-group) group) - (if raise - (switch-to-group group) - (message "Placing window ~a in frame ~d of group ~a" - (window-name window) (frame-number frame) (group-name group)))) - (when raise - (switch-to-screen (group-screen group)) - (focus-frame group frame)) - (run-hook-with-args *place-window-hook* window group frame)) - window)) - -(defun pick-prefered-frame (window) - (let* ((group (window-group window)) - (frames (group-frames group)) - (default (tile-group-current-frame group))) - (or - (if (or (functionp *new-window-prefered-frame*) - (and (symbolp *new-window-prefered-frame*) - (fboundp *new-window-prefered-frame*))) - (handler-case - (funcall *new-window-prefered-frame* window) - (error (c) - (message "^1*^BError while calling ^b^3**new-window-prefered-frame*^1*^B: ^n~a" c) - nil)) - (loop for i in *new-window-prefered-frame* - thereis (case i - (:last - ;; last-frame can be stale - (and (> (length frames) 1) - (tile-group-last-frame group))) - (:unfocused - (find-if (lambda (f) - (not (eq f (tile-group-current-frame group)))) - frames)) - (:empty - (find-if (lambda (f) - (null (frame-window f))) - frames)) - (:choice - ;; Transient windows sometimes specify a location - ;; relative to the TRANSIENT_FOR window. Just ignore - ;; these hints. - (unless (find (window-type window) '(:transient :dialog)) - (let ((hints (window-normal-hints window))) - (when (and hints (xlib:wm-size-hints-user-specified-position-p hints)) - (find-frame group (window-x window) (window-y window)))))) - (t ; :focused - (tile-group-current-frame group))))) - default))) - -(defun add-window (screen xwin) - (screen-add-mapped-window screen xwin) - (register-window (if *processing-existing-windows* - (place-existing-window screen xwin) - (place-window screen xwin)))) - -(defun netwm-remove-window (window) - (xlib:delete-property (window-xwin window) :_NET_WM_DESKTOP)) - -(defun process-mapped-window (screen xwin) - "Add the window to the screen's mapped window list and process it as -needed." - (let ((window (add-window screen xwin))) - (setf (xlib:window-event-mask (window-xwin window)) *window-events*) - ;; windows always have border width 0. Their parents provide the - ;; border. - (set-window-geometry window :border-width 0) - (reparent-window window) - (maximize-window window) - (grab-keys-on-window window) - ;; quite often the modeline displays the window list, so update it - (update-all-mode-lines) - ;; Set allowed actions - (xlib:change-property xwin :_NET_WM_ALLOWED_ACTIONS - (mapcar (lambda (a) - (xlib:intern-atom *display* a)) - +netwm-allowed-actions+) - :atom 32) - ;; Run the new window hook on it. - (run-hook-with-args *new-window-hook* window) - window)) - -(defun find-withdrawn-window (xwin) - "Return the window and screen for a withdrawn window." - (declare (type xlib:window xwin)) - (dolist (i *screen-list*) - (let ((w (find xwin (screen-withdrawn-windows i) :key 'window-xwin :test 'xlib:window-equal))) - (when w - (return-from find-withdrawn-window (values w i)))))) - -(defun restore-window (window) - "Restore a withdrawn window" - (declare (type window window)) - ;; put it in a valid group - (let ((screen (window-screen window))) - ;; Use window plaecment rules - (multiple-value-bind (group frame raise) (get-window-placement screen window) - (declare (ignore raise)) - (unless (find (window-group window) - (screen-groups screen)) - (setf (window-group window) (or group (screen-current-group screen)))) - ;; FIXME: somehow it feels like this could be merged with group-add-window - (setf (window-title window) (xwin-name (window-xwin window)) - (window-class window) (xwin-class (window-xwin window)) - (window-res window) (xwin-res-name (window-xwin window)) - (window-role window) (xwin-role (window-xwin window)) - (window-type window) (xwin-type (window-xwin window)) - (window-normal-hints window) (xlib:wm-normal-hints (window-xwin window)) - (window-number window) (find-free-window-number (window-group window)) - (window-state window) +iconic-state+ - (xwin-state (window-xwin window)) +iconic-state+ - (screen-withdrawn-windows screen) (delete window (screen-withdrawn-windows screen)) - ;; put the window at the end of the list - (group-windows (window-group window)) (append (group-windows (window-group window)) (list window)) - (window-frame window) (or frame (pick-prefered-frame window)))) - (screen-add-mapped-window screen (window-xwin window)) - (register-window window) - (xlib:change-property (window-xwin window) :_NET_WM_DESKTOP - (list (netwm-group-id (window-group window))) - :cardinal 32) - (maximize-window window) - ;; It is effectively a new window in terms of the window list. - (run-hook-with-args *new-window-hook* window) - ;; give it focus - (if (deny-request-p window *deny-map-request*) - (unless *suppress-deny-messages* - (if (eq (window-group window) (current-group)) - (echo-string (window-screen window) (format nil "'~a' denied map request" (window-name window))) - (echo-string (window-screen window) (format nil "'~a' denied map request in group ~a" (window-name window) (group-name (window-group window)))))) - (frame-raise-window (window-group window) (window-frame window) window - (if (eq (window-frame window) - (tile-group-current-frame (window-group window))) - t nil))))) - -(defun withdraw-window (window) - "Withdrawing a window means just putting it in a list til we get a destroy event." - (declare (type window window)) - ;; This function cannot request info about WINDOW from the xserver as it may not exist anymore. - (let ((f (window-frame window)) - (group (window-group window)) - (screen (window-screen window))) - (dformat 1 "withdraw window ~a~%" screen) - ;; Save it for later since it is only withdrawn, not destroyed. - (push window (screen-withdrawn-windows screen)) - (setf (window-state window) +withdrawn-state+ - (xwin-state (window-xwin window)) +withdrawn-state+) - (xlib:unmap-window (window-parent window)) - ;; Clean up the window's entry in the screen and group - (screen-remove-mapped-window screen (window-xwin window)) - (setf (group-windows group) - (delete window (group-windows group))) - ;; remove it from it's frame structures - (when (eq (frame-window f) window) - (frame-raise-window group f (first (frame-windows group f)) nil)) - (when (window-in-current-group-p window) - ;; since the window doesn't exist, it doesn't have focus. - (setf (screen-focus screen) nil)) - (netwm-remove-window window) - ;; If the current window was removed, then refocus the frame it - ;; was in, since it has a new current window - (when (eq (tile-group-current-frame group) f) - (focus-frame (window-group window) f)) - ;; quite often the modeline displays the window list, so update it - (update-all-mode-lines) - ;; Run the destroy hook on the window - (run-hook-with-args *destroy-window-hook* window))) - -(defun destroy-window (window) - (declare (type window window)) - "The window has been destroyed. clean up our data structures." - ;; This function cannot request info about WINDOW from the xserver - (let ((screen (window-screen window))) - (unless (eql (window-state window) +withdrawn-state+) - (withdraw-window window)) - ;; now that the window is withdrawn, clean up the data structures - (setf (screen-withdrawn-windows screen) - (delete window (screen-withdrawn-windows screen))) - (dformat 1 "destroy window ~a~%" screen) - (dformat 3 "destroying parent window~%") - (xlib:destroy-window (window-parent window)))) - -(defun move-window-to-head (group window) - "Move window to the head of the group's window list." - (declare (type group group)) - (declare (type window window)) - ;(assert (member window (screen-mapped-windows screen))) - (setf (group-windows group) (delete window (group-windows group))) - (push window (group-windows group)) - (netwm-update-client-list-stacking (group-screen group))) - -(defun no-focus (group last-win) - "don't focus any window but still read keyboard events." - (dformat 3 "no-focus~%") - (let* ((screen (group-screen group))) - (when (eq group (screen-current-group screen)) - (xlib:set-input-focus *display* (screen-focus-window screen) :POINTER-ROOT) - (setf (screen-focus screen) nil) - (move-screen-to-head screen)) - (when last-win - (update-window-border last-win)))) - -(defun focus-window (window) - "Give the window focus. This means the window will be visible, -maximized, and given focus." - (dformat 3 "focus-window: ~s~%" window) - (let* ((group (window-group window)) - (screen (group-screen group)) - (cw (screen-focus screen))) - ;; If window to focus is already focused then our work is done. - (unless (eq window cw) - (update-all-mode-lines) - (raise-window window) - (screen-set-focus screen window) - ;;(send-client-message window :WM_PROTOCOLS +wm-take-focus+) - (update-window-border window) - (when cw - (update-window-border cw)) - ;; Move the window to the head of the mapped-windows list - (move-window-to-head group window) - (run-hook-with-args *focus-window-hook* window cw)))) - -(defun delete-window (window) - "Send a delete event to the window." - (dformat 3 "Delete window~%") - (send-client-message window :WM_PROTOCOLS (xlib:intern-atom *display* :WM_DELETE_WINDOW))) - -(defun xwin-kill (window) - "Kill the client associated with window." - (dformat 3 "Kill client~%") - (xlib:kill-client *display* (xlib:window-id window))) - - -;;; Message printing functions - -(defun color-exists-p (color) - (handler-case - (loop for i in *screen-list* - always (xlib:lookup-color (xlib:screen-default-colormap (screen-number i)) color)) - (xlib:name-error () nil))) - -(defun font-exists-p (font-name) - ;; if we can list the font then it exists - (plusp (length (xlib:list-font-names *display* font-name :max-fonts 1)))) - -(defmacro set-any-color (val color) - `(progn (dolist (s *screen-list*) - (setf (,val s) (alloc-color s ,color))) - (update-colors-all-screens))) - -;; FIXME: I don't like any of this. Isn't there a way to define -;; a setf method to call (update-colors-all-screens) when the user -;; does eg. (setf *foreground-color* "green") instead of having -;; these redundant set-foo functions? -(defun set-fg-color (color) - "Set the foreground color for the message bar and input -bar. @var{color} can be any color recognized by X." - (setf *text-color* color) - (set-any-color screen-fg-color color)) - -(defun set-bg-color (color) - "Set the background color for the message bar and input -bar. @var{color} can be any color recognized by X." - (set-any-color screen-bg-color color)) - -(defun set-border-color (color) - "Set the border color for the message bar and input -bar. @var{color} can be any color recognized by X." - (set-any-color screen-border-color color)) - -(defun set-win-bg-color (color) - "Set the background color of the window. The background color will only -be visible for windows with size increment hints such as @samp{emacs} -and @samp{xterm}." - (set-any-color screen-win-bg-color color)) - -(defun set-focus-color (color) - (set-any-color screen-focus-color color)) - -(defun set-unfocus-color (color) - (set-any-color screen-unfocus-color color)) - -(defun set-msg-border-width (width) - "Set the border width for the message bar and input -bar." - (check-type width (integer 0)) - (dolist (i *screen-list*) - (setf (screen-msg-border-width i) width)) - (update-border-all-screens) - t) - -(defun set-frame-outline-width (width) - (check-type width (integer 0)) - (dolist (i *screen-list*) - (setf (screen-frame-outline-width i) (if (oddp width) (1+ width) width) - (xlib:gcontext-line-width (screen-frame-outline-gc i)) (screen-frame-outline-width i))) - (update-border-all-screens) - t) - -(defun set-font (font) - "Set the font for the message bar and input bar." - (when (font-exists-p font) - (dolist (i *screen-list*) - (let ((fobj (xlib:open-font *display* (first (xlib:list-font-names *display* font :max-fonts 1))))) - (xlib:close-font (screen-font i)) - (setf (screen-font i) fobj - (xlib:gcontext-font (screen-message-gc i)) fobj) - ;; update the modelines too - (dolist (h (screen-heads i)) - (when (and (head-mode-line h) - (eq (mode-line-mode (head-mode-line h)) :stump)) - (setf (xlib:gcontext-font (mode-line-gc (head-mode-line h))) fobj) - (resize-mode-line (head-mode-line h)) - (sync-mode-line (head-mode-line h)))))) - t)) - -(defun max-width (font l) - "Return the width of the longest string in L using FONT." - (loop for i in l - maximize (xlib:text-width font i :translate #'translate-id))) - -(defun get-gravity-coords (gravity width height minx miny maxx maxy) - "Return the x y coords for a window on with gravity etc" - (values (case gravity - ((:top-right :bottom-right :right) (- maxx width)) - ((:top :bottom :center) (truncate (- maxx minx width) 2)) - (t minx)) - (case gravity - ((:bottom-left :bottom-right :bottom) (- maxy height)) - ((:left :right :center) (truncate (- maxy miny height) 2)) - (t miny)))) - -(defun setup-win-gravity (screen win gravity) - "Position the x, y of the window according to its gravity. This -function expects to be wrapped in a with-state for win." - (xlib:with-state ((screen-root screen)) - (let ((w (xlib:drawable-width win)) - (h (xlib:drawable-height win)) - (screen-width (head-width (current-head))) - (screen-height (head-height (current-head)))) - (let ((x (case gravity - ((:top-left :bottom-left) 0) - (:center (truncate (- screen-width w (* (xlib:drawable-border-width win) 2)) 2)) - (t (- screen-width w (* (xlib:drawable-border-width win) 2))))) - (y (case gravity - ((:bottom-right :bottom-left) (- screen-height h (* (xlib:drawable-border-width win) 2))) - (:center (truncate (- screen-height h (* (xlib:drawable-border-width win) 2)) 2)) - (t 0)))) - (setf (xlib:drawable-y win) (max (head-y (current-head)) (+ (head-y (current-head)) y)) - (xlib:drawable-x win) (max (head-x (current-head)) (+ (head-x (current-head)) x))))))) - -(defun setup-message-window (screen lines width) - (let ((height (* lines - (+ (xlib:font-ascent (screen-font screen)) - (xlib:font-descent (screen-font screen))))) - (win (screen-message-window screen))) - ;; Now that we know the dimensions, raise and resize it. - (xlib:with-state (win) - (setf (xlib:drawable-height win) height - (xlib:drawable-width win) (+ width (* *message-window-padding* 2)) - (xlib:window-priority win) :above) - (setup-win-gravity screen win *message-window-gravity*)) - (xlib:map-window win) - ;; Clear the window - (xlib:clear-area win) - (incf (screen-ignore-msg-expose screen)) - ;; Have to flush this or the window might get cleared - ;; after we've already started drawing it. - (xlib:display-finish-output *display*))) - -(defun invert-rect (screen win x y width height) - "invert the color in the rectangular area. Used for highlighting text." - (let ((gcontext (xlib:create-gcontext :drawable win - :foreground (screen-fg-color screen) - :function boole-xor))) - (xlib:draw-rectangle win gcontext x y width height t) - (setf (xlib:gcontext-foreground gcontext) (screen-bg-color screen)) - (xlib:draw-rectangle win gcontext x y width height t))) - - -;;; Frame functions - -(defun populate-frames (group) - "Try to fill empty frames in GROUP with hidden windows" - (dolist (f (group-frames group)) - (unless (frame-window f) - (choose-new-frame-window f group) - (when (frame-window f) - (maximize-window (frame-window f)) - (unhide-window (frame-window f)))))) - -(defun frame-by-number (group n) - (unless (eq n nil) - (find n (group-frames group) - :key 'frame-number - :test '=))) - -(defun find-frame (group x y) - "Return the frame of GROUP containing the pixel at X Y" - (dolist (f (group-frames group)) - (let* ((fy (frame-y f)) - (fx (frame-x f)) - (fwx (+ fx (frame-width f))) - (fhy (+ fy (frame-height f)))) - (when (and - (>= y fy) (<= y fhy) - (>= x fx) (<= x fwx) - (return f)))))) - - -(defun frame-set-x (frame v) - (decf (frame-width frame) - (- v (frame-x frame))) - (setf (frame-x frame) v)) - -(defun frame-set-y (frame v) - (decf (frame-height frame) - (- v (frame-y frame))) - (setf (frame-y frame) v)) - -(defun frame-set-r (frame v) - (setf (frame-width frame) - (- v (frame-x frame)))) - -(defun frame-set-b (frame v) - (setf (frame-height frame) - (- v (frame-y frame)))) - -(defun frame-r (frame) - (+ (frame-x frame) (frame-width frame))) - -(defun frame-b (frame) - (+ (frame-y frame) (frame-height frame))) - -(defun frame-intersect (f1 f2) - "Return a new frame representing (only) the intersection of F1 and F2. WIDTH and HEIGHT will be <= 0 if there is no overlap" - (let ((r (copy-frame f1))) - (when (> (frame-x f2) (frame-x f1)) - (frame-set-x r (frame-x f2))) - (when (< (+ (frame-x f2) (frame-width f2)) - (+ (frame-x f1) (frame-width f1))) - (frame-set-r r (frame-r f2))) - (when (> (frame-y f2) (frame-y f1)) - (frame-set-y r (frame-y f2))) - (when (< (+ (frame-y f2) (frame-height f2)) - (+ (frame-y f1) (frame-height f1))) - (frame-set-b r (frame-b f2))) - (values r))) - -(defun frames-overlap-p (f1 f2) - "Returns T if frames F1 and F2 overlap at all" - (and (and (frame-p f1) (frame-p f2)) - (let ((frame (frame-intersect f1 f2))) - (values (not (and (plusp (frame-width frame)) - (plusp (frame-height frame)))))))) - -(defun frame-raise-window (g f w &optional (focus t)) - "Raise the window w in frame f in group g. if FOCUS is -T (default) then also focus the frame." - (let ((oldw (frame-window f))) - ;; nothing to do when W is nil - (setf (frame-window f) w) - (unless (and w (eq oldw w)) - (if w - (raise-window w) - (mapc 'hide-window (frame-windows g f)))) - (when focus - (focus-frame g f)) - (when (and w (not (window-modal-p w))) - (raise-modals-of w)))) - -(defun focus-frame (group f) - (let ((w (frame-window f)) - (last (tile-group-current-frame group)) - (show-indicator nil)) - (setf (tile-group-current-frame group) f) - ;; record the last frame to be used in the fother command. - (unless (eq f last) - (setf (tile-group-last-frame group) last) - (run-hook-with-args *focus-frame-hook* f last) - (setf show-indicator t)) - (if w - (focus-window w) - (no-focus group (frame-window last))) - (if show-indicator - (show-frame-indicator group) - (show-frame-outline group)))) - -(defun frame-windows (group f) - (remove-if-not (lambda (w) (eq (window-frame w) f)) - (group-windows group))) - -(defun frame-sort-windows (group f) - (remove-if-not (lambda (w) (eq (window-frame w) f)) - (sort-windows group))) - -(defun copy-frame-tree (tree) - "Return a copy of the frame tree." - (cond ((null tree) tree) - ((typep tree 'frame) - (copy-structure tree)) - (t - (mapcar #'copy-frame-tree tree)))) - -(defun group-frames (group) - (tree-accum-fn (tile-group-frame-tree group) 'nconc 'list)) - -(defun head-frames (group head) - (tree-accum-fn (tile-group-frame-head group head) 'nconc 'list)) - -(defun find-free-frame-number (group) - (find-free-number (mapcar (lambda (f) (frame-number f)) - (group-frames group)))) - -(defun choose-new-frame-window (frame group) - "Find out what window should go in a newly created frame." - (let ((win (case *new-frame-action* - (:last-window (other-hidden-window group)) - (t nil)))) - (setf (frame-window frame) win) - (when win - (setf (window-frame win) frame)))) - -(defun split-frame-h (group p) - "Return 2 new frames. The first one stealing P's number and window" - (let* ((w (truncate (/ (frame-width p) 2))) - (h (frame-height p)) - (f1 (make-frame :number (frame-number p) - :x (frame-x p) - :y (frame-y p) - :width w - :height h - :window (frame-window p))) - (f2 (make-frame :number (find-free-frame-number group) - :x (+ (frame-x p) w) - :y (frame-y p) - ;; gobble up the modulo - :width (- (frame-width p) w) - :height h - :window nil))) - (run-hook-with-args *new-frame-hook* f2) - (values f1 f2))) - -(defun split-frame-v (group p) - "Return 2 new frames. The first one stealing P's number and window" - (let* ((w (frame-width p)) - (h (truncate (/ (frame-height p) 2))) - (f1 (make-frame :number (frame-number p) - :x (frame-x p) - :y (frame-y p) - :width w - :height h - :window (frame-window p))) - (f2 (make-frame :number (find-free-frame-number group) - :x (frame-x p) - :y (+ (frame-y p) h) - :width w - ;; gobble up the modulo - :height (- (frame-height p) h) - :window nil))) - (run-hook-with-args *new-frame-hook* f2) - (values f1 f2))) - -(defun funcall-on-leaf (tree leaf fn) - "Return a new tree with LEAF replaced with the result of calling FN on LEAF." - (cond ((atom tree) - (if (eq leaf tree) - (funcall fn leaf) - tree)) - (t (mapcar (lambda (sib) - (funcall-on-leaf sib leaf fn)) - tree)))) - -(defun funcall-on-node (tree fn match) - "Call fn on the node where match returns t." - (if (funcall match tree) - (funcall fn tree) - (cond ((atom tree) tree) - (t (mapcar (lambda (sib) - (funcall-on-node sib fn match)) - tree))))) - -(defun replace-frame-in-tree (tree f &rest frames) - (funcall-on-leaf tree f (lambda (f) - (declare (ignore f)) - frames))) - -(defun sibling-internal (tree leaf fn) - "helper for next-sibling and prev-sibling." - (cond ((atom tree) nil) - ((find leaf tree) - (let* ((rest (cdr (member leaf (funcall fn tree)))) - (pick (car (if (null rest) (funcall fn tree) rest)))) - (unless (eq pick leaf) - pick))) - (t (find-if (lambda (x) - (sibling-internal x leaf fn)) - tree)))) - -(defun next-sibling (tree leaf) - "Return the sibling of LEAF in TREE." - (sibling-internal tree leaf 'identity)) - -(defun prev-sibling (tree leaf) - (sibling-internal tree leaf 'reverse)) - -(defun closest-sibling (tree leaf) - "Return the sibling to the right/below of leaf or left/above if -leaf is the most right/below of its siblings." - (let* ((parent (tree-parent tree leaf)) - (lastp (= (position leaf parent) (1- (length parent))))) - (if lastp - (prev-sibling parent leaf) - (next-sibling parent leaf)))) - -(defun migrate-frame-windows (group src dest) - "Migrate all windows in SRC frame to DEST frame." - (mapc (lambda (w) - (when (eq (window-frame w) src) - (setf (window-frame w) dest))) - (group-windows group))) - -(defun tree-accum-fn (tree acc fn) - "Run an accumulator function on fn applied to each leaf" - (cond ((null tree) nil) - ((atom tree) - (funcall fn tree)) - (t (apply acc (mapcar (lambda (x) (tree-accum-fn x acc fn)) tree))))) - -(defun tree-iterate (tree fn) - "Call FN on every leaf in TREE" - (cond ((null tree) nil) - ((atom tree) - (funcall fn tree)) - (t (mapc (lambda (x) (tree-iterate x fn)) tree)))) - -(defun tree-x (tree) - (tree-accum-fn tree 'min 'frame-x)) - -(defun tree-y (tree) - (tree-accum-fn tree 'min 'frame-y)) - -(defun tree-width (tree) - (cond ((atom tree) (frame-width tree)) - ((tree-row-split tree) - ;; in row splits, all children have the same width, so use the - ;; first one. - (tree-width (first tree))) - (t - ;; for column splits we add the width of each child - (reduce '+ tree :key 'tree-width)))) - -(defun tree-height (tree) - (cond ((atom tree) (frame-height tree)) - ((tree-column-split tree) - ;; in row splits, all children have the same width, so use the - ;; first one. - (tree-height (first tree))) - (t - ;; for column splits we add the width of each child - (reduce '+ tree :key 'tree-height)))) - -(defun tree-parent (top node) - "Return the list in TOP that contains NODE." - (cond ((atom top) nil) - ((find node top) top) - (t (loop for i in top - thereis (tree-parent i node))))) - -(defun tree-leaf (top) - "Return a leaf of the tree. Use this when you need a leaf but -you don't care which one." - (tree-accum-fn top - (lambda (&rest siblings) - (car siblings)) - #'identity)) - -(defun tree-row-split (tree) - "Return t if the children of tree are stacked vertically" - (loop for i in (cdr tree) - with head = (car tree) - always (= (tree-x head) (tree-x i)))) - -(defun tree-column-split (tree) - "Return t if the children of tree are side-by-side" - (loop for i in (cdr tree) - with head = (car tree) - always (= (tree-y head) (tree-y i)))) - -(defun tree-split-type (tree) - "return :row or :column" - (cond ((tree-column-split tree) :column) - ((tree-row-split tree) :row) - (t (error "tree-split-type unknown")))) - -(defun offset-tree (tree x y) - "move the screen's frames around." - (tree-iterate tree (lambda (frame) - (incf (frame-x frame) x) - (incf (frame-y frame) y)))) - -(defun offset-tree-dir (tree amount dir) - (ecase dir - (:left (offset-tree tree (- amount) 0)) - (:right (offset-tree tree amount 0)) - (:top (offset-tree tree 0 (- amount))) - (:bottom (offset-tree tree 0 amount)))) - -(defun expand-tree (tree amount dir) - "expand the frames in tree by AMOUNT in DIR direction. DIR can be :top :bottom :left :right" - (labels ((expand-frame (f amount dir) - (ecase dir - (:left (decf (frame-x f) amount) - (incf (frame-width f) amount)) - (:right (incf (frame-width f) amount)) - (:top (decf (frame-y f) amount) - (incf (frame-height f) amount)) - (:bottom (incf (frame-height f) amount))))) - (cond ((null tree) nil) - ((atom tree) - (expand-frame tree amount dir)) - ((or (and (find dir '(:left :right)) - (tree-row-split tree)) - (and (find dir '(:top :bottom)) - (tree-column-split tree))) - (dolist (i tree) - (expand-tree i amount dir))) - (t - (let* ((children (if (find dir '(:left :top)) - (reverse tree) - tree)) - (sz-fn (if (find dir '(:left :right)) - 'tree-width - 'tree-height)) - (total (funcall sz-fn tree)) - (amt-list (loop for i in children - for old-sz = (funcall sz-fn i) - collect (truncate (/ (* amount old-sz) total)))) - (remainder (- amount (apply '+ amt-list))) - (ofs 0)) - ;; spread the remainder out as evenly as possible - (assert (< remainder (length amt-list))) - (loop for i upfrom 0 - while (> remainder 0) - do - (incf (nth i amt-list)) - (decf remainder)) - ;; resize proportionally - (loop for i in children - for amt in amt-list - do - (expand-tree i amt dir) - (offset-tree-dir i ofs dir) - (incf ofs amt))))))) - -(defun join-subtrees (tree leaf) - "expand the children of tree to occupy the space of -LEAF. Return tree with leaf removed." - (let* ((others (remove leaf tree)) - (newtree (if (= (length others) 1) - (car others) - others)) - (split-type (tree-split-type tree)) - (dir (if (eq split-type :column) :right :bottom)) - (ofsdir (if (eq split-type :column) :left :top)) - (amt (if (eq split-type :column) - (tree-width leaf) - (tree-height leaf))) - (after (cdr (member leaf tree)))) - ;; align all children after the leaf with the edge of the - ;; frame before leaf. - (offset-tree-dir after amt ofsdir) - (expand-tree newtree amt dir) - newtree)) - -(defun resize-tree (tree w h &optional x y) - "Scale TREE to width W and height H, ignoring aspect. If X and Y are - provided, reposition the TREE as well." - (let* ((tw (tree-width tree)) - (th (tree-height tree)) - (wf (/ 1 (/ tw w))) - (hf (/ 1 (/ th h))) - (xo (if x (- x (tree-x tree)) 0)) - (yo (if y (- y (tree-y tree)) 0))) - (tree-iterate tree (lambda (f) - (setf (frame-height f) (round (* (frame-height f) hf)) - (frame-y f) (round (* (frame-y f) hf)) - (frame-width f) (round (* (frame-width f) wf)) - (frame-x f) (round (* (frame-x f) wf))) - (incf (frame-y f) yo) - (incf (frame-x f) xo))) - (dformat 4 "resize-tree ~Dx~D -> ~Dx~D~%" tw th (tree-width tree) (tree-height tree)))) - -(defun remove-frame (tree leaf) - "Return a new tree with LEAF and it's sibling merged into -one." - (cond ((atom tree) tree) - ((find leaf tree) - (join-subtrees tree leaf)) - (t (mapcar (lambda (sib) - (remove-frame sib leaf)) - tree)))) - -(defun sync-frame-windows (group frame) - "synchronize windows attached to FRAME." - (mapc (lambda (w) - (when (eq (window-frame w) frame) - (dformat 3 "maximizing ~S~%" w) - (maximize-window w))) - (group-windows group))) - -(defun sync-all-frame-windows (group) - "synchronize all frames in GROUP." - (let ((tree (tile-group-frame-tree group))) - (tree-iterate tree - (lambda (f) - (sync-frame-windows group f))))) - -(defun sync-head-frame-windows (group head) - "synchronize all frames in GROUP and HEAD." - (dolist (f (head-frames group head)) - (sync-frame-windows group f))) - -(defun offset-frames (group x y) - "move the screen's frames around." - (let ((tree (tile-group-frame-tree group))) - (tree-iterate tree (lambda (frame) - (incf (frame-x frame) x) - (incf (frame-y frame) y))))) - -(defun resize-frame (group frame amount dim) - "Resize FRAME by AMOUNT in DIM dimension, DIM can be -either :width or :height" - (check-type group group) - (check-type frame frame) - (check-type amount integer) - ;; (check-type dim (member :width :height)) - (labels ((max-amount (parent node min dim-fn) - (dformat 10 "max ~@{~a~^ ~}~%" parent node min dim-fn) - (if parent - (- (funcall dim-fn parent) - (funcall dim-fn node) - (* min (1- (length parent)))) - ;; no parent means the frame can't get any bigger. - 0))) - (let* ((tree (tile-group-frame-tree group)) - (parent (tree-parent tree frame)) - (gparent (tree-parent tree parent)) - (split-type (tree-split-type parent))) - (dformat 10 "~s ~s parent: ~s ~s width: ~s h: ~s~%" dim amount split-type parent (tree-width parent) (tree-height parent)) - ;; normalize amount - (let* ((max (ecase dim - (:width - (if (>= (frame-width frame) (frame-width (frame-head group frame))) - 0 - (if (eq split-type :column) - (max-amount parent frame *min-frame-width* 'tree-width) - (max-amount gparent parent *min-frame-width* 'tree-width)))) - (:height - (if (>= (frame-height frame) (frame-height (frame-head group frame))) - 0 - (if (eq split-type :row) - (max-amount parent frame *min-frame-height* 'tree-height) - (max-amount gparent parent *min-frame-height* 'tree-height)))))) - (min (ecase dim - ;; Frames taking up the entire HEAD in one - ;; dimension can't be resized in that dimension. - (:width - (if (and (eq split-type :row) - (or (null gparent) - (>= (frame-width frame) (frame-width (frame-head group frame))))) - 0 - (- *min-frame-width* (frame-width frame)))) - (:height - (if (and (eq split-type :column) - (or (null gparent) - (>= (frame-height frame) (frame-height (frame-head group frame))))) - 0 - (- *min-frame-height* (frame-height frame))))))) - (setf amount (max (min amount max) min)) - (dformat 10 "bounds ~d ~d ~d~%" amount max min)) - ;; if FRAME is taking up the whole DIM or if AMOUNT = 0, do nothing - (unless (zerop amount) - (let* ((resize-parent (or (and (eq split-type :column) - (eq dim :height)) - (and (eq split-type :row) - (eq dim :width)))) - (to-resize (if resize-parent parent frame)) - (to-resize-parent (if resize-parent gparent parent)) - (lastp (= (position to-resize to-resize-parent) (1- (length to-resize-parent)))) - (to-shrink (if lastp - (prev-sibling to-resize-parent to-resize) - (next-sibling to-resize-parent to-resize)))) - (expand-tree to-resize amount (ecase dim - (:width (if lastp :left :right)) - (:height (if lastp :top :bottom)))) - (expand-tree to-shrink (- amount) (ecase dim - (:width (if lastp :right :left)) - (:height (if lastp :bottom :top)))) - (unless (and *resize-hides-windows* (eq *top-map* *resize-map*)) - (tree-iterate to-resize - (lambda (leaf) - (sync-frame-windows group leaf))) - (tree-iterate to-shrink - (lambda (leaf) - (sync-frame-windows group leaf))))))))) - -(defun balance-frames-internal (group tree) - "Resize all the children of tree to be of equal width or height -depending on the tree's split direction." - (let* ((split-type (tree-split-type tree)) - (fn (if (eq split-type :column) - 'tree-width - 'tree-height)) - (side (if (eq split-type :column) - :right - :bottom)) - (total (funcall fn tree)) - size rem) - (multiple-value-setq (size rem) (truncate total (length tree))) - (loop - for i in tree - for j = rem then (1- j) - for totalofs = 0 then (+ totalofs ofs) - for ofs = (+ (- size (funcall fn i)) (if (plusp j) 1 0)) - do - (expand-tree i ofs side) - (offset-tree-dir i totalofs side) - (tree-iterate i (lambda (leaf) - (sync-frame-windows group leaf)))))) - -(defun split-frame (group how) - "split the current frame into 2 frames. return T if it succeeded. NIL otherwise." - (check-type how (member :row :column)) - (let* ((frame (tile-group-current-frame group)) - (head (frame-head group frame))) - ;; don't create frames smaller than the minimum size - (when (or (and (eq how :row) - (>= (frame-height frame) (* *min-frame-height* 2))) - (and (eq how :column) - (>= (frame-width frame) (* *min-frame-width* 2)))) - (multiple-value-bind (f1 f2) (funcall (if (eq how :column) - 'split-frame-h - 'split-frame-v) - group frame) - (setf (tile-group-frame-head group head) - (if (atom (tile-group-frame-head group head)) - (list f1 f2) - (funcall-on-node (tile-group-frame-head group head) - (lambda (tree) - (if (eq (tree-split-type tree) how) - (list-splice-replace frame tree f1 f2) - (substitute (list f1 f2) frame tree))) - (lambda (tree) - (unless (atom tree) - (find frame tree)))))) - (migrate-frame-windows group frame f1) - (choose-new-frame-window f2 group) - (if (eq (tile-group-current-frame group) - frame) - (setf (tile-group-current-frame group) f1)) - (setf (tile-group-last-frame group) f2) - (sync-frame-windows group f1) - (sync-frame-windows group f2) - ;; we also need to show the new window in the other frame - (when (frame-window f2) - (unhide-window (frame-window f2))) - t)))) - -(defun draw-frame-outline (group f tl br) - "Draw an outline around FRAME." - (let* ((screen (group-screen group)) - (win (if (frame-window f) (window-xwin (frame-window f)) (screen-root screen))) - (width (screen-frame-outline-width screen)) - (gc (screen-frame-outline-gc screen)) - (halfwidth (/ width 2))) - (let ((x (frame-x f)) - (y (frame-display-y group f)) - (w (frame-width f)) - (h (frame-display-height group f))) - (when tl - (xlib:draw-line win gc - x (+ halfwidth y) w 0 t) - (xlib:draw-line win gc - (+ halfwidth x) y 0 h t)) - (when br - (xlib:draw-line win gc - (+ x (- w halfwidth)) y 0 h t) - (xlib:draw-line win gc - x (+ y (- h halfwidth)) w 0 t))))) - -(defun draw-frame-outlines (group &optional head) - "Draw an outline around all frames in GROUP." - (clear-frame-outlines group) - (dolist (h (if head (list head) (group-heads group))) - (draw-frame-outline group h nil t) - (tree-iterate (tile-group-frame-head group h) (lambda (f) - (draw-frame-outline group f t nil))))) - -(defun clear-frame-outlines (group) - "Clear the outlines drawn with DRAW-FRAME-OUTLINES." - (xlib:clear-area (screen-root (group-screen group)))) - -(defun draw-frame-numbers (group) - "Draw the number of each frame in its corner. Return the list of -windows used to draw the numbers in. The caller must destroy them." - (let ((screen (group-screen group))) - (mapcar (lambda (f) - (let ((w (xlib:create-window - :parent (screen-root screen) - :x (frame-x f) :y (frame-display-y group f) :width 1 :height 1 - :background (screen-fg-color screen) - :border (screen-border-color screen) - :border-width 1 - :event-mask '()))) - (xlib:map-window w) - (setf (xlib:window-priority w) :above) - (echo-in-window w (screen-font screen) - (screen-fg-color screen) - (screen-bg-color screen) - (string (get-frame-number-translation f))) - (xlib:display-finish-output *display*) - (dformat 3 "mapped ~S~%" (frame-number f)) - w)) - (group-frames group)))) - - -;;; Screen functions - -(defun netwm-update-client-list-stacking (screen) - (unless *initializing* - (xlib:change-property (screen-root screen) - :_NET_CLIENT_LIST_STACKING - ;; Order is bottom to top. - (reverse (mapcar 'window-xwin (all-windows))) - :window 32 - :transform #'xlib:drawable-id - :mode :replace))) - -(defun netwm-update-client-list (screen) - (xlib:change-property (screen-root screen) - :_NET_CLIENT_LIST - (screen-mapped-windows screen) - :window 32 - :transform #'xlib:drawable-id - :mode :replace) - (netwm-update-client-list-stacking screen)) - - -(defun screen-add-mapped-window (screen xwin) - (push xwin (screen-mapped-windows screen)) - (netwm-update-client-list screen)) - -(defun screen-remove-mapped-window (screen xwin) - (unregister-window xwin) - (setf (screen-mapped-windows screen) - (remove xwin (screen-mapped-windows screen))) - (netwm-update-client-list screen)) - -(defun sort-screens () - "Return the list of screen sorted by ID." - (sort1 *screen-list* '< :key 'screen-id)) - -(defun next-screen (&optional (list (sort-screens))) - (let ((matches (member (current-screen) list))) - (if (null (cdr matches)) - ;; If the last one in the list is current, then - ;; use the first one. - (car list) - ;; Otherwise, use the next one in the list. - (cadr matches)))) - -(defun move-screen-to-head (screen) - (setf *screen-list* (remove screen *screen-list*)) - (push screen *screen-list*)) - -(defun switch-to-screen (screen) - (when (and screen - (not (eq screen (current-screen)))) - (if (screen-focus screen) - (xlib:set-input-focus *display* (window-xwin (screen-focus screen)) :POINTER-ROOT) - (xlib:set-input-focus *display* (screen-focus-window screen) :POINTER-ROOT)) - (move-screen-to-head screen))) - -(defun screen-set-focus (screen window) - (when (eq (window-group window) - (screen-current-group screen)) - ;;(format t "FOCUS TO: ~a ~a~%" window (window-xwin window)) - ;;(format t "FOCUS BEFORE: ~a~%" (multiple-value-list (xlib:input-focus *display*))) - ;;(format t "FOCUS RET: ~a~%" (xlib:set-input-focus *display* (window-xwin window) :POINTER-ROOT)) - (xlib:set-input-focus *display* (window-xwin window) :POINTER-ROOT) - ;;(xlib:display-finish-output *display*) - ;;(format t "FOCUS IS: ~a~%" (multiple-value-list (xlib:input-focus *display*))) - (xlib:change-property (screen-root screen) :_NET_ACTIVE_WINDOW - (list (window-xwin window)) - :window 32 - :transform #'xlib:drawable-id - :mode :replace) - (setf (screen-focus screen) window) - (move-screen-to-head screen))) - -(defun screen-current-window (screen) - "Return the current window on the specified screen" - (group-current-window (screen-current-group screen))) - -(defun current-window () - "Return the current window on the current screen" - (screen-current-window (current-screen))) - -(defun register-window (window) - (setf (gethash (xlib:window-id (window-xwin window)) *xwin-to-window*) window)) - -(defun unregister-window (xwin) - (remhash (xlib:window-id xwin) *xwin-to-window*)) - -(defun window-by-id (id) - (gethash id *xwin-to-window*)) - -(defun find-window (xwin) - (window-by-id (xlib:window-id xwin))) - -(defun find-window-by-parent (xwin &optional (windows (all-windows))) - (dformat 3 "find-window-by-parent!~%") - (find xwin windows :key 'window-parent :test 'xlib:window-equal)) - -(defun screen-root (screen) - (xlib:screen-root (screen-number screen))) - -(defun update-colors-for-screen (screen) - (let ((fg (screen-fg-color screen)) - (bg (screen-bg-color screen))) - (setf (xlib:gcontext-foreground (screen-message-gc screen)) fg - (xlib:gcontext-background (screen-message-gc screen)) bg - (xlib:gcontext-foreground (screen-frame-outline-gc screen)) fg - (xlib:gcontext-background (screen-frame-outline-gc screen)) bg - (ccontext-default-fg (screen-message-cc screen)) fg - (ccontext-default-bg (screen-message-cc screen)) bg)) - (dolist (i (list (screen-message-window screen) - (screen-input-window screen))) - (setf (xlib:window-border i) (screen-border-color screen) - (xlib:window-background i) (screen-bg-color screen))) - ;; update the backgrounds of all the managed windows - (dolist (g (screen-groups screen)) - (dolist (w (group-windows g)) - (unless (eq w (group-current-window g)) - (setf (xlib:window-background (window-parent w)) (screen-win-bg-color screen)) - (xlib:clear-area (window-parent w))))) - (dolist (i (screen-withdrawn-windows screen)) - (setf (xlib:window-background (window-parent i)) (screen-win-bg-color screen)) - (xlib:clear-area (window-parent i))) - (update-screen-color-context screen)) - -(defun update-colors-all-screens () - "After setting the fg, bg, or border colors. call this to sync any existing windows." - (mapc 'update-colors-for-screen *screen-list*)) - -(defun update-border-for-screen (screen) - (setf (xlib:drawable-border-width (screen-input-window screen)) (screen-msg-border-width screen) - (xlib:drawable-border-width (screen-message-window screen)) (screen-msg-border-width screen))) - -(defun update-border-all-screens () - "After setting the border width call this to sync any existing windows." - (mapc 'update-border-for-screen *screen-list*)) - -(defun internal-window-p (screen win) - "Return t if win is a window used by stumpwm" - (or (xlib:window-equal (screen-message-window screen) win) - (xlib:window-equal (screen-input-window screen) win) - (xlib:window-equal (screen-focus-window screen) win) - (xlib:window-equal (screen-key-window screen) win))) - -(defun unmap-message-window (screen) - "Unmap the screen's message window, if it is mapped." - (unless (eq (xlib:window-map-state (screen-message-window screen)) :unmapped) - (xlib:unmap-window (screen-message-window screen)))) - -(defun unmap-all-message-windows () - (mapc #'unmap-message-window *screen-list*) - (when (timer-p *message-window-timer*) - (cancel-timer *message-window-timer*) - (setf *message-window-timer* nil))) - -(defun unmap-frame-indicator-window (screen) - "Unmap the screen's message window, if it is mapped." -;; (unless (eq (xlib:window-map-state (screen-frame-window screen)) :unmapped) - (xlib:unmap-window (screen-frame-window screen))) - -(defun unmap-all-frame-indicator-windows () - (mapc #'unmap-frame-indicator-window *screen-list*) - (when (timer-p *frame-indicator-timer*) - (cancel-timer *frame-indicator-timer*) - (setf *frame-indicator-timer* nil))) - -(defun reset-message-window-timer () - "Set the message window timer to timeout in *timeout-wait* seconds." - (unless *ignore-echo-timeout* - (when (timer-p *message-window-timer*) - (cancel-timer *message-window-timer*)) - (setf *message-window-timer* (run-with-timer *timeout-wait* nil - 'unmap-all-message-windows)))) - -(defun reset-frame-indicator-timer () - "Set the message window timer to timeout in *timeout-wait* seconds." - (when (timer-p *frame-indicator-timer*) - (cancel-timer *frame-indicator-timer*)) - (setf *frame-indicator-timer* (run-with-timer *timeout-frame-indicator-wait* nil - 'unmap-all-frame-indicator-windows))) - -(defun show-frame-outline (group &optional (clear t)) - ;; Don't draw if this isn't a current group! - (when (find group (mapcar 'screen-current-group *screen-list*)) - (dformat 5 "show-frame-outline!~%") - ;; *resize-hides-windows* uses the frame outlines for display, - ;; so try not to interfere. - (unless (eq *top-map* *resize-map*) - (when clear - (clear-frame-outlines group)) - (let ((frame (tile-group-current-frame group))) - (unless (and (= 1 (length (tile-group-frame-tree group))) - (atom (first (tile-group-frame-tree group)))) - ;; draw the outline - (unless (frame-window frame) - (draw-frame-outline group frame t t))))))) - -(defun show-frame-indicator (group &optional force) - (show-frame-outline group) - ;; FIXME: Arg, these tests are already done in show-frame-outline - (when (find group (mapcar 'screen-current-group *screen-list*)) - (when (or force - (and (or (> 1 (length (tile-group-frame-tree group))) - (not (atom (first (tile-group-frame-tree group))))) - (not *suppress-frame-indicator*))) - (let ((frame (tile-group-current-frame group)) - (w (screen-frame-window (current-screen))) - (string *frame-indicator-text*) - (font (screen-font (current-screen)))) - (xlib:with-state (w) - (setf (xlib:drawable-x w) (+ (frame-x frame) - (truncate (- (frame-width frame) (xlib:text-width font string)) 2)) - (xlib:drawable-y w) (+ (frame-y frame) - (truncate (- (frame-height frame) (font-height font)) 2)) - (xlib:window-priority w) :above)) - (xlib:map-window w) - (echo-in-window w font (screen-fg-color (current-screen)) (screen-bg-color (current-screen)) string) - (reset-frame-indicator-timer))))) - -(defun echo-in-window (win font fg bg string) - (let* ((height (font-height font)) - (gcontext (xlib:create-gcontext :drawable win - :font font - :foreground fg - :background bg)) - (width (xlib:text-width font string))) - (xlib:with-state (win) - (setf (xlib:drawable-height win) height - (xlib:drawable-width win) width)) - (xlib:clear-area win) - (xlib:display-finish-output *display*) - (xlib:draw-image-glyphs win gcontext 0 (xlib:font-ascent font) string))) - -(defun push-last-message (screen strings highlights) - ;; only push unique messages - (unless *record-last-msg-override* - (push strings (screen-last-msg screen)) - (push highlights (screen-last-msg-highlights screen)) - ;; crop for size - (when (>= (length (screen-last-msg screen)) *max-last-message-size*) - (setf (screen-last-msg screen) (butlast (screen-last-msg screen))) - (setf (screen-last-msg-highlights screen) (butlast (screen-last-msg-highlights screen)))))) - -(defun redraw-current-message (screen) - (let ((*record-last-msg-override* t) - (*ignore-echo-timeout* t)) - (dformat 5 "Redrawing message window!~%") - (apply 'echo-string-list screen (screen-current-msg screen) (screen-current-msg-highlights screen)))) - -(defun echo-nth-last-message (screen n) - (let ((*record-last-msg-override* t)) - (apply 'echo-string-list screen (nth n (screen-last-msg screen)) (nth n (screen-last-msg-highlights screen))))) - -(defun echo-string-list (screen strings &rest highlights) - "Draw each string in l in the screen's message window. HIGHLIGHT is - the nth entry to highlight." - (when strings - (unless *executing-stumpwm-command* - (let ((width (render-strings screen (screen-message-cc screen) *message-window-padding* 0 strings '() nil))) - (setup-message-window screen (length strings) width) - (render-strings screen (screen-message-cc screen) *message-window-padding* 0 strings highlights)) - (setf (screen-current-msg screen) - strings - (screen-current-msg-highlights screen) - highlights)) - (push-last-message screen strings highlights) - (xlib:display-finish-output *display*) - ;; Set a timer to hide the message after a number of seconds - (if *suppress-echo-timeout* - ;; any left over timers need to be canceled. - (when (timer-p *message-window-timer*) - (cancel-timer *message-window-timer*) - (setf *message-window-timer* nil)) - (reset-message-window-timer)) - (apply 'run-hook-with-args *message-hook* strings))) - -(defun echo-string (screen msg) - "Display @var{string} in the message bar on @var{screen}. You almost always want to use @command{message}." - (echo-string-list screen (split-string msg (string #\Newline)))) - -(defun message (fmt &rest args) - "run FMT and ARGS through `format' and echo the result to the current screen." - (echo-string (current-screen) (apply 'format nil fmt args))) - - -(defun err (fmt &rest args) - "run FMT and ARGS through format and echo the result to the -current screen along with a backtrace. For careful study, the -message does not time out." - (let ((*suppress-echo-timeout* t)) - (echo-string (current-screen) - (concat (apply 'format nil fmt args) - (backtrace-string))))) - -(defun message-no-timeout (fmt &rest args) - "Like message, but the window doesn't disappear after a few seconds." - (let ((*suppress-echo-timeout* t)) - (apply 'message fmt args))) - -(defmacro with-current-screen (screen &body body) - "A macro to help us out with early set up." - `(let ((*screen-list* (list ,screen))) - ,@body)) - -(defun current-screen () - "Return the current screen." - (car *screen-list*)) - -(defun netwm-set-properties (screen focus-window) - "Set NETWM properties on the root window of the specified screen. -FOCUS-WINDOW is an extra window used for _NET_SUPPORTING_WM_CHECK." - (let* ((screen-number (screen-number screen)) - (root (xlib:screen-root screen-number))) - ;; _NET_SUPPORTED - (xlib:change-property root :_NET_SUPPORTED - (mapcar (lambda (a) - (xlib:intern-atom *display* a)) - (append +netwm-supported+ - (mapcar #'car +netwm-window-types+))) - :atom 32) - - ;; _NET_SUPPORTING_WM_CHECK - (xlib:change-property root :_NET_SUPPORTING_WM_CHECK - (list focus-window) :window 32 - :transform #'xlib:drawable-id) - (xlib:change-property focus-window :_NET_SUPPORTING_WM_CHECK - (list focus-window) :window 32 - :transform #'xlib:drawable-id) - (xlib:change-property focus-window :_NET_WM_NAME - "stumpwm" - :string 8 :transform #'xlib:char->card8) - - ;; _NET_CLIENT_LIST - (xlib:change-property root :_NET_CLIENT_LIST - () :window 32 - :transform #'xlib:drawable-id) - - ;; _NET_DESKTOP_GEOMETRY - (xlib:change-property root :_NET_DESKTOP_GEOMETRY - (list (xlib:screen-width screen-number) - (xlib:screen-height screen-number)) - :cardinal 32) - - ;; _NET_DESKTOP_VIEWPORT - (xlib:change-property root :_NET_DESKTOP_VIEWPORT - (list 0 0) :cardinal 32) - - (netwm-set-group-properties screen))) - -(defun init-screen (screen-number id host) - "Given a screen number, returns a screen structure with initialized members" - ;; Listen for the window manager events on the root window - (dformat 1 "Initializing screen: ~a ~a~%" host id) - (setf (xlib:window-event-mask (xlib:screen-root screen-number)) - '(:substructure-redirect - :substructure-notify - :property-change - :structure-notify - :button-press - :exposure)) - (xlib:display-finish-output *display*) - ;; Initialize the screen structure - (labels ((ac (color) - (xlib:alloc-color (xlib:screen-default-colormap screen-number) color))) - (let* ((screen (make-screen)) - (fg (ac +default-foreground-color+)) - (bg (ac +default-background-color+)) - (border (ac +default-border-color+)) - (focus (ac +default-focus-color+)) - (unfocus (ac +default-unfocus-color+)) - (win-bg (ac +default-window-background-color+)) - (input-window (xlib:create-window :parent (xlib:screen-root screen-number) - :x 0 :y 0 :width 20 :height 20 - :background bg - :border border - :border-width 1 - :colormap (xlib:screen-default-colormap - screen-number) - :event-mask '(:key-press :key-release))) - (focus-window (xlib:create-window :parent (xlib:screen-root screen-number) - :x 0 :y 0 :width 1 :height 1)) - (key-window (xlib:create-window :parent (xlib:screen-root screen-number) - :x 0 :y 0 :width 1 :height 1 - :event-mask '(:key-press :key-release))) - (message-window (xlib:create-window :parent (xlib:screen-root screen-number) - :x 0 :y 0 :width 1 :height 1 - :background bg - :bit-gravity :north-east - :border border - :border-width 1 - :colormap (xlib:screen-default-colormap - screen-number) - :event-mask '(:exposure))) - (frame-window (xlib:create-window :parent (xlib:screen-root screen-number) - :x 0 :y 0 :width 20 :height 20 - :background bg - :border border - :border-width 1 - :colormap (xlib:screen-default-colormap - screen-number) - :event-mask '(:exposure))) - (font (xlib:open-font *display* +default-font-name+)) - (group (make-tile-group - :screen screen - :number 1 - :name *default-group-name*))) - ;; Create our screen structure - ;; The focus window is mapped at all times - (xlib:map-window focus-window) - (xlib:map-window key-window) - (xwin-grab-keys focus-window) - (setf (screen-number screen) screen-number - (screen-id screen) id - (screen-host screen) host - (screen-groups screen) (list group) - (screen-current-group screen) group - (screen-font screen) font - (screen-fg-color screen) fg - (screen-bg-color screen) bg - (screen-win-bg-color screen) win-bg - (screen-border-color screen) border - (screen-focus-color screen) focus - (screen-unfocus-color screen) unfocus - (screen-msg-border-width screen) 1 - (screen-frame-outline-width screen) +default-frame-outline-width+ - (screen-input-window screen) input-window - (screen-focus-window screen) focus-window - (screen-key-window screen) key-window - (screen-frame-window screen) frame-window - (screen-ignore-msg-expose screen) 0 - (screen-message-cc screen) (make-ccontext :win message-window - :gc (xlib:create-gcontext - :drawable message-window - :font font - :foreground fg - :background bg)) - (screen-frame-outline-gc screen) (xlib:create-gcontext :drawable (screen-root screen) - :font font - :foreground fg - :background fg - :line-style :double-dash - :line-width +default-frame-outline-width+)) - (setf (screen-heads screen) (make-screen-heads screen (xlib:screen-root screen-number)) - (tile-group-frame-tree group) (copy-heads screen) - (tile-group-current-frame group) (first (tile-group-frame-tree group))) - (netwm-set-properties screen focus-window) - (update-colors-for-screen screen) - (update-color-map screen) - screen))) - - -;;; Head functions - -(defun head-by-number (screen n) - (find n (screen-heads screen) :key 'head-number)) - -(defun parse-xinerama-head (line) - (ppcre:register-groups-bind (('parse-integer number width height x y)) - ("^ +head #([0-9]+): ([0-9]+)x([0-9]+) @ ([0-9]+),([0-9]+)" line :sharedp t) - (handler-case - (make-head :number number - :x x :y y - :width width - :height height) - (parse-error () - nil)))) - -(defun make-screen-heads (screen root) - "or use xdpyinfo to query the xinerama extension, if it's enabled." - (or (and (xlib:query-extension *display* "XINERAMA") - (with-current-screen screen - ;; Ignore 'clone' heads. - (loop - for i = 0 then (1+ i) - for h in - (delete-duplicates - (loop for i in (split-string (run-shell-command "xdpyinfo -ext XINERAMA" t)) - for head = (parse-xinerama-head i) - when head - collect head) - :test #'frames-overlap-p) - do (setf (head-number h) i) - collect h))) - (list (make-head :number 0 - :x 0 :y 0 - :width (xlib:drawable-width root) - :height (xlib:drawable-height root) - :window nil)))) - -(defun copy-heads (screen) - "Return a copy of screen's heads." - (mapcar 'copy-frame (screen-heads screen))) - - -;; Determining a frame's head based on position probably won't -;; work with overlapping heads. Would it be better to walk -;; up the frame tree? -(defun frame-head (group frame) - (dolist (head (screen-heads (group-screen group))) - (when (and - (>= (frame-x frame) (frame-x head)) - (>= (frame-y frame) (frame-y head)) - (<= (+ (frame-x frame) (frame-width frame)) - (+ (frame-x head) (frame-width head))) - (<= (+ (frame-y frame) (frame-height frame)) - (+ (frame-y head) (frame-height head)))) - (return head)))) - -(defun group-heads (group) - (screen-heads (group-screen group))) - -(defun tile-group-frame-head (group head) - (elt (tile-group-frame-tree group) (position head (group-heads group)))) - -(defun (setf tile-group-frame-head) (frame group head) - (setf (elt (tile-group-frame-tree group) (position head (group-heads group))) frame)) - -(defun current-head (&optional (group (current-group))) - (frame-head group (tile-group-current-frame group))) - -(defun head-windows (group head) - "Returns a list of windows on HEAD of GROUP" - (remove-if-not - (lambda (w) - (eq head (frame-head group (window-frame w)))) - (group-windows group))) - -(defun frame-is-head (group frame) - (< (frame-number frame) (length (group-heads group)))) - -(defun add-head (screen head) - (dformat 1 "Adding head #~D~%" (head-number head)) - (setf (screen-heads screen) (sort (push head (screen-heads screen)) #'< :key 'head-number)) - (dolist (group (screen-groups screen)) - (setf (tile-group-frame-tree group) - (sort (push (copy-frame head) (tile-group-frame-tree group)) - #'< :key (lambda (tile) - (if (atom tile) - (frame-number tile) - (frame-number (car tile)))))) - ;; Try to put something in the new frame - (let ((frame (tile-group-frame-head group head))) - (choose-new-frame-window frame group) - (when (frame-window frame) - (unhide-window (frame-window frame)))))) - -(defun remove-head (screen head) - (dformat 1 "Removing head #~D~%" (head-number head)) - (dolist (group (screen-groups screen)) - ;; Hide its windows. - (let ((windows (head-windows group head))) - ;; Remove it from the frame tree. - (setf (tile-group-frame-tree group) (delete (tile-group-frame-head group head) (tile-group-frame-tree group))) - ;; Just set current frame to whatever. - (let ((frame (first (group-frames group)))) - (setf (tile-group-current-frame group) frame - (tile-group-last-frame group) nil) - (dolist (window windows) - (hide-window window) - (setf (window-frame window) frame)))) - ;; Try to do something with the orphaned windows - (populate-frames group)) - (when (head-mode-line head) - (toggle-mode-line screen head)) - ;; Remove it from SCREEN's head list. - (setf (screen-heads screen) (delete head (screen-heads screen)))) - -(defun scale-head (screen oh nh) - "Scales head OH to match the dimensions of NH." - (dolist (group (screen-groups screen)) - (resize-tree (tile-group-frame-head group oh) (head-width nh) (head-height nh) (head-x nh) (head-y nh))) - (setf (head-x oh) (head-x nh) - (head-y oh) (head-y nh) - (head-width oh) (head-width nh) - (head-height oh) (head-height nh))) - ;;; keyboard helper functions @@ -2813,692 +135,3 @@ list of modifier symbols." (defun warp-pointer-relative (dx dy) "Move the pointer by DX and DY relative to the current location." (xlib:warp-pointer-relative *display* dx dy)) - - -;; Event handler functions - -(defparameter *event-fn-table* (make-hash-table) - "A hash of event types to functions") - -(defmacro define-stump-event-handler (event keys &body body) - (let ((fn-name (gensym)) - (event-slots (gensym))) - `(labels ((,fn-name (&rest ,event-slots &key ,@keys &allow-other-keys) - (declare (ignore ,event-slots)) - ,@body)) - (setf (gethash ,event *event-fn-table*) #',fn-name)))) - - ;(define-stump-event-handler :map-notify (event-window window override-redirect-p) - ; ) - -(defun handle-mode-line-window (xwin x y width height) - (declare (ignore width)) - (let ((ml (find-mode-line-window xwin))) - (when ml - (setf (xlib:drawable-height xwin) height) - (update-mode-line-position ml x y) - (resize-mode-line ml) - (sync-mode-line ml)))) - -(defun handle-unmanaged-window (xwin x y width height border-width value-mask) - "Call this function for windows that stumpwm isn't - managing. Basically just give the window what it wants." - (labels ((has-x (mask) (= 1 (logand mask 1))) - (has-y (mask) (= 2 (logand mask 2))) - (has-w (mask) (= 4 (logand mask 4))) - (has-h (mask) (= 8 (logand mask 8))) - (has-bw (mask) (= 16 (logand mask 16))) - ;; (has-stackmode (mask) (= 64 (logand mask 64))) - ) - (xlib:with-state (xwin) - (when (has-x value-mask) - (setf (xlib:drawable-x xwin) x)) - (when (has-y value-mask) - (setf (xlib:drawable-y xwin) y)) - (when (has-h value-mask) - (setf (xlib:drawable-height xwin) height)) - (when (has-w value-mask) - (setf (xlib:drawable-width xwin) width)) - (when (has-bw value-mask) - (setf (xlib:drawable-border-width xwin) border-width))))) - -(defun update-configuration (win) - ;; Send a synthetic configure-notify event so that the window - ;; knows where it is onscreen. - (xwin-send-configuration-notify (window-xwin win) - (xlib:drawable-x (window-parent win)) - (xlib:drawable-y (window-parent win)) - (window-width win) (window-height win) 0)) - -(defun handle-managed-window (window width height stack-mode value-mask) - "This is a managed window so deal with it appropriately." - ;; Grant the stack-mode change (if it's mapped) - (set-window-geometry window :width width :height height) - (maximize-window window) - (when (and (window-in-current-group-p window) - ;; stack-mode change? - (= 64 (logand value-mask 64))) - (case stack-mode - (:above - (maybe-raise-window window)))) - (update-configuration window)) - -(defun handle-window-move (win x y relative-to &optional (value-mask -1)) - (when *honor-window-moves* - (dformat 3 "Window requested new position ~D,~D relative to ~S~%" x y relative-to) - (labels ((has-x (mask) (= 1 (logand mask 1))) - (has-y (mask) (= 2 (logand mask 2)))) - (when (or (eq relative-to :root) (has-x value-mask) (has-y value-mask)) - (let* ((group (window-group win)) - (pos (if (eq relative-to :parent) - (list - (+ (xlib:drawable-x (window-parent win)) x) - (+ (xlib:drawable-y (window-parent win)) y)) - (list x y))) - (frame (apply #'find-frame group pos))) - (when frame - (pull-window win frame))))))) - -(define-stump-event-handler :configure-request (stack-mode #|parent|# window #|above-sibling|# x y width height border-width value-mask) - ;; Grant the configure request but then maximize the window after the granting. - (dformat 3 "CONFIGURE REQUEST ~@{~S ~}~%" stack-mode window x y width height border-width value-mask) - (let ((win (find-window window))) - (cond - (win - (handle-window-move win x y :parent value-mask) - (handle-managed-window win width height stack-mode value-mask)) - ((handle-mode-line-window window x y width height)) - (t (handle-unmanaged-window window x y width height border-width value-mask))))) - -(defun scale-screen (screen heads) - "Scale all frames of all groups of SCREEN to match the dimensions - of HEADS." - (when (< (length heads) (length (screen-heads screen))) - ;; Some heads were removed (or cloned), try to guess which. - (dolist (oh (screen-heads screen)) - (dolist (nh heads) - (when (and (= (head-x nh) (head-x oh)) - (= (head-y nh) (head-y oh))) - ;; Same screen position; probably the same head. - (setf (head-number nh) (head-number oh))))) - ;; Actually remove the missing heads. - (dolist (head (set-difference (screen-heads screen) heads :key 'head-number)) - (remove-head screen head))) - (loop - for nh in heads - as oh = (find (head-number nh) (screen-heads screen) :key 'head-number) - do (if oh - (scale-head screen oh nh) - (add-head screen nh)))) - -(define-stump-event-handler :configure-notify (stack-mode #|parent|# window #|above-sibling|# x y width height border-width value-mask) - (dformat 4 "CONFIGURE NOTIFY ~@{~S ~}~%" stack-mode window x y width height border-width value-mask) - (let ((screen (find-screen window))) - (when screen - (let ((old-heads (copy-list (screen-heads screen)))) - (setf (screen-heads screen) nil) - (let ((new-heads (make-screen-heads screen (screen-root screen)))) - (setf (screen-heads screen) old-heads) - (cond - ((equalp old-heads new-heads) - (dformat 3 "Bogus configure-notify on root window of ~S~%" screen) t) - (t - (dformat 1 "Updating Xinerama configuration for ~S.~%" screen) - (if new-heads - (progn - (scale-screen screen new-heads) - (mapc 'sync-all-frame-windows (screen-groups screen)) - (update-mode-lines screen)) - (dformat 1 "Invalid configuration! ~S~%" new-heads))))))))) - -(define-stump-event-handler :map-request (parent send-event-p window) - (unless send-event-p - ;; This assumes parent is a root window and it should be. - (dformat 3 "map request: ~a ~a ~a~%" window parent (find-window window)) - (let ((screen (find-screen parent)) - (win (find-window window)) - (wwin (find-withdrawn-window window))) - ;; only absorb it if it's not already managed (it could be iconic) - (cond - (win (dformat 1 "map request for mapped window ~a~%" win)) - ((eq (xwin-type window) :dock) - (when wwin - (setf screen (window-screen wwin))) - (dformat 1 "window is dock-type. attempting to place in mode-line.") - (place-mode-line-window screen window) - ;; Some panels are broken and only set the dock type after they map and withdraw. - (when wwin - (setf (screen-withdrawn-windows screen) (delete wwin (screen-withdrawn-windows screen)))) - t) - (wwin (restore-window wwin)) - ((xlib:get-property window :_KDE_NET_WM_SYSTEM_TRAY_WINDOW_FOR) - ;; Do nothing if this is a systray window (the system tray - ;; will handle it, if there is one, and, if there isn't the - ;; user doesn't want this popping up as a managed window - ;; anyway. - t) - (t - (let ((window (process-mapped-window screen window))) - ;; Give it focus - (if (deny-request-p window *deny-map-request*) - (unless *suppress-deny-messages* - (if (eq (window-group window) (current-group)) - (echo-string (window-screen window) (format nil "'~a' denied map request" (window-name window))) - (echo-string (window-screen window) (format nil "'~a' denied map request in group ~a" (window-name window) (group-name (window-group window)))))) - (frame-raise-window (window-group window) (window-frame window) window - (if (eq (window-frame window) - (tile-group-current-frame (window-group window))) - t nil))))))))) - -(define-stump-event-handler :unmap-notify (send-event-p event-window window #|configure-p|#) - ;; There are two kinds of unmap notify events: the straight up - ;; ones where event-window and window are the same, and - ;; substructure unmap events when the event-window is the parent - ;; of window. - (dformat 2 "UNMAP: ~s ~s ~a~%" send-event-p (not (xlib:window-equal event-window window)) (find-window window)) - (unless (and (not send-event-p) - (not (xlib:window-equal event-window window))) - (let ((window (find-window window))) - ;; if we can't find the window then there's nothing we need to - ;; do. - (when window - (if (plusp (window-unmap-ignores window)) - (progn - (dformat 3 "decrement ignores! ~d~%" (window-unmap-ignores window)) - (decf (window-unmap-ignores window))) - (withdraw-window window)))))) - -;;(define-stump-event-handler :create-notify (#|window parent x y width height border-width|# override-redirect-p)) -;; (unless (or override-redirect-p -;; (internal-window-p (window-screen window) window)) -;; (process-new-window (window-screen window) window)) -;; (run-hook-with-args *new-window-hook* window))) - -(define-stump-event-handler :destroy-notify (send-event-p event-window window) - (unless (or send-event-p - (xlib:window-equal event-window window)) - ;; Ignore structure destroy notifies and only - ;; use substructure destroy notifiers. This way - ;; event-window is the window's parent. - (let ((win (or (find-window window) - (find-withdrawn-window window)))) - (if win - (destroy-window win) - (progn - (let ((ml (find-mode-line-window window))) - (when ml (destroy-mode-line-window ml)))))))) - -(defun read-from-keymap (kmap &optional update-fn) - "Read a sequence of keys from the user, guided by the keymap, -KMAP and return the binding or nil if the user hit an unbound sequence. - -The Caller is responsible for setting up the input focus." - (let* ((code-state (read-key-no-modifiers)) - (code (car code-state)) - (state (cdr code-state))) - (handle-keymap kmap code state nil nil update-fn))) - -(defun handle-keymap (kmap code state key-seq grab update-fn) - "Find the command mapped to the (code state) and return it." - ;; a symbol is assumed to have a hashtable as a value. - (dformat 1 "Awaiting key ~a~%" kmap) - (let ((keymap '())) - (when (and (symbolp kmap) - (boundp kmap) - (hash-table-p (symbol-value kmap))) - (setf - keymap kmap - kmap (symbol-value kmap))) - (check-type kmap hash-table) - (let* ((key (code-state->key code state)) - (cmd (lookup-key kmap key)) - (key-seq (cons key key-seq))) - (dformat 1 "key-press: ~S ~S ~S~%" key state cmd) - (run-hook-with-args *key-press-hook* key key-seq cmd) - (when update-fn - (funcall update-fn key-seq)) - (if cmd - (cond - ((or (hash-table-p cmd) - (and (symbolp cmd) - (boundp cmd) - (hash-table-p (symbol-value cmd)))) - (when grab - (grab-pointer (current-screen))) - (let* ((code-state (read-key-no-modifiers)) - (code (car code-state)) - (state (cdr code-state))) - (unwind-protect - (handle-keymap cmd code state key-seq nil update-fn) - (when grab (ungrab-pointer))))) - (t (values cmd key-seq))) - (if (find key (list (kbd "?") - (kbd "C-h")) - :test 'equalp) - (progn (display-keybinding keymap) (values t key-seq)) - (values nil key-seq)))))) - -(define-stump-event-handler :key-press (code state #|window|#) - (labels ((get-cmd (code state) - (with-focus (screen-key-window (current-screen)) - (handle-keymap *top-map* code state nil t nil)))) - (unwind-protect - ;; modifiers can sneak in with a race condition. so avoid that. - (unless (is-modifier code) - (multiple-value-bind (cmd key-seq) (get-cmd code state) - (cond - ((eq cmd t)) - (cmd - (unmap-message-window (current-screen)) - (interactive-command cmd) t) - (t (message "~{~a ~}not bound." (mapcar 'print-key (nreverse key-seq)))))))))) - -(defun bytes-to-window (bytes) - "A sick hack to assemble 4 bytes into a 32 bit number. This is -because ratpoison sends the rp_command_request window in 8 byte -chunks." - (+ (first bytes) - (ash (second bytes) 8) - (ash (third bytes) 16) - (ash (fourth bytes) 24))) - -(defun handle-rp-commands (root) - "Handle a ratpoison style command request." - (labels ((one-cmd () - (multiple-value-bind (win type format bytes-after) (xlib:get-property root :rp_command_request :end 4 :delete-p t) - (declare (ignore type format)) - (setf win (xlib::lookup-window *display* (bytes-to-window win))) - (when (xlib:window-p win) - (let* ((data (xlib:get-property win :rp_command)) - (interactive-p (car data)) - (cmd (map 'string 'code-char (nbutlast (cdr data))))) - (declare (ignore interactive-p)) - (interactive-command cmd) - (xlib:change-property win :rp_command_result (map 'list 'char-code "0TODO") :string 8) - (xlib:display-finish-output *display*))) - bytes-after))) - (loop while (> (one-cmd) 0)))) - -(defun handle-stumpwm-commands (root) - "Handle a StumpWM style command request." - (let* ((win root) - (screen (find-screen root)) - (data (xlib:get-property win :stumpwm_command :delete-p t)) - (cmd (bytes-to-string data))) - (let ((msgs (screen-last-msg screen)) - (hlts (screen-last-msg-highlights screen)) - (*executing-stumpwm-command* t)) - (setf (screen-last-msg screen) '() - (screen-last-msg-highlights screen) '()) - (interactive-command cmd) - (xlib:change-property win :stumpwm_command_result - (string-to-bytes (format nil "~{~{~a~%~}~}" (nreverse (screen-last-msg screen)))) - :string 8) - (setf (screen-last-msg screen) msgs - (screen-last-msg-highlights screen) hlts)) - (xlib:display-finish-output *display*))) - -(defun update-window-properties (window atom) - (case atom - (:wm_name - (setf (window-title window) (xwin-name (window-xwin window))) - ;; Let the mode line know about the new name. - (update-all-mode-lines)) - (:wm_normal_hints - (setf (window-normal-hints window) (xlib:wm-normal-hints (window-xwin window)) - (window-type window) (xwin-type (window-xwin window))) - (dformat 4 "new hints: ~s~%" (window-normal-hints window)) - (maximize-window window)) - (:wm_hints) - (:wm_class - (setf (window-class window) (xwin-class (window-xwin window)) - (window-res window) (xwin-res-name (window-xwin window)))) - (:wm_window_role - (setf (window-role window) (xwin-role (window-xwin window)))) - (:wm_transient_for - (setf (window-type window) (xwin-type (window-xwin window))) - (maximize-window window)) - (:_NET_WM_STATE - ;; Client is broken and sets this property itself instead of sending a - ;; client request to the root window. Try to make do. - (dolist (p (xlib:get-property (window-xwin window) :_NET_WM_STATE)) - (case (xlib:atom-name *display* p) - (:_NET_WM_STATE_FULLSCREEN - ;; FIXME: what about when properties are REMOVED? - (update-fullscreen window 1))))))) - -(define-stump-event-handler :property-notify (window atom state) - (dformat 2 "property notify ~s ~s ~s~%" window atom state) - (case atom - (:rp_command_request - ;; we will only find the screen if window is a root window, which - ;; is the only place we listen for ratpoison commands. - (let* ((screen (find-screen window))) - (when (and (eq state :new-value) - screen) - (handle-rp-commands window)))) - (:stumpwm_command - ;; RP commands are too weird and problematic, KISS. - (let* ((screen (find-screen window))) - (when (and (eq state :new-value) - screen) - (handle-stumpwm-commands window)))) - (t - (let ((window (find-window window))) - (when window - (update-window-properties window atom)))))) - -(define-stump-event-handler :mapping-notify (request start count) - ;; We could be a bit more intelligent about when to update the - ;; modifier map, but I don't think it really matters. - (xlib:mapping-notify *display* request start count) - (update-modifier-map) - (sync-keys)) - -(define-stump-event-handler :selection-request (requestor property selection target time) - (send-selection requestor property selection target time)) - -(define-stump-event-handler :selection-clear () - (setf *x-selection* nil)) - -(defun find-message-window-screen (win) - "Return the screen, if any, that message window WIN belongs." - (dolist (screen *screen-list*) - (when (xlib:window-equal (screen-message-window screen) win) - (return screen)))) - -(defun draw-cross (screen window x y width height) - (xlib:draw-line window - (screen-frame-outline-gc screen) - x y - width height - t) - (xlib:draw-line window - (screen-frame-outline-gc screen) - x (+ y height) - (+ x width) y)) - -(define-stump-event-handler :exposure (window x y width height count) - (let (screen ml) - (when (zerop count) - (cond - ((setf screen (find-screen window)) - ;; root exposed - (show-frame-outline (screen-current-group screen) nil)) - ((setf screen (find-message-window-screen window)) - ;; message window exposed - (if (plusp (screen-ignore-msg-expose screen)) - (decf (screen-ignore-msg-expose screen)) - (redraw-current-message screen))) - ((setf ml (find-mode-line-window window)) - (setf screen (mode-line-screen ml)) - (redraw-mode-line ml t))) - ;; Show the area. - (when (and *debug-expose-events* screen) - (draw-cross screen window x y width height))))) - - -(define-stump-event-handler :reparent-notify (window parent) - (let ((win (find-window window))) - (when (and win - (not (xlib:window-equal parent (window-parent win)))) - ;; reparent it back - (unless (eq (xlib:window-map-state (window-xwin win)) :unmapped) - (incf (window-unmap-ignores win))) - (xlib:reparent-window (window-xwin win) (window-parent win) 0 0)))) - - -;;; Fullscreen functions - -(defun activate-fullscreen (window) - (dformat 2 "client requests to go fullscreen~%") - (add-wm-state (window-xwin window) :_NET_WM_STATE_FULLSCREEN) - (setf (window-fullscreen window) t) - (maximize-window window) - (focus-window window)) - -(defun deactivate-fullscreen (window) - (setf (window-fullscreen window) nil) - (dformat 2 "client requests to leave fullscreen~%") - (remove-wm-state (window-xwin window) :_NET_WM_STATE_FULLSCREEN) - (setf (xlib:drawable-border-width (window-parent window)) (default-border-width-for-type (window-type window))) - (maximize-window window) - (update-window-border window) - (update-mode-lines (current-screen))) - -(defun update-fullscreen (window action) - (let ((fullscreen-p (window-fullscreen window))) - (case action - (0 ; _NET_WM_STATE_REMOVE - (when fullscreen-p - (deactivate-fullscreen window))) - (1 ; _NET_WM_STATE_ADD - (unless fullscreen-p - (activate-fullscreen window))) - (2 ; _NET_WM_STATE_TOGGLE - (if fullscreen-p - (deactivate-fullscreen window) - (activate-fullscreen window)))))) - - -(defun maybe-raise-window (window) - (if (deny-request-p window *deny-raise-request*) - (unless (or *suppress-deny-messages* - ;; don't mention windows that are already visible - (eq (frame-window (window-frame window)) window)) - (if (eq (window-group window) (current-group)) - (echo-string (window-screen window) (format nil "'~a' denied raise request" (window-name window))) - (echo-string (window-screen window) (format nil "'~a' denied raise request in group ~a" (window-name window) (group-name (window-group window)))))) - (focus-all window))) - -(define-stump-event-handler :client-message (window type #|format|# data) - (dformat 2 "client message: ~s ~s~%" type data) - (case type - (:_NET_CURRENT_DESKTOP ;switch desktop - (let* ((screen (find-screen window)) - (n (elt data 0)) - (group (and screen - (< n (length (screen-groups screen))) - (elt (sort-groups screen) n)))) - (when group - (switch-to-group group)))) - (:_NET_WM_DESKTOP ;move window to desktop - (let* ((our-window (find-window window)) - (screen (when our-window - (window-screen our-window))) - (n (elt data 0)) - (group (and screen - (< n (length (screen-groups screen))) - (elt (sort-groups screen) n)))) - (when (and our-window group) - (move-window-to-group our-window group)))) - (:_NET_ACTIVE_WINDOW - (let ((our-window (find-window window)) - (source (elt data 0))) - (when our-window - (if (= source 2) ;request is from a pager - (focus-all our-window) - (maybe-raise-window our-window))))) - (:_NET_CLOSE_WINDOW - (let ((our-window (find-window window))) - (when our-window - (delete-window our-window)))) - (:_NET_WM_STATE - (let ((our-window (find-window window))) - (when our-window - (let ((action (elt data 0)) - (p1 (elt data 1)) - (p2 (elt data 2))) - (dolist (p (list p1 p2)) - (unless (= p 0) - (case (xlib:atom-name *display* p) - (:_NET_WM_STATE_FULLSCREEN - (update-fullscreen our-window action))))))))) - (:_NET_MOVERESIZE_WINDOW - (let ((our-window (find-window window))) - (when our-window - (let ((x (elt data 1)) - (y (elt data 2))) - (dformat 3 "!!! Data: ~S~%" data) - (handle-window-move our-window x y :relative :root))))) - (t - (dformat 2 "ignored message~%")))) - -(define-stump-event-handler :focus-out (window mode kind) - (dformat 5 "~@{~s ~}~%" window mode kind)) - -;;; Mouse focus - -(defun focus-all (win) - "Focus the window, frame, group and screen belonging to WIN. Raise -the window in it's frame." - (when (and win (window-frame win)) - (unmap-message-window (window-screen win)) - (switch-to-screen (window-screen win)) - (let ((frame (window-frame win)) - (group (window-group win))) - (switch-to-group group) - (frame-raise-window group frame win)))) - -(define-stump-event-handler :enter-notify (window mode) - (when (and window (eq mode :normal) (eq *mouse-focus-policy* :sloppy)) - (let ((win (find-window window))) - (when (and win (find win (top-windows))) - (focus-all win))))) - -(define-stump-event-handler :button-press (window code x y child time) - ;; Pass click to client - (xlib:allow-events *display* :replay-pointer time) - (let (screen ml win) - (cond - ((and (setf screen (find-screen window)) (not child)) - (when (and (eq *mouse-focus-policy* :click) - *root-click-focuses-frame*) - (let* ((group (screen-current-group screen)) - (frame (find-frame group x y))) - (when frame - (focus-frame group frame)))) - (run-hook-with-args *root-click-hook* screen code x y)) - ((setf ml (find-mode-line-window window)) - (run-hook-with-args *mode-line-click-hook* ml code x y)) - ((setf win (find-window-by-parent window (visible-windows))) - (when (eq *mouse-focus-policy* :click) - (focus-all win)))))) - -;; Handling event :KEY-PRESS -;; (:DISPLAY #<XLIB:DISPLAY :0 (The X.Org Foundation R60700000)> :EVENT-KEY :KEY-PRESS :EVENT-CODE 2 :SEND-EVENT-P NIL :CODE 45 :SEQUENCE 1419 :TIME 98761213 :ROOT #<XLIB:WINDOW :0 96> :WINDOW #<XLIB:WINDOW :0 6291484> :EVENT-WINDOW #<XLIB:WINDOW :0 6291484> :CHILD -;; #<XLIB:WINDOW :0 6291485> :ROOT-X 754 :ROOT-Y 223 :X 753 :Y 222 :STATE 4 :SAME-SCREEN-P T) -;; H - -(defun handle-event (&rest event-slots &key display event-key &allow-other-keys) - (declare (ignore display)) - (dformat 1 ">>> ~S~%" event-key) - (let ((eventfn (gethash event-key *event-fn-table*))) - (when eventfn - (handler-case - (progn - ;; This is not the stumpwm top level, but if the restart - ;; is in the top level then it seems the event being - ;; processed isn't popped off the stack and is immediately - ;; reprocessed after restarting to the top level. So fake - ;; it, and put the restart here. - (with-simple-restart (top-level "Return to stumpwm's top level") - (apply eventfn event-slots)) - (xlib:display-finish-output *display*)) - ((or xlib:window-error xlib:drawable-error) (c) - ;; Asynchronous errors are handled in the error - ;; handler. Synchronous errors like trying to get the window - ;; hints on a deleted window are caught and ignored here. We - ;; do this inside the event handler so that the event is - ;; handled. If we catch it higher up the event will not be - ;; flushed from the queue and we'll get ourselves into an - ;; infinite loop. - (dformat 4 "ignore synchronous ~a~%" c)))) - (dformat 2 "<<< ~S~%" event-key) - t)) - -;;; Selection - -(defun export-selection () - (let* ((screen (current-screen)) - (selwin (screen-focus-window (current-screen))) - (root (screen-root screen))) - (xlib:set-selection-owner *display* :primary selwin) - (unless (eq (xlib:selection-owner *display* :primary) selwin) - (error "Can't set selection owner")) - ;; also set the cut buffer for completeness - (xlib:change-property root :cut-buffer0 *x-selection* :string 8 :transform #'xlib:char->card8 - :mode :replace))) - -(defun set-x-selection (text) - "Set the X11 selection string to @var{string}." - (setf *x-selection* text) - (export-selection)) - -(defun send-selection (requestor property selection target time) - (dformat 1 "send-selection ~s ~s ~s ~s ~s~%" requestor property selection target time) - (cond - ;; they're requesting what targets are available - ((eq target :targets) - (xlib:change-property requestor property (list :targets :string) target 8 :mode :replace)) - ;; send them a string - ((find target '(:string )) - (xlib:change-property requestor property *x-selection* :string 8 :mode :replace :transform #'xlib:char->card8)) - ;; we don't know how to handle anything else - (t - (setf property nil))) - (xlib:send-event requestor :selection-notify nil - :display *display* - :window requestor - :selection selection - :property property - :target target - :time time) - (xlib:display-finish-output *display*)) - -(defun get-x-selection (&optional timeout) - "Return the x selection no matter what client own it." - (labels ((wait-for-selection (&rest event-slots &key display event-key &allow-other-keys) - (declare (ignore display)) - (when (eq event-key :selection-notify) - (destructuring-bind (&key window property &allow-other-keys) event-slots - (if property - (xlib:get-property window property :type :string :result-type 'string :transform #'xlib:card8->char :delete-p t) - ""))))) - (if *x-selection* - *x-selection* - (progn - (xlib:convert-selection :primary :string (screen-input-window (current-screen)) :stumpwm-selection) - ;; Note: this may spend longer than timeout in this loop but it will eventually return. - (let ((time (get-internal-real-time))) - (loop for ret = (xlib:process-event *display* :handler #'wait-for-selection :timeout timeout :discard-p nil) - when (or ret - (> (/ (- time (get-internal-real-time)) internal-time-units-per-second) - timeout)) - ;; make sure we return a string - return (or ret ""))))))) - -;;; Top map push/popping - -(defvar *top-map-list* nil) - -(defun push-top-map (new-top) - (push *top-map* *top-map-list*) - (setf *top-map* new-top) - (sync-keys)) - -(defun pop-top-map () - (when *top-map-list* - (setf *top-map* (pop *top-map-list*)) - (sync-keys) - t)) - -(defmacro save-frame-excursion (&body body) - "Execute body and then restore the current frame." - (let ((oframe (gensym "OFRAME")) - (ogroup (gensym "OGROUP"))) - `(let ((,oframe (tile-group-current-frame (current-group))) - (,ogroup (current-group))) - (unwind-protect (progn ,@body) - (focus-frame ,ogroup ,oframe))))) - |