1 ;;; --------------------------------------------------------------------------
2 ;;; CLFSWM - FullScreen Window Manager
4 ;;; --------------------------------------------------------------------------
5 ;;; Documentation: Utility
6 ;;; --------------------------------------------------------------------------
8 ;;; (C) 2012 Philippe Brochard <pbrochard@common-lisp.net>
10 ;;; This program is free software; you can redistribute it and/or modify
11 ;;; it under the terms of the GNU General Public License as published by
12 ;;; the Free Software Foundation; either version 3 of the License, or
13 ;;; (at your option) any later version.
15 ;;; This program is distributed in the hope that it will be useful,
16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;;; GNU General Public License for more details.
20 ;;; You should have received a copy of the GNU General Public License
21 ;;; along with this program; if not, write to the Free Software
22 ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
24 ;;; --------------------------------------------------------------------------
29 ;;; Configuration file
30 (defun xdg-config-home ()
31 (aif (getenv "XDG_CONFIG_HOME")
32 (pathname-directory (concatenate 'string it
"/"))
33 (append (pathname-directory (user-homedir-pathname)) '(".config"))))
36 (let ((saved-conf-name nil
))
37 (defun conf-file-name (&optional alternate-name
)
38 (unless (and saved-conf-name
(not alternate-name
))
39 (let* ((user-conf (probe-file (merge-pathnames (user-homedir-pathname) #p
".clfswmrc")))
40 (etc-conf (probe-file #p
"/etc/clfswmrc"))
41 (config-user-conf (probe-file (make-pathname :directory
(append (xdg-config-home) '("clfswm"))
43 (alternate-conf (and alternate-name
(probe-file alternate-name
))))
44 (setf saved-conf-name
(or alternate-conf config-user-conf user-conf etc-conf
))))
45 (print saved-conf-name
)
51 (defun load-contrib (file)
52 "Load a file in the contrib directory"
53 (let ((truename (merge-pathnames file
*contrib-dir
*)))
54 (format t
"Loading contribution file: ~A~%" truename
)
55 (if (probe-file truename
)
56 (load truename
:verbose nil
)
57 (format t
" File not found!~%"))))
60 (defun reload-clfswm ()
62 (format t
"~&-*- Reloading CLFSWM -*-~%")
63 (asdf:oos
'asdf
:load-op
:clfswm
)
68 ;;;----------------------------
70 ;;;----------------------------
73 (defun build-lisp-image (dump-name)
74 #+:CLISP
(ext:saveinitmem dump-name
:init-function
(lambda () (clfswm:main
) (ext:quit
)) :executable t
)
75 #+:SBCL
(sb-ext:save-lisp-and-die dump-name
:toplevel
'clfswm
:main
:executable t
)
76 #+:CMU
(ext:save-lisp dump-name
:init-function
(lambda () (clfswm:main
) (ext:quit
)) :executable t
)
77 #+:CCL
(ccl:save-application dump-name
:toplevel-function
(lambda () (clfswm:main
) (ccl:quit
)) :prepend-kernel t
)
78 #+:ECL
(c:build-program dump-name
:epilogue-code
'(clfswm:main
)))
83 (defun query-yes-or-no (formatter &rest args
)
84 (let ((rep (query-string (apply #'format nil formatter args
) "" '("Yes" "No"))))
86 (char= (char rep
0) #\y
)
87 (char= (char rep
0) #\Y
))))
91 (defun banish-pointer ()
92 "Move the pointer to the lower right corner of the screen"
93 (with-placement (*banish-pointer-placement
* x y
)
94 (xlib:warp-pointer
*root
* x y
)))
99 ;;; Root functions utility
100 (defun show-current-root ()
101 (when *have-to-show-current-root
*
102 (let ((*notify-window-placement
* *show-current-root-placement
*))
103 (notify-message *show-current-root-delay
* *show-current-root-message
*))))
105 (defun select-generic-root (fun restart-menu
)
107 (let* ((current-root (find-root (current-child)))
108 (parent (find-parent-frame (root-original current-root
))))
110 (setf (frame-child parent
) (funcall fun
(frame-child parent
)))
111 (let ((new-root (find-root (frame-selected-child parent
))))
112 (setf (current-child) (aif (root-current-child new-root
)
114 (frame-selected-child parent
))))))
115 (show-all-children t
)
118 (open-menu (find-menu 'root-menu
))
119 (leave-second-mode)))
121 (defun select-next-root ()
122 "Select the next root"
123 (select-generic-root #'rotate-list nil
))
125 (defun select-previous-root ()
126 "Select the previous root"
127 (select-generic-root #'anti-rotate-list nil
))
130 (defun select-next-root-restart-menu ()
131 "Select the next root"
132 (select-generic-root #'rotate-list t
))
134 (defun select-previous-root-restart-menu ()
135 "Select the previous root"
136 (select-generic-root #'anti-rotate-list t
))
139 (defun rotate-root-geometry-generic (fun restart-menu
)
142 (show-all-children t
)
145 (open-menu (find-menu 'root-menu
))
146 (leave-second-mode)))
149 (defun rotate-root-geometry-next ()
150 "Rotate root geometry to next root"
151 (rotate-root-geometry-generic #'rotate-root-geometry nil
))
153 (defun rotate-root-geometry-previous ()
154 "Rotate root geometry to previous root"
155 (rotate-root-geometry-generic #'anti-rotate-root-geometry nil
))
157 (defun rotate-root-geometry-next-restart-menu ()
158 "Rotate root geometry to next root"
159 (rotate-root-geometry-generic #'rotate-root-geometry t
))
161 (defun rotate-root-geometry-previous-restart-menu ()
162 "Rotate root geometry to previous root"
163 (rotate-root-geometry-generic #'anti-rotate-root-geometry t
))
167 (defun exchange-root-geometry-with-mouse ()
168 "Exchange two root geometry pointed with the mouse"
169 (open-notify-window '("Select the first root to exchange"))
170 (wait-no-key-or-button-press)
171 (wait-mouse-button-release)
172 (close-notify-window)
173 (multiple-value-bind (x1 y1
) (xlib:query-pointer
*root
*)
174 (open-notify-window '("Select the second root to exchange"))
175 (wait-no-key-or-button-press)
176 (wait-mouse-button-release)
177 (close-notify-window)
178 (multiple-value-bind (x2 y2
) (xlib:query-pointer
*root
*)
179 (exchange-root-geometry (find-root-by-coordinates x1 y1
)
180 (find-root-by-coordinates x2 y2
))))
185 (defun change-current-root-geometry ()
186 "Change the current root geometry"
187 (let* ((root (find-root (current-child)))
188 (x (query-number "New root X position" (root-x root
)))
189 (y (query-number "New root Y position" (root-y root
)))
190 (w (query-number "New root width" (root-w root
)))
191 (h (query-number "New root height" (root-h root
))))
192 (setf (root-x root
) x
(root-y root
) y
193 (root-w root
) w
(root-h root
) h
)
196 (leave-second-mode)))
200 (defun display-all-frame-info ()
201 (with-all-frames (*root-frame
* frame
)
202 (display-frame-info frame
)))
204 (defun display-all-root-frame-info ()
205 (with-all-root-child (root)
206 (display-frame-info root
)))
210 (defun place-window-from-hints (window)
211 "Place a window from its hints"
212 (let* ((hints (xlib:wm-normal-hints window
))
213 (min-width (or (and hints
(xlib:wm-size-hints-min-width hints
)) 0))
214 (min-height (or (and hints
(xlib:wm-size-hints-min-height hints
)) 0))
215 (max-width (or (and hints
(xlib:wm-size-hints-max-width hints
)) (x-drawable-width *root
*)))
216 (max-height (or (and hints
(xlib:wm-size-hints-max-height hints
)) (x-drawable-height *root
*)))
217 (rwidth (or (and hints
(or (xlib:wm-size-hints-width hints
) (xlib:wm-size-hints-base-width hints
)))
218 (x-drawable-width window
)))
219 (rheight (or (and hints
(or (xlib:wm-size-hints-height hints
) (xlib:wm-size-hints-base-height hints
)))
220 (x-drawable-height window
))))
221 (setf (x-drawable-width window
) (min (max min-width rwidth
*default-window-width
*) max-width
)
222 (x-drawable-height window
) (min (max min-height rheight
*default-window-height
*) max-height
))
223 (with-placement (*unmanaged-window-placement
* x y
(x-drawable-width window
) (x-drawable-height window
))
224 (setf (x-drawable-x window
) x
225 (x-drawable-y window
) y
))
226 (xlib:display-finish-output
*display
*)))
229 (defun rename-current-child ()
230 "Rename the current child"
231 (let ((name (query-string (format nil
"New child name: (last: ~A)" (child-name (current-child)))
232 (child-name (current-child)))))
233 (rename-child (current-child) name
)
234 (leave-second-mode)))
237 (defun ask-child-transparency (msg child
)
238 (let ((trans (query-number (format nil
"New ~A transparency: (last: ~A)"
240 (* 100 (child-transparency child
)))
241 (* 100 (child-transparency child
)))))
242 (when (numberp trans
)
243 (setf (child-transparency child
) (float (/ trans
100))))))
245 (defun set-current-child-transparency ()
246 "Set the current child transparency"
247 (ask-child-transparency "child" (current-child))
251 (defun ask-child-border-size (msg child
)
252 (let ((size (query-number (format nil
"New ~A border size: (last: ~A)"
254 (child-border-size child
))
255 (child-border-size child
))))
257 (setf (child-border-size child
) size
))))
260 (defun set-current-child-border-size ()
261 "Set the current child border size"
262 (ask-child-border-size "child" (current-child))
266 (defun renumber-current-frame ()
267 "Renumber the current frame"
268 (when (frame-p (current-child))
269 (let ((number (query-number (format nil
"New child number: (last: ~A)" (frame-number (current-child)))
270 (frame-number (current-child)))))
271 (setf (frame-number (current-child)) number
)
272 (leave-second-mode))))
277 (defun add-default-frame ()
278 "Add a default frame in the current frame"
279 (when (frame-p (current-child))
280 (let ((name (query-string "Frame name")))
281 (push (create-frame :name name
) (frame-child (current-child)))))
284 (defun add-frame-in-parent-frame ()
285 "Add a frame in the parent frame (and reorganize parent frame)"
286 (let ((parent (find-parent-frame (current-child))))
287 (when (and parent
(not (child-original-root-p (current-child))))
288 (let ((new-frame (create-frame)))
289 (pushnew new-frame
(frame-child parent
))
290 (awhen (child-root-p (current-child))
291 (change-root it parent
))
292 (setf (current-child) parent
)
293 (set-layout-once #'tile-space-layout
)
294 (setf (current-child) new-frame
)
295 (leave-second-mode)))))
300 (defun add-placed-frame ()
301 "Add a placed frame in the current frame"
302 (when (frame-p (current-child))
303 (let ((name (query-string "Frame name"))
304 (x (/ (query-number "Frame x in percent (%)") 100))
305 (y (/ (query-number "Frame y in percent (%)") 100))
306 (w (/ (query-number "Frame width in percent (%)" 100) 100))
307 (h (/ (query-number "Frame height in percent (%)" 100) 100)))
308 (push (create-frame :name name
:x x
:y y
:w w
:h h
)
309 (frame-child (current-child)))))
314 (defun delete-focus-window-generic (close-fun)
315 (with-focus-window (window)
316 (when (child-equal-p window
(current-child))
317 (setf (current-child) (find-current-root)))
318 (delete-child-and-children-in-all-frames window close-fun
)))
321 (defun delete-focus-window ()
322 "Close focus window: Delete the focus window in all frames and workspaces"
323 (delete-focus-window-generic 'delete-window
))
325 (defun destroy-focus-window ()
326 "Kill focus window: Destroy the focus window in all frames and workspaces"
327 (delete-focus-window-generic 'destroy-window
))
329 (defun remove-focus-window ()
330 "Remove the focus window from the current frame"
331 (with-focus-window (window)
332 (setf (current-child) (find-current-root))
334 (remove-child-in-frame window
(find-parent-frame window
))
335 (show-all-children)))
338 (defun unhide-all-windows-in-current-child ()
339 "Unhide all hidden windows into the current child"
340 (dolist (window (get-hidden-windows))
341 (unhide-window window
)
342 (process-new-window window
)
349 (defun find-window-under-mouse (x y
)
350 "Return the child window under the mouse"
352 (with-all-root-child (root)
353 (with-all-windows-frames-and-parent (root child parent
)
354 (when (and (or (managed-window-p child parent
) (child-equal-p parent
(current-child)))
355 (not (window-hidden-p child
))
356 (in-window child x y
))
358 (when (in-frame child x y
)
359 (setf win
(frame-window child
)))))
365 (defun find-child-under-mouse-in-never-managed-windows (x y
)
366 "Return the child under mouse from never managed windows"
368 (dolist (win (xlib:query-tree
*root
*))
369 (unless (window-hidden-p win
)
370 (multiple-value-bind (never-managed raise
)
371 (never-managed-window-p win
)
372 (when (and never-managed raise
(in-window win x y
))
377 (defun find-child-under-mouse-in-child-tree (x y
&optional first-foundp
)
378 "Return the child under the mouse"
380 (with-all-root-child (root)
381 (with-all-windows-frames (root child
)
382 (when (and (not (window-hidden-p child
))
383 (in-window child x y
))
385 (return-from find-child-under-mouse-in-child-tree child
)
387 (when (in-frame child x y
)
389 (return-from find-child-under-mouse-in-child-tree child
)
395 (defun find-child-under-mouse (x y
&optional first-foundp also-never-managed
)
396 "Return the child under the mouse"
397 (or (and also-never-managed
398 (find-child-under-mouse-in-never-managed-windows x y
))
399 (find-child-under-mouse-in-child-tree x y first-foundp
)))
405 ;;; Selection functions
406 (defun clear-selection ()
407 "Clear the current selection"
408 (setf *child-selection
* nil
)
409 (display-all-root-frame-info))
411 (defun copy-current-child ()
412 "Copy the current child to the selection"
413 (pushnew (current-child) *child-selection
*)
414 (display-all-root-frame-info))
417 (defun cut-current-child (&optional
(show-now t
))
418 "Cut the current child to the selection"
419 (unless (child-root-p (current-child))
420 (let ((parent (find-parent-frame (current-child))))
421 (hide-all (current-child))
423 (remove-child-in-frame (current-child) (find-parent-frame (current-child) (find-current-root)))
425 (setf (current-child) parent
))
427 (show-all-children t
))
430 (defun remove-current-child ()
431 "Remove the current child from its parent frame"
432 (unless (child-root-p (current-child))
433 (let ((parent (find-parent-frame (current-child))))
434 (hide-all (current-child))
435 (remove-child-in-frame (current-child) (find-parent-frame (current-child) (find-current-root)))
437 (setf (current-child) parent
))
438 (show-all-children t
)
439 (leave-second-mode))))
441 (defun delete-current-child ()
442 "Delete the current child and its children in all frames"
443 (unless (child-root-p (current-child))
444 (hide-all (current-child))
445 (delete-child-and-children-in-all-frames (current-child))
446 (show-all-children t
)
447 (leave-second-mode)))
450 (defun paste-selection-no-clear ()
451 "Paste the selection in the current frame - Do not clear the selection after paste"
452 (when (frame-p (current-child))
453 (dolist (child *child-selection
*)
454 (unless (find-child-in-parent child
(current-child))
455 (pushnew child
(frame-child (current-child)) :test
#'child-equal-p
)))
456 (show-all-children)))
458 (defun paste-selection ()
459 "Paste the selection in the current frame"
460 (when (frame-p (current-child))
461 (paste-selection-no-clear)
462 (setf *child-selection
* nil
)
463 (display-all-root-frame-info)))
466 (defun copy-focus-window ()
467 "Copy the focus window to the selection"
468 (with-focus-window (window)
469 (with-current-child (window)
470 (copy-current-child))))
473 (defun cut-focus-window ()
474 "Cut the focus window to the selection"
475 (with-focus-window (window)
476 (setf (current-child) (with-current-child (window)
477 (cut-current-child nil
)))
478 (show-all-children t
)))
485 ;;; Maximize function
486 (defun frame-toggle-maximize ()
487 "Maximize/Unmaximize the current frame in its parent frame"
488 (when (frame-p (current-child))
489 (let ((unmaximized-coords (frame-data-slot (current-child) :unmaximized-coords
)))
490 (if unmaximized-coords
491 (with-slots (x y w h
) (current-child)
492 (destructuring-bind (nx ny nw nh
) unmaximized-coords
493 (setf (frame-data-slot (current-child) :unmaximized-coords
) nil
494 x nx y ny w nw h nh
)))
495 (with-slots (x y w h
) (current-child)
496 (setf (frame-data-slot (current-child) :unmaximized-coords
)
500 (leave-second-mode)))
510 ;;; CONFIG - Identify mode
511 (defun identify-key ()
514 (font (xlib:open-font
*display
* *identify-font-string
*))
515 (window (xlib:create-window
:parent
*root
*
517 :width
(- (xlib:screen-width
*screen
*) (* *border-size
* 2))
518 :height
(* 5 (+ (xlib:max-char-ascent font
) (xlib:max-char-descent font
)))
519 :background
(get-color *identify-background
*)
520 :border-width
*border-size
*
521 :border
(get-color *identify-border
*)
522 :colormap
(xlib:screen-default-colormap
*screen
*)
523 :event-mask
'(:exposure
)))
524 (gc (xlib:create-gcontext
:drawable window
525 :foreground
(get-color *identify-foreground
*)
526 :background
(get-color *identify-background
*)
528 :line-style
:solid
)))
529 (setf (window-transparency window
) *identify-transparency
*)
530 (labels ((print-doc (msg hash-table-key pos code state
)
531 (let ((function (find-key-from-code hash-table-key code state
)))
532 (when (and function
(fboundp (first function
)))
533 (xlib:draw-glyphs
*pixmap-buffer
* gc
10 (+ (* pos
(+ (xlib:max-char-ascent font
) (xlib:max-char-descent font
))) 5)
534 (format nil
"~A ~A" msg
(documentation (first function
) 'function
))))))
535 (print-key (code state keysym key modifiers
)
536 (clear-pixmap-buffer window gc
)
537 (setf (xlib:gcontext-foreground gc
) (get-color *identify-foreground
*))
538 (xlib:draw-glyphs
*pixmap-buffer
* gc
5 (+ (xlib:max-char-ascent font
) 5)
539 (format nil
"Press a key to identify. Press 'q' to stop the identify loop."))
541 (xlib:draw-glyphs
*pixmap-buffer
* gc
10 (+ (* 2 (+ (xlib:max-char-ascent font
) (xlib:max-char-descent font
))) 5)
542 (format nil
"Code=~A KeySym=~S Key=~S Modifiers=~A"
543 code keysym key modifiers
))
544 (print-doc "Main mode : " *main-keys
* 3 code state
)
545 (print-doc "Second mode: " *second-keys
* 4 code state
))
546 (copy-pixmap-buffer window gc
))
547 (handle-identify-key (&rest event-slots
&key root code state
&allow-other-keys
)
548 (declare (ignore event-slots root
))
549 (let* ((modifiers (state->modifiers state
))
550 (key (keycode->char code state
))
551 (keysym (keysym->keysym-name
(keycode->keysym code modifiers
))))
552 (setf done
(and (equal key
#\q
) (equal modifiers
*default-modifiers
*)))
553 (dbg code keysym key modifiers
)
554 (print-key code state keysym key modifiers
)
556 (handle-identify (&rest event-slots
&key display event-key
&allow-other-keys
)
557 (declare (ignore display
))
559 (:key-press
(apply #'handle-identify-key event-slots
) t
)
560 (:exposure
(print-key nil nil nil nil nil
)))
562 (xgrab-pointer *root
* 92 93)
564 (format t
"~&Press 'q' to stop the identify loop~%")
565 (print-key nil nil nil nil nil
)
569 (with-xlib-protect (:Identify-Loop nil
)
570 (when (xlib:event-listen
*display
* *loop-timeout
*)
571 (xlib:process-event
*display
* :handler
#'handle-identify
))
572 (xlib:display-finish-output
*display
*)))
574 (xlib:destroy-window window
)
575 (xlib:close-font font
)
576 (xgrab-pointer *root
* 66 67))))))
583 (let ((all-symbols (collect-all-symbols)))
584 (defun eval-from-query-string ()
585 "Eval a lisp form from the query input"
586 (let ((form (query-string (format nil
"Eval Lisp <~A> " (package-name *package
*))
589 (when (and form
(not (equal form
"")))
590 (let ((printed-result
591 (with-output-to-string (*standard-output
*)
592 (setf result
(handler-case
593 (loop for i in
(multiple-value-list
594 (eval (read-from-string form
)))
595 collect
(format nil
"~S" i
))
597 (format nil
"~A" condition
)))))))
598 (let ((ret (info-mode (expand-newline (append (ensure-list (format nil
"> ~A" form
))
599 (ensure-list printed-result
)
600 (ensure-list result
)))
601 :width
(- (xlib:screen-width
*screen
*) 2))))
602 (when (or (search "defparameter" form
:test
#'string-equal
)
603 (search "defvar" form
:test
#'string-equal
))
604 (let ((elem (split-string form
)))
605 (pushnew (string-downcase (if (string= (first elem
) "(") (third elem
) (second elem
)))
606 all-symbols
:test
#'string
=)))
607 (when (search "in-package" form
:test
#'string-equal
)
608 (let ((*notify-window-placement
* 'middle-middle-root-placement
))
609 (open-notify-window '("Collecting all symbols for Lisp REPL completion."))
610 (setf all-symbols
(collect-all-symbols))
611 (close-notify-window)))
613 (eval-from-query-string))))))))
619 (let ((commands (command-in-path)))
620 (defun run-program-from-query-string ()
621 "Run a program from the query input"
622 (labels ((run-program-from-query-string-fun ()
623 (multiple-value-bind (program return
)
624 (query-string "Run:" "" commands
)
625 (when (and (equal return
:return
) program
(not (equal program
"")))
626 (let ((cmd (concatenate 'string
"cd $HOME && exec " program
)))
629 (let ((fun (run-program-from-query-string-fun)))
633 (setf *second-mode-leave-function
* fun
)
641 ;;; Frame name actions
642 (defun ask-frame-name (msg)
644 (let ((all-frame-name nil
))
645 (with-all-frames (*root-frame
* frame
)
646 (awhen (frame-name frame
) (push it all-frame-name
)))
647 (query-string msg
"" all-frame-name
)))
650 ;;; Focus by functions
651 (defun focus-frame-by (frame)
652 (when (frame-p frame
)
653 (focus-all-children frame
(or (find-parent-frame frame
(find-current-root))
654 (find-parent-frame frame
)
656 (show-all-children t
)))
659 (defun focus-frame-by-name ()
660 "Focus a frame by name"
661 (focus-frame-by (find-frame-by-name (ask-frame-name "Focus frame:")))
664 (defun focus-frame-by-number ()
665 "Focus a frame by number"
666 (focus-frame-by (find-frame-by-number (query-number "Focus frame by number:")))
670 ;;; Open by functions
671 (defun open-frame-by (frame)
672 (when (frame-p frame
)
673 (push (create-frame :name
(query-string "Frame name")) (frame-child frame
))
674 (show-all-children)))
678 (defun open-frame-by-name ()
679 "Open a new frame in a named frame"
680 (open-frame-by (find-frame-by-name (ask-frame-name "Open a new frame in: ")))
683 (defun open-frame-by-number ()
684 "Open a new frame in a numbered frame"
685 (open-frame-by (find-frame-by-number (query-number "Open a new frame in the group numbered:")))
689 ;;; Delete by functions
690 (defun delete-frame-by (frame)
691 (unless (or (child-equal-p frame
*root-frame
*)
692 (child-root-p frame
))
693 (when (child-equal-p frame
(current-child))
694 (setf (current-child) (find-current-root)))
695 (remove-child-in-frame frame
(find-parent-frame frame
)))
696 (show-all-children t
))
699 (defun delete-frame-by-name ()
700 "Delete a frame by name"
701 (delete-frame-by (find-frame-by-name (ask-frame-name "Delete frame: ")))
704 (defun delete-frame-by-number ()
705 "Delete a frame by number"
706 (delete-frame-by (find-frame-by-number (query-number "Delete frame by number:")))
711 (defun move-child-to (child frame-dest
)
712 (when (and child
(frame-p frame-dest
))
713 (remove-child-in-frame child
(find-parent-frame child
))
714 (pushnew child
(frame-child frame-dest
))
715 (focus-all-children child frame-dest
)
716 (show-all-children t
)))
718 (defun move-current-child-by-name ()
719 "Move current child in a named frame"
720 (move-child-to (current-child)
722 (ask-frame-name (format nil
"Move '~A' to frame: " (child-name (current-child))))))
725 (defun move-current-child-by-number ()
726 "Move current child in a numbered frame"
727 (move-child-to (current-child)
728 (find-frame-by-number
729 (query-number (format nil
"Move '~A' to frame numbered:" (child-name (current-child))))))
734 (defun copy-child-to (child frame-dest
)
735 (when (and child
(frame-p frame-dest
))
736 (pushnew child
(frame-child frame-dest
))
737 (focus-all-children child frame-dest
)
738 (show-all-children t
)))
740 (defun copy-current-child-by-name ()
741 "Copy current child in a named frame"
742 (copy-child-to (current-child)
744 (ask-frame-name (format nil
"Copy '~A' to frame: " (child-name (current-child))))))
747 (defun copy-current-child-by-number ()
748 "Copy current child in a numbered frame"
749 (copy-child-to (current-child)
750 (find-frame-by-number
751 (query-number (format nil
"Copy '~A' to frame numbered:" (child-name (current-child))))))
758 (defun show-all-frames-info ()
759 "Show all frames info windows"
760 (let ((*show-root-frame-p
* t
))
762 (with-all-root-child (root)
763 (with-all-frames (root frame
)
764 (raise-window (frame-window frame
))
765 (display-frame-info frame
)))))
767 (defun hide-all-frames-info ()
768 "Hide all frames info windows"
771 (defun show-all-frames-info-key ()
772 "Show all frames info windows until a key is release"
773 (show-all-frames-info)
774 (wait-no-key-or-button-press)
775 (hide-all-frames-info))
778 (defun move-frame (frame parent orig-x orig-y
)
779 (when (and frame parent
(not (child-root-p frame
)))
780 (hide-all-children frame
)
781 (with-slots (window) frame
782 (move-window window orig-x orig-y
#'display-frame-info
(list frame
))
783 (setf (frame-x frame
) (x-px->fl
(x-drawable-x window
) parent
)
784 (frame-y frame
) (y-px->fl
(x-drawable-y window
) parent
)))
785 (show-all-children)))
787 (defun resize-frame (frame parent orig-x orig-y
)
788 (when (and frame parent
(not (child-root-p frame
)))
789 (hide-all-children frame
)
790 (with-slots (window) frame
791 (resize-window window orig-x orig-y
#'display-frame-info
(list frame
))
792 (setf (frame-w frame
) (w-px->fl
(anti-adj-border-wh (x-drawable-width window
) frame
) parent
)
793 (frame-h frame
) (h-px->fl
(anti-adj-border-wh (x-drawable-height window
) frame
) parent
)))
794 (show-all-children)))
798 (defun mouse-click-to-focus-generic (root-x root-y mouse-fn
)
799 "Focus the current frame or focus the current window parent
800 mouse-fun is #'move-frame or #'resize-frame"
802 (child (find-child-under-mouse root-x root-y
))
803 (parent (find-parent-frame child
))
804 (root-p (child-root-p child
)))
805 (labels ((add-new-frame ()
806 (when (frame-p child
)
809 mouse-fn
#'resize-frame
810 (current-child) child
)
811 (place-frame child parent root-x root-y
10 10)
812 (map-window (frame-window child
))
813 (pushnew child
(frame-child parent
)))))
814 (when (and root-p
*create-frame-on-root
*)
816 (when (and (frame-p child
) (not (child-root-p child
)))
817 (funcall mouse-fn child parent root-x root-y
))
818 (when (and child parent
819 (focus-all-children child parent
(not (child-root-p child
))))
820 (when (show-all-children)
821 (setf to-replay nil
)))
823 (replay-button-event)
824 (stop-button-event)))))
827 (defun mouse-click-to-focus-and-move (window root-x root-y
)
828 "Move and focus the current frame or focus the current window parent.
829 Or do actions on corners"
830 (declare (ignore window
))
831 (or (do-corner-action root-x root-y
*corner-main-mode-left-button
*)
832 (mouse-click-to-focus-generic root-x root-y
#'move-frame
)))
834 (defun mouse-click-to-focus-and-resize (window root-x root-y
)
835 "Resize and focus the current frame or focus the current window parent.
836 Or do actions on corners"
837 (declare (ignore window
))
838 (or (do-corner-action root-x root-y
*corner-main-mode-right-button
*)
839 (mouse-click-to-focus-generic root-x root-y
#'resize-frame
)))
841 (defun mouse-middle-click (window root-x root-y
)
842 "Do actions on corners"
843 (declare (ignore window
))
844 (or (do-corner-action root-x root-y
*corner-main-mode-middle-button
*)
845 (replay-button-event)))
850 (defun mouse-focus-move/resize-generic
(root-x root-y mouse-fn window-parent
)
851 "Focus the current frame or focus the current window parent
852 mouse-fun is #'move-frame or #'resize-frame.
853 Focus child and its parents -
854 For window: set current child to window or its parent according to window-parent"
855 (labels ((move/resize-managed
(child)
856 (let ((parent (find-parent-frame child
)))
859 (child-root-p child
))
862 mouse-fn
#'resize-frame
)
863 (place-frame child parent root-x root-y
10 10)
864 (map-window (frame-window child
))
865 (push child
(frame-child parent
)))
866 (focus-all-children child parent window-parent
)
870 (if (managed-window-p child parent
)
871 (funcall mouse-fn parent
(find-parent-frame parent
) root-x root-y
)
872 (funcall (cond ((or (eql mouse-fn
#'move-frame
)
873 (eql mouse-fn
#'move-frame-constrained
))
875 ((or (eql mouse-fn
#'resize-frame
)
876 (eql mouse-fn
#'resize-frame-constrained
))
878 child root-x root-y
)))
879 (frame (funcall mouse-fn child parent root-x root-y
)))
880 (show-all-children)))
881 (move/resize-never-managed
(child raise-fun
)
882 (funcall raise-fun child
)
883 (funcall (cond ((eql mouse-fn
#'move-frame
) #'move-window
)
884 ((eql mouse-fn
#'resize-frame
) #'resize-window
))
885 child root-x root-y
)))
886 (let ((child (find-child-under-mouse root-x root-y nil t
)))
887 (multiple-value-bind (never-managed raise-fun
)
888 (never-managed-window-p child
)
889 (if (and (xlib:window-p child
) never-managed raise-fun
)
890 (move/resize-never-managed child raise-fun
)
891 (move/resize-managed child
))))))
894 (defun test-mouse-binding (window root-x root-y
)
895 (dbg window root-x root-y
)
896 (replay-button-event))
900 (defun mouse-select-next-level (window root-x root-y
)
901 "Select the next level in frame"
902 (declare (ignore root-x root-y
))
903 (let ((frame (find-frame-window window
)))
904 (when (or frame
(xlib:window-equal window
*root
*))
906 (replay-button-event)))
910 (defun mouse-select-previous-level (window root-x root-y
)
911 "Select the previous level in frame"
912 (declare (ignore root-x root-y
))
913 (let ((frame (find-frame-window window
)))
914 (when (or frame
(xlib:window-equal window
*root
*))
915 (select-previous-level))
916 (replay-button-event)))
920 (defun mouse-enter-frame (window root-x root-y
)
921 "Enter in the selected frame - ie make it the root frame"
922 (declare (ignore root-x root-y
))
923 (let ((frame (find-frame-window window
)))
924 (when (or frame
(xlib:window-equal window
*root
*))
926 (replay-button-event)))
930 (defun mouse-leave-frame (window root-x root-y
)
931 "Leave the selected frame - ie make its parent the root frame"
932 (declare (ignore root-x root-y
))
933 (let ((frame (find-frame-window window
)))
934 (when (or frame
(xlib:window-equal window
*root
*))
936 (replay-button-event)))
941 ;;;;;| Various definitions
944 (defun show-help (&optional
(browser "dillo") (tempfile "/tmp/clfswm.html"))
945 "Show current keys and buttons bindings"
947 (produce-doc-html-in-file tempfile
))
949 (do-shell (format nil
"~A ~A" browser tempfile
)))
953 ;;; Bind or jump functions
954 (let ((key-slots (make-array 10 :initial-element nil
))
956 (defun reset-bind-or-jump-slots ()
958 (setf (aref key-slots i
) nil
)))
960 (defun bind-on-slot (&optional
(slot current-slot
) child
)
961 "Bind current child to slot"
962 (setf (aref key-slots slot
) (if child child
(current-child))))
964 (defun remove-binding-on-slot ()
965 "Remove binding on slot"
966 (setf (aref key-slots current-slot
) nil
))
968 (defun jump-to-slot ()
970 (let ((jump-child (aref key-slots current-slot
)))
971 (when (and jump-child
(find-child jump-child
*root-frame
*))
972 (unless (find-child-in-all-root jump-child
)
973 (change-root (find-root jump-child
) jump-child
))
974 (setf (current-child) jump-child
)
975 (focus-all-children jump-child jump-child
)
976 (show-all-children t
))))
978 (defun bind-or-jump (n)
979 "Bind or jump to a slot (a frame or a window)"
980 (setf current-slot
(- n
1))
981 (let ((default-bind `("b" bind-on-slot
982 ,(format nil
"Bind slot ~A on child: ~A" n
(child-fullname (current-child))))))
983 (info-mode-menu (aif (aref key-slots current-slot
)
985 ("BackSpace" remove-binding-on-slot
986 ,(format nil
"Remove slot ~A binding on child: ~A" n
(child-fullname (current-child))))
989 ,(format nil
"Jump to child: ~A" (aif (aref key-slots current-slot
)
991 "Not set - Please, bind it with 'b'")))
992 ("Return" jump-to-slot
"Same thing")
993 ("space" jump-to-slot
"Same thing"))
994 (list default-bind
))))))
998 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
999 ;;; Useful function for the second mode ;;;
1000 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1001 (defmacro with-movement
(&body body
)
1002 `(when (frame-p (current-child))
1007 (display-all-frame-info)
1008 (draw-second-mode-window)
1009 (open-menu (find-menu 'frame-movement-menu
)))))
1013 (defun current-frame-pack-up ()
1014 "Pack the current frame up"
1015 (with-movement (pack-frame-up (current-child) (find-parent-frame (current-child) (find-current-root)))))
1017 (defun current-frame-pack-down ()
1018 "Pack the current frame down"
1019 (with-movement (pack-frame-down (current-child) (find-parent-frame (current-child) (find-current-root)))))
1021 (defun current-frame-pack-left ()
1022 "Pack the current frame left"
1023 (with-movement (pack-frame-left (current-child) (find-parent-frame (current-child) (find-current-root)))))
1025 (defun current-frame-pack-right ()
1026 "Pack the current frame right"
1027 (with-movement (pack-frame-right (current-child) (find-parent-frame (current-child) (find-current-root)))))
1030 (defun center-current-frame ()
1031 "Center the current frame"
1032 (with-movement (center-frame (current-child))))
1035 (defun current-frame-fill-up ()
1036 "Fill the current frame up"
1037 (with-movement (fill-frame-up (current-child) (find-parent-frame (current-child) (find-current-root)))))
1039 (defun current-frame-fill-down ()
1040 "Fill the current frame down"
1041 (with-movement (fill-frame-down (current-child) (find-parent-frame (current-child) (find-current-root)))))
1043 (defun current-frame-fill-left ()
1044 "Fill the current frame left"
1045 (with-movement (fill-frame-left (current-child) (find-parent-frame (current-child) (find-current-root)))))
1047 (defun current-frame-fill-right ()
1048 "Fill the current frame right"
1049 (with-movement (fill-frame-right (current-child) (find-parent-frame (current-child) (find-current-root)))))
1051 (defun current-frame-fill-all-dir ()
1052 "Fill the current frame in all directions"
1054 (let ((parent (find-parent-frame (current-child) (find-current-root))))
1055 (fill-frame-up (current-child) parent
)
1056 (fill-frame-down (current-child) parent
)
1057 (fill-frame-left (current-child) parent
)
1058 (fill-frame-right (current-child) parent
))))
1060 (defun current-frame-fill-vertical ()
1061 "Fill the current frame vertically"
1063 (let ((parent (find-parent-frame (current-child) (find-current-root))))
1064 (fill-frame-up (current-child) parent
)
1065 (fill-frame-down (current-child) parent
))))
1067 (defun current-frame-fill-horizontal ()
1068 "Fill the current frame horizontally"
1070 (let ((parent (find-parent-frame (current-child) (find-current-root))))
1071 (fill-frame-left (current-child) parent
)
1072 (fill-frame-right (current-child) parent
))))
1076 (defun current-frame-resize-up ()
1077 "Resize the current frame up to its half height"
1078 (with-movement (resize-half-height-up (current-child))))
1080 (defun current-frame-resize-down ()
1081 "Resize the current frame down to its half height"
1082 (with-movement (resize-half-height-down (current-child))))
1084 (defun current-frame-resize-left ()
1085 "Resize the current frame left to its half width"
1086 (with-movement (resize-half-width-left (current-child))))
1088 (defun current-frame-resize-right ()
1089 "Resize the current frame right to its half width"
1090 (with-movement (resize-half-width-right (current-child))))
1092 (defun current-frame-resize-all-dir ()
1093 "Resize down the current frame"
1094 (with-movement (resize-frame-down (current-child))))
1096 (defun current-frame-resize-all-dir-minimal ()
1097 "Resize down the current frame to its minimal size"
1098 (with-movement (resize-minimal-frame (current-child))))
1101 ;;; Children navigation
1102 (defun with-movement-select-next-brother ()
1103 "Select the next brother frame"
1104 (with-movement (select-next-brother-simple)))
1106 (defun with-movement-select-previous-brother ()
1107 "Select the previous brother frame"
1108 (with-movement (select-previous-brother-simple)))
1110 (defun with-movement-select-next-level ()
1111 "Select the next level"
1112 (with-movement (select-next-level)))
1114 (defun with-movement-select-previous-level ()
1115 "Select the previous levelframe"
1116 (with-movement (select-previous-level)))
1118 (defun with-movement-select-next-child ()
1119 "Select the next child"
1120 (with-movement (select-next-child-simple)))
1124 ;;; Adapt frame functions
1125 (defun adapt-current-frame-to-window-hints-generic (width-p height-p
)
1126 "Adapt the current frame to the current window minimal size hints"
1127 (when (frame-p (current-child))
1128 (let ((window (first (frame-child (current-child)))))
1129 (when (xlib:window-p window
)
1130 (let* ((hints (xlib:wm-normal-hints window
))
1131 (min-width (and hints
(xlib:wm-size-hints-min-width hints
)))
1132 (min-height (and hints
(xlib:wm-size-hints-min-height hints
))))
1133 (when (and width-p min-width
)
1134 (setf (frame-rw (current-child)) min-width
))
1135 (when (and height-p min-height
)
1136 (setf (frame-rh (current-child)) min-height
))
1137 (fixe-real-size (current-child) (find-parent-frame (current-child)))
1138 (leave-second-mode))))))
1140 (defun adapt-current-frame-to-window-hints ()
1141 "Adapt the current frame to the current window minimal size hints"
1142 (adapt-current-frame-to-window-hints-generic t t
))
1144 (defun adapt-current-frame-to-window-width-hint ()
1145 "Adapt the current frame to the current window minimal width hint"
1146 (adapt-current-frame-to-window-hints-generic t nil
))
1148 (defun adapt-current-frame-to-window-height-hint ()
1149 "Adapt the current frame to the current window minimal height hint"
1150 (adapt-current-frame-to-window-hints-generic nil t
))
1155 ;;; Managed window type functions
1156 (defun current-frame-manage-window-type-generic (type-list)
1157 (when (frame-p (current-child))
1158 (setf (frame-managed-type (current-child)) type-list
1159 (frame-forced-managed-window (current-child)) nil
1160 (frame-forced-unmanaged-window (current-child)) nil
))
1161 (leave-second-mode))
1164 (defun current-frame-manage-window-type ()
1165 "Change window types to be managed by a frame"
1166 (when (frame-p (current-child))
1167 (let* ((type-str (query-string "Managed window type: (all, normal, transient, maxsize, desktop, dock, toolbar, menu, utility, splash, dialog)"
1168 (format nil
"~{~:(~A~) ~}" (frame-managed-type (current-child)))))
1169 (type-list (loop :for type
:in
(split-string type-str
)
1170 :collect
(intern (string-upcase type
) :keyword
))))
1171 (current-frame-manage-window-type-generic type-list
))))
1174 (defun current-frame-manage-all-window-type ()
1175 "Manage all window type"
1176 (current-frame-manage-window-type-generic '(:all
)))
1178 (defun current-frame-manage-only-normal-window-type ()
1179 "Manage only normal window type"
1180 (current-frame-manage-window-type-generic '(:normal
)))
1182 (defun current-frame-manage-no-window-type ()
1183 "Do not manage any window type"
1184 (current-frame-manage-window-type-generic nil
))
1193 ;;; Force window functions
1194 (defun force-window-in-frame ()
1195 "Force the current window to move in the frame (Useful only for unmanaged windows)"
1196 (with-current-window
1197 (let ((parent (find-parent-frame window
)))
1198 (setf (x-drawable-x window
) (frame-rx parent
)
1199 (x-drawable-y window
) (frame-ry parent
))
1200 (xlib:display-finish-output
*display
*)))
1201 (leave-second-mode))
1204 (defun force-window-center-in-frame ()
1205 "Force the current window to move in the center of the frame (Useful only for unmanaged windows)"
1206 (with-current-window
1207 (let ((parent (find-parent-frame window
)))
1208 (setf (x-drawable-x window
) (truncate (+ (frame-rx parent
)
1209 (/ (- (frame-rw parent
)
1210 (x-drawable-width window
)) 2)))
1211 (x-drawable-y window
) (truncate (+ (frame-ry parent
)
1212 (/ (- (frame-rh parent
)
1213 (x-drawable-height window
)) 2))))
1214 (xlib:display-finish-output
*display
*)))
1215 (leave-second-mode))
1219 (defun display-current-window-info ()
1220 "Display information on the current window"
1221 (with-current-window
1222 (info-mode (list (format nil
"Window: ~A" window
)
1223 (format nil
"Window name: ~A" (xlib:wm-name window
))
1224 (format nil
"Window class: ~A" (xlib:get-wm-class window
))
1225 (format nil
"Window type: ~:(~A~)" (window-type window
))
1226 (format nil
"Window id: 0x~X" (xlib:window-id window
))
1227 (format nil
"Window transparency: ~A" (* 100 (window-transparency window
))))))
1228 (leave-second-mode))
1230 (defun set-current-window-transparency ()
1231 "Set the current window transparency"
1232 (with-current-window
1233 (ask-child-transparency "window" window
))
1234 (leave-second-mode))
1237 (defun manage-current-window ()
1238 "Force to manage the current window by its parent frame"
1239 (with-current-window
1240 (let ((parent (find-parent-frame window
)))
1241 (with-slots ((managed forced-managed-window
)
1242 (unmanaged forced-unmanaged-window
)) parent
1243 (setf unmanaged
(child-remove window unmanaged
)
1244 unmanaged
(remove (xlib:wm-name window
) unmanaged
:test
#'string-equal-p
))
1245 (pushnew window managed
))))
1246 (leave-second-mode))
1248 (defun unmanage-current-window ()
1249 "Force to not manage the current window by its parent frame"
1250 (with-current-window
1251 (let ((parent (find-parent-frame window
)))
1252 (with-slots ((managed forced-managed-window
)
1253 (unmanaged forced-unmanaged-window
)) parent
1254 (setf managed
(child-remove window managed
)
1255 managed
(remove (xlib:wm-name window
) managed
:test
#'string-equal-p
))
1256 (pushnew window unmanaged
))))
1257 (leave-second-mode))
1261 ;;; Moving child with the mouse button
1262 (defun mouse-move-child-over-frame (window root-x root-y
)
1263 "Move the child under the mouse cursor to another frame"
1264 (declare (ignore window
))
1265 (let ((child (find-child-under-mouse root-x root-y
)))
1266 (unless (child-root-p child
)
1268 (remove-child-in-frame child
(find-parent-frame child
))
1269 (wait-mouse-button-release 50 51)
1270 (multiple-value-bind (x y
)
1271 (xlib:query-pointer
*root
*)
1272 (let ((dest (find-child-under-mouse x y
)))
1273 (when (xlib:window-p dest
)
1274 (setf dest
(find-parent-frame dest
)))
1275 (unless (child-equal-p child dest
)
1276 (move-child-to child dest
)
1277 (show-all-children))))))
1278 (stop-button-event))
1283 ;;; Hide/Show frame window functions
1284 (defun hide/show-frame-window
(frame value
)
1285 "Hide/show the frame window"
1286 (when (frame-p frame
)
1287 (setf (frame-show-window-p (current-child)) value
)
1288 (show-all-children))
1289 (leave-second-mode))
1292 (defun hide-current-frame-window ()
1293 "Hide the current frame window"
1294 (hide/show-frame-window
(current-child) nil
))
1296 (defun show-current-frame-window ()
1297 "Show the current frame window"
1298 (hide/show-frame-window
(current-child) t
))
1302 ;;; Hide/Unhide current child
1303 (defun hide-current-child ()
1304 "Hide the current child"
1305 (unless (child-root-p (current-child))
1306 (let ((parent (find-parent-frame (current-child))))
1307 (when (frame-p parent
)
1308 (with-slots (child hidden-children
) parent
1309 (hide-all (current-child))
1310 (setf child
(child-remove (current-child) child
))
1311 (pushnew (current-child) hidden-children
)
1312 (setf (current-child) parent
))
1313 (show-all-children)))
1314 (leave-second-mode)))
1317 (defun frame-unhide-child (hidden frame-src frame-dest
)
1318 "Unhide a hidden child from frame-src in frame-dest"
1319 (with-slots (hidden-children) frame-src
1320 (setf hidden-children
(child-remove hidden hidden-children
)))
1321 (with-slots (child) frame-dest
1322 (pushnew hidden child
)))
1326 (defun unhide-a-child ()
1327 "Unhide a child in the current frame"
1328 (when (frame-p (current-child))
1329 (with-slots (child hidden-children
) (current-child)
1330 (info-mode-menu (loop :for i
:from
0
1331 :for hidden
:in hidden-children
1332 :collect
(list (code-char (+ (char-code #\a) i
))
1335 (frame-unhide-child lhd
(current-child) (current-child))))
1336 (format nil
"Unhide ~A" (child-fullname hidden
))))))
1337 (show-all-children))
1338 (leave-second-mode))
1341 (defun unhide-all-children ()
1342 "Unhide all current frame hidden children"
1343 (when (frame-p (current-child))
1344 (with-slots (child hidden-children
) (current-child)
1345 (dolist (c hidden-children
)
1347 (setf hidden-children nil
))
1348 (show-all-children))
1349 (leave-second-mode))
1352 (defun unhide-a-child-from-all-frames ()
1353 "Unhide a child from all frames in the current frame"
1354 (when (frame-p (current-child))
1357 (with-all-frames (*root-frame
* frame
)
1358 (when (frame-hidden-children frame
)
1359 (push (format nil
"~A" (child-fullname frame
)) acc
)
1360 (dolist (hidden (frame-hidden-children frame
))
1361 (push (list (code-char (+ (char-code #\a) (incf keynum
)))
1364 (frame-unhide-child lhd frame
(current-child))))
1365 (format nil
"Unhide ~A" (child-fullname hidden
)))
1367 (info-mode-menu (nreverse acc
)))
1368 (show-all-children))
1369 (leave-second-mode))
1375 (let ((last-child nil
))
1376 (defun init-last-child ()
1377 (setf last-child nil
))
1378 (defun switch-to-last-child ()
1379 "Store the current child and switch to the previous one"
1380 (let ((current-child (current-child)))
1382 (change-root (find-root last-child
) last-child
)
1383 (setf (current-child) last-child
)
1384 (focus-all-children (current-child) (current-child))
1385 (show-all-children t
))
1386 (setf last-child current-child
))
1387 (leave-second-mode)))
1395 ;;; Focus policy functions
1396 (defun set-focus-policy-generic (focus-policy)
1397 (when (frame-p (current-child))
1398 (setf (frame-focus-policy (current-child)) focus-policy
))
1399 (leave-second-mode))
1402 (defun current-frame-set-click-focus-policy ()
1403 "Set a click focus policy for the current frame."
1404 (set-focus-policy-generic :click
))
1406 (defun current-frame-set-sloppy-focus-policy ()
1407 "Set a sloppy focus policy for the current frame."
1408 (set-focus-policy-generic :sloppy
))
1410 (defun current-frame-set-sloppy-strict-focus-policy ()
1411 "Set a (strict) sloppy focus policy only for windows in the current frame."
1412 (set-focus-policy-generic :sloppy-strict
))
1414 (defun current-frame-set-sloppy-select-policy ()
1415 "Set a sloppy select policy for the current frame."
1416 (set-focus-policy-generic :sloppy-select
))
1420 (defun set-focus-policy-generic-for-all (focus-policy)
1421 (with-all-frames (*root-frame
* frame
)
1422 (setf (frame-focus-policy frame
) focus-policy
))
1423 (leave-second-mode))
1426 (defun all-frames-set-click-focus-policy ()
1427 "Set a click focus policy for all frames."
1428 (set-focus-policy-generic-for-all :click
))
1430 (defun all-frames-set-sloppy-focus-policy ()
1431 "Set a sloppy focus policy for all frames."
1432 (set-focus-policy-generic-for-all :sloppy
))
1434 (defun all-frames-set-sloppy-strict-focus-policy ()
1435 "Set a (strict) sloppy focus policy for all frames."
1436 (set-focus-policy-generic-for-all :sloppy-strict
))
1438 (defun all-frames-set-sloppy-select-policy ()
1439 "Set a sloppy select policy for all frames."
1440 (set-focus-policy-generic-for-all :sloppy-select
))
1444 ;;; Ensure unique name/number functions
1445 (defun extract-number-from-name (name)
1446 (when (stringp name
)
1447 (let* ((pos (1+ (or (position #\. name
:from-end t
) -
1)))
1448 (number (parse-integer name
:junk-allowed t
:start pos
)))
1450 (if number
(subseq name
0 (1- pos
)) name
)))))
1455 (defun ensure-unique-name ()
1456 "Ensure that all children names are unique"
1457 (with-all-children (*root-frame
* child
)
1458 (multiple-value-bind (num1 name1
)
1459 (extract-number-from-name (child-name child
))
1460 (declare (ignore num1
))
1463 (with-all-children (*root-frame
* c
)
1464 (unless (child-equal-p child c
))
1465 (multiple-value-bind (num2 name2
)
1466 (extract-number-from-name (child-name c
))
1467 (when (string-equal name1 name2
)
1470 (when (> (length acc
) 1)
1471 (setf (child-name child
)
1472 (format nil
"~A.~A" name1
1473 (1+ (find-free-number (loop for i in acc when i collect
(1- i
)))))))))))
1474 (leave-second-mode))
1476 (defun ensure-unique-number ()
1477 "Ensure that all children numbers are unique"
1479 (with-all-frames (*root-frame
* frame
)
1480 (setf (frame-number frame
) (incf num
))))
1481 (leave-second-mode))
1485 ;;; Standard menu functions - Based on the XDG specifications
1486 (defun um-create-xdg-section-list (menu)
1487 (dolist (section *xdg-section-list
*)
1488 (add-sub-menu menu
:next section
(format nil
"~A" section
) menu
))
1489 (unless (find-toplevel-menu 'Utility menu
)
1490 (add-sub-menu menu
:next
'Utility
(format nil
"~A" 'Utility
) menu
)))
1492 (defun um-find-submenu (menu section-list
)
1494 (dolist (section section-list
)
1495 (awhen (find-toplevel-menu (intern (string-upcase section
) :clfswm
) menu
)
1499 (list (find-toplevel-menu 'Utility menu
)))))
1502 (defun um-extract-value (line)
1503 (second (split-string line
#\
=)))
1506 (defun um-add-desktop (desktop menu
)
1507 (let (name exec categories comment
)
1508 (when (probe-file desktop
)
1509 (with-open-file (stream desktop
:direction
:input
)
1510 (loop for line
= (ignore-errors (read-line stream nil nil
))
1513 (cond ((first-position "Name=" line
) (setf name
(um-extract-value line
)))
1514 ((first-position "Exec=" line
) (setf exec
(um-extract-value line
)))
1515 ((first-position "Categories=" line
) (setf categories
(um-extract-value line
)))
1516 ((first-position "Comment=" line
) (setf comment
(um-extract-value line
))))
1517 (when (and name exec categories
)
1518 (let* ((sub-menu (um-find-submenu menu
(split-string categories
#\
;)))
1519 (fun-name (intern name
:clfswm
)))
1520 (setf (symbol-function fun-name
) (let ((do-exec exec
))
1523 (leave-second-mode)))
1524 (documentation fun-name
'function
) (format nil
"~A~A" name
(if comment
1525 (format nil
" - ~A" comment
)
1527 (dolist (m sub-menu
)
1528 (add-menu-key (menu-name m
) :next fun-name m
)))
1529 (setf name nil exec nil categories nil comment nil
)))))))
1532 (defun update-menus (&optional
(menu (make-menu :name
'main
:doc
"Main menu")))
1533 (um-create-xdg-section-list menu
)
1535 (found (make-hash-table :test
#'equal
)))
1536 (dolist (dir (remove-duplicates
1537 (split-string (or (getenv "XDG_DATA_DIRS") "/usr/local/share/:/usr/share/")
1538 #\
:) :test
#'string-equal
))
1539 (dolist (desktop (directory (concatenate 'string dir
"/applications/**/*.desktop")))
1540 (unless (gethash (file-namestring desktop
) found
)
1541 (setf (gethash (file-namestring desktop
) found
) t
)
1542 (um-add-desktop desktop menu
)
1548 ;;; Close/Kill focused window
1550 (defun ask-close/kill-current-window
()
1551 "Close or kill the current window (ask before doing anything)"
1552 (let ((window (xlib:input-focus
*display
*))
1553 (*info-mode-placement
* *ask-close
/kill-placement
*))
1555 (if (and window
(not (xlib:window-equal window
*no-focus-window
*)))
1556 `(,(format nil
"Focus window: ~A" (xlib:wm-name window
))
1557 (#\s delete-focus-window
"Close the focus window")
1558 (#\k destroy-focus-window
"Kill the focus window")
1559 (#\x cut-focus-window
)
1560 (#\c copy-focus-window
)
1561 (#\v paste-selection
))
1562 `(,(format nil
"Focus window: None")
1563 (#\v paste-selection
))))
1568 ;;; Other window manager functions
1569 (defun get-proc-list ()
1570 (let ((proc (do-shell "ps x -o pid=" nil t
))
1572 (loop for line
= (read-line proc nil nil
)
1574 do
(push line proc-list
))
1578 (defun run-other-window-manager ()
1579 (let ((proc-start (get-proc-list)))
1580 (do-shell *other-window-manager
* nil t
:terminal
)
1581 (let* ((proc-end (get-proc-list))
1582 (proc-diff (set-difference proc-end proc-start
:test
#'equal
)))
1583 (dbg 'killing-sigterm proc-diff
)
1584 (do-shell (format nil
"kill ~{ ~A ~} 2> /dev/null" proc-diff
) nil t
:terminal
)
1585 (dbg 'killing-sigkill proc-diff
)
1586 (do-shell (format nil
"kill -9 ~{ ~A ~} 2> /dev/null" proc-diff
) nil t
:terminal
)
1588 (setf *other-window-manager
* nil
)))
1591 (defun do-run-other-window-manager (window-manager)
1592 (setf *other-window-manager
* window-manager
)
1593 (throw 'exit-main-loop nil
))
1595 (defmacro def-run-other-window-manager
(name &optional definition
)
1596 (let ((definition (or definition name
)))
1597 `(defun ,(create-symbol "run-" name
) ()
1598 ,(format nil
"Run ~A" definition
)
1599 (do-run-other-window-manager ,(format nil
"~A" name
)))))
1601 (def-run-other-window-manager "xterm")
1602 (def-run-other-window-manager "icewm")
1603 (def-run-other-window-manager "twm")
1604 (def-run-other-window-manager "gnome-session" "Gnome")
1605 (def-run-other-window-manager "startkde" "KDE")
1606 (def-run-other-window-manager "xfce4-session" "XFCE")
1610 (do-run-other-window-manager "( lxsession & ); xterm -e \"echo ' /----------------------------------\\' ; echo ' | CLFSWM Note: |' ; echo ' | Close this window when done. |' ; echo ' \\----------------------------------/'; echo; echo; $SHELL\""))
1614 (do-run-other-window-manager "( xfce4-session &) ; xterm -e \"echo ' /----------------------------------\\' ; echo ' | CLFSWM Note: |' ; echo ' | Close this window when done. |' ; echo ' \\----------------------------------/'; echo; echo; $SHELL\""))
1617 (defun run-prompt-wm ()
1618 "Prompt for an other window manager"
1619 (let ((wm (query-string "Run an other window manager:" "icewm")))
1620 (do-run-other-window-manager wm
)))
1623 ;;; Hide or show unmanaged windows utility.
1624 (defun set-hide-unmanaged-window ()
1625 "Hide unmanaged windows when frame is not selected"
1626 (when (frame-p (current-child))
1627 (setf (frame-data-slot (current-child) :unmanaged-window-action
) :hide
)
1628 (leave-second-mode)))
1630 (defun set-show-unmanaged-window ()
1631 "Show unmanaged windows when frame is not selected"
1632 (when (frame-p (current-child))
1633 (setf (frame-data-slot (current-child) :unmanaged-window-action
) :show
)
1634 (leave-second-mode)))
1636 (defun set-default-hide-unmanaged-window ()
1637 "Set default behaviour to hide or not unmanaged windows when frame is not selected"
1638 (when (frame-p (current-child))
1639 (setf (frame-data-slot (current-child) :unmanaged-window-action
) nil
)
1640 (leave-second-mode)))
1642 (defun set-globally-hide-unmanaged-window ()
1643 "Hide unmanaged windows by default. This is overriden by functions above"
1644 (setf *hide-unmanaged-window
* t
)
1645 (leave-second-mode))
1647 (defun set-globally-show-unmanaged-window ()
1648 "Show unmanaged windows by default. This is overriden by functions above"
1649 (setf *hide-unmanaged-window
* nil
)
1650 (leave-second-mode))
1653 ;;; Speed mouse movement.
1654 (let (minx miny maxx maxy history lx ly
)
1655 (labels ((middle (x1 x2
)
1656 (round (/ (+ x1 x2
) 2)))
1657 (reset-if-moved (x y
)
1658 (when (or (/= x
(or lx x
)) (/= y
(or ly y
)))
1659 (speed-mouse-reset)))
1660 (add-in-history (x y
)
1661 (push (list x y
) history
)))
1662 (defun speed-mouse-reset ()
1663 "Reset speed mouse coordinates"
1664 (setf minx nil miny nil maxx nil maxy nil history nil lx nil ly nil
))
1665 (defun speed-mouse-left ()
1666 "Speed move mouse to left"
1668 (reset-if-moved x y
)
1670 (add-in-history x y
)
1671 (setf lx
(middle (or minx
0) maxx
))
1672 (xlib:warp-pointer
*root
* lx y
)))
1673 (defun speed-mouse-right ()
1674 "Speed move mouse to right"
1676 (reset-if-moved x y
)
1678 (add-in-history x y
)
1679 (setf lx
(middle minx
(or maxx
(xlib:screen-width
*screen
*))))
1680 (xlib:warp-pointer
*root
* lx y
)))
1681 (defun speed-mouse-up ()
1682 "Speed move mouse to up"
1684 (reset-if-moved x y
)
1686 (add-in-history x y
)
1687 (setf ly
(middle (or miny
0) maxy
))
1688 (xlib:warp-pointer
*root
* x ly
)))
1689 (defun speed-mouse-down ()
1690 "Speed move mouse to down"
1692 (reset-if-moved x y
)
1694 (add-in-history x y
)
1695 (setf ly
(middle miny
(or maxy
(xlib:screen-height
*screen
*))))
1696 (xlib:warp-pointer
*root
* x ly
)))
1697 (defun speed-mouse-undo ()
1698 "Undo last speed mouse move"
1700 (let ((h (pop history
)))
1702 (destructuring-bind (bx by
) h
1706 (xlib:warp-pointer
*root
* lx ly
))))))
1707 (defun speed-mouse-first-history ()
1708 "Revert to the first speed move mouse"
1710 (let ((h (first (last history
))))
1714 (xlib:warp-pointer
*root
* lx ly
)))))))
1718 ;;; Notify window functions
1725 (labels ((text-string (tx)
1730 (get-color (typecase tx
1732 (t *notify-window-foreground
*)))))
1733 (defun is-notify-window-p (win)
1734 (when (and (xlib:window-p win
) (xlib:window-p window
))
1735 (xlib:window-equal win window
)))
1737 (defun raise-notify-window ()
1738 (raise-window window
))
1740 (defun refresh-notify-window ()
1741 (add-timer 0.1 #'refresh-notify-window
:refresh-notify-window
)
1742 (when (and window gc font
)
1743 (raise-window window
)
1744 (let ((text-height (- (xlib:font-ascent font
) (xlib:font-descent font
))))
1745 (loop for tx in text
1747 (setf (xlib:gcontext-foreground gc
) (text-color tx
))
1748 (xlib:draw-glyphs window gc
1749 (truncate (/ (- width
(* (xlib:max-char-width font
) (length (text-string tx
)))) 2))
1751 (text-string tx
))))))
1753 (defun close-notify-window ()
1754 (erase-timer :refresh-notify-window
)
1755 (setf *never-managed-window-list
*
1756 (remove (list #'is-notify-window-p
'raise-window
)
1757 *never-managed-window-list
* :test
#'equal
))
1759 (xlib:free-gcontext gc
))
1761 (xlib:destroy-window window
))
1763 (xlib:close-font font
))
1764 (xlib:display-finish-output
*display
*)
1769 (defun open-notify-window (text-list)
1770 (close-notify-window)
1771 (setf font
(xlib:open-font
*display
* *notify-window-font-string
*))
1772 (let ((text-height (- (xlib:font-ascent font
) (xlib:font-descent font
))))
1773 (setf text text-list
)
1774 (setf width
(* (xlib:max-char-width font
) (+ (loop for tx in text-list
1775 maximize
(length (text-string tx
))) 2))
1776 height
(+ (* text-height
(length text-list
) 2) text-height
))
1777 (with-placement (*notify-window-placement
* x y width height
)
1778 (setf window
(xlib:create-window
:parent
*root
*
1783 :background
(get-color *notify-window-background
*)
1784 :border-width
*border-size
*
1785 :border
(get-color *notify-window-border
*)
1786 :colormap
(xlib:screen-default-colormap
*screen
*)
1787 :event-mask
'(:exposure
:key-press
))
1788 gc
(xlib:create-gcontext
:drawable window
1789 :foreground
(get-color *notify-window-foreground
*)
1790 :background
(get-color *notify-window-background
*)
1792 :line-style
:solid
))
1793 (setf (window-transparency window
) *notify-window-transparency
*)
1794 (when (frame-p (current-child))
1795 (setf current-child
(current-child)))
1796 (add-in-never-managed-window-list (list 'is-notify-window-p
'raise-window
))
1798 (refresh-notify-window)
1799 (xlib:display-finish-output
*display
*))))))
1801 (defun notify-message (delay &rest messages
)
1802 (erase-timer :close-notify-window
)
1803 (funcall #'open-notify-window messages
)
1804 (add-timer delay
#'close-notify-window
:close-notify-window
))
1807 (defun display-hello-window ()
1808 (notify-message *notify-window-delay
*
1809 '("Welcome to CLFSWM" "yellow")
1810 "Press Alt+F1 for help"))
1813 ;;; Run or raise functions
1814 (defun run-or-raise (raisep run-fn
&key
(maximized nil
))
1815 (let ((window (with-all-windows (*root-frame
* win
)
1816 (when (funcall raisep win
)
1819 (let ((parent (find-parent-frame window
)))
1820 (setf (current-child) parent
)
1821 (put-child-on-top window parent
)
1823 (change-root (find-root parent
) parent
))
1824 (focus-all-children window parent
)
1825 (show-all-children t
))
1828 ;;; Transparency setting
1829 (defun inc-transparency (window root-x root-y
)
1830 "Increment the child under mouse transparency"
1831 (declare (ignore root-x root-y
))
1832 (unless *in-second-mode
* (stop-button-event))
1833 (incf (child-transparency window
) 0.1))
1835 (defun dec-transparency (window root-x root-y
)
1836 "Decrement the child under mouse transparency"
1837 (declare (ignore root-x root-y
))
1838 (unless *in-second-mode
* (stop-button-event))
1839 (decf (child-transparency window
) 0.1))
1841 (defun inc-transparency-slow (window root-x root-y
)
1842 "Increment slowly the child under mouse transparency"
1843 (declare (ignore root-x root-y
))
1844 (unless *in-second-mode
* (stop-button-event))
1845 (incf (child-transparency window
) 0.01))
1847 (defun dec-transparency-slow (window root-x root-y
)
1848 "Decrement slowly the child under mouse transparency"
1849 (declare (ignore root-x root-y
))
1850 (unless *in-second-mode
* (stop-button-event))
1851 (decf (child-transparency window
) 0.01))
1854 (defun key-inc-transparency ()
1855 "Increment the current window transparency"
1856 (with-current-window
1857 (incf (child-transparency window
) 0.1)))
1859 (defun key-dec-transparency ()
1860 "Decrement the current window transparency"
1861 (with-current-window
1862 (decf (child-transparency window
) 0.1)))
1868 ;;; Geometry change functions
1869 (defun swap-frame-geometry ()
1870 "Swap current brother frame geometry"
1871 (when (frame-p (current-child))
1872 (let ((parent (find-parent-frame (current-child))))
1873 (when (frame-p parent
)
1874 (let ((brother (second (frame-child parent
))))
1875 (when (frame-p brother
)
1876 (rotatef (frame-x (current-child)) (frame-x brother
))
1877 (rotatef (frame-y (current-child)) (frame-y brother
))
1878 (rotatef (frame-w (current-child)) (frame-w brother
))
1879 (rotatef (frame-h (current-child)) (frame-h brother
))
1880 (show-all-children t
)
1881 (leave-second-mode)))))))
1883 (defun rotate-frame-geometry-generic (fun)
1884 "(Rotate brother frame geometry"
1885 (when (frame-p (current-child))
1886 (let ((parent (find-parent-frame (current-child))))
1887 (when (frame-p parent
)
1888 (let* ((child-list (funcall fun
(frame-child parent
)))
1889 (first (first child-list
)))
1890 (dolist (child (rest child-list
))
1891 (when (and (frame-p first
) (frame-p child
))
1892 (rotatef (frame-x first
) (frame-x child
))
1893 (rotatef (frame-y first
) (frame-y child
))
1894 (rotatef (frame-w first
) (frame-w child
))
1895 (rotatef (frame-h first
) (frame-h child
))
1896 (setf first child
)))
1897 (show-all-children t
))))))
1900 (defun rotate-frame-geometry ()
1901 "Rotate brother frame geometry"
1902 (rotate-frame-geometry-generic #'identity
))
1904 (defun anti-rotate-frame-geometry ()
1905 "Anti rotate brother frame geometry"
1906 (rotate-frame-geometry-generic #'reverse
))