Fetching contributors…
Cannot retrieve contributors at this time
190 lines (175 sloc) 8.39 KB
;;; Window placement routines
(in-package :stumpwm)
(defun xwin-to-window (xwin)
"Build a window for XWIN"
(make-instance '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 (get-normalized-normal-hints xwin)
:state +iconic-state+
:plist (make-hash-table)
:unmap-ignores 0))
(defvar *rule-scanners-cache* (make-hash-table :test 'equal)
"A cache for the ppcre scanners")
(defun get-or-create-rule-scanner (regex)
(or (gethash regex *rule-scanners-cache*)
(setf (gethash regex *rule-scanners-cache*)
(ppcre:create-scanner regex))))
(defun string-match (string pat)
(ppcre:scan (get-or-create-rule-scanner pat) string))
(defun window-matches-properties-p (window &key class instance type role title)
"Returns T if window matches all the given properties"
(and
(if class (string-match (window-class window) class) t)
(if instance (string-match (window-res window) instance) t)
(if type (string-match (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
&key create restore class instance type role title) rule
(declare (ignore frame raise create restore))
(if (or lock
(equal group-name (group-name (or (when (slot-boundp w 'group)
(window-group w))
(current-group)))))
(window-matches-properties-p w :class class
:instance instance
:type type
:role role
:title title))))
(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
&key create restore class instance type role title) match
(declare (ignore lock class instance type role title))
(let ((group (find-group screen group-name)))
(cond (group
(when (and restore (stringp restore))
(let ((restore-file (data-dir-file restore)))
(if (probe-file restore-file)
(restore-group group
(read-dump-from-file restore-file))
(message "^B^1*Can't restore group \"^b~a^B\" with \"^b~a^B\"."
group-name restore-file))))
(values group (frame-by-number group frame) raise))
(create
(let ((new-group (add-group (current-screen) group-name))
(restore-file (if (stringp create)
(data-dir-file create)
(data-dir-file group-name))))
(if (and new-group
(probe-file restore-file))
(restore-group new-group
(read-dump-from-file restore-file))
(when (stringp create)
(message "^B^1*Can't restore group \"^b~a^B\" with \"^b~a^B\"."
group-name restore-file)))
(values new-group (frame-by-number new-group frame) raise)))
(t (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)
(with-current-screen screen
(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)))
(when frame
(unless (eq (window-frame window) frame)
(pull-window window frame)))))))
(defun assign-window (window group &optional (where :tail))
"Assign the window to the specified group and perform the necessary
housekeeping."
(setf (window-group window) group
(window-number window) (find-free-window-number group))
(if (eq where :head)
(push window (group-windows group))
(setf (group-windows group) (append (group-windows group) (list window))))
(setf (xwin-state (window-xwin window)) +iconic-state+)
(netwm-set-group window))
(defun place-window (screen window)
"Pick a group WINDOW and return the group-specific placement hints, if any."
(let* ((netwm-group (netwm-group window screen))
(placement (multiple-value-list (get-window-placement screen window)))
(placement-group (first placement))
(group (or (when *processing-existing-windows*
netwm-group)
placement-group
netwm-group
(screen-current-group screen))))
(assign-window window group (if *processing-existing-windows* :head :tail))
;; if we're using the placement group, then return the extra data.
(when (eq group placement-group)
(list :frame (second placement)
:raise (third placement)))))
(defun pick-preferred-frame (window)
(let* ((group (window-group window))
(frames (group-frames group))
(default (tile-group-current-frame group))
(preferred-frame (or *new-window-preferred-frame* default)))
(when (or (functionp *new-window-preferred-frame*)
(and (symbolp *new-window-preferred-frame*)
(fboundp *new-window-preferred-frame*)))
(setq preferred-frame
(handler-case
(funcall *new-window-preferred-frame* window)
(t (c)
(message "^1*^BError while calling ^b^3**new-window-preferred-frame*^1*^B: ^n~a" c)
default))))
(cond
;; If we already have a frame use it.
((frame-p preferred-frame)
preferred-frame)
;; If `preferred-frame' is a list of keyword use it to determine the
;; frame. The sanity check doesn't cover not recognized keywords. We
;; simply fall back to the default then.
((and (listp preferred-frame)
(every #'keywordp preferred-frame))
(or
(loop for i in preferred-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))))))))
default))
;; Not well formed `*new-window-preferred-frame*'. Message an error and
;; return the default.
(t (message "^1*^BInvalid ^b^3**new-window-preferred-frame*^1*^B: ^n~a"
preferred-frame)
default))))