1 ;;; --------------------------------------------------------------------------
2 ;;; CLFSWM - FullScreen Window Manager
4 ;;; --------------------------------------------------------------------------
5 ;;; Documentation: Utility
6 ;;; --------------------------------------------------------------------------
8 ;;; (C) 2010 Philippe Brochard <hocwp@free.fr>
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 (pathname-directory (concatenate 'string
(or (getenv "XDG_CONFIG_HOME")
35 (let ((saved-conf-name nil
))
36 (defun conf-file-name (&optional alternate-name
)
37 (unless (and saved-conf-name
(not alternate-name
))
38 (let* ((user-conf (probe-file (merge-pathnames (user-homedir-pathname) #p
".clfswmrc")))
39 (etc-conf (probe-file #p
"/etc/clfswmrc"))
40 (config-user-conf (probe-file (make-pathname :directory
(append (xdg-config-home) '("clfswm"))
42 (alternate-conf (and alternate-name
(probe-file alternate-name
))))
43 (setf saved-conf-name
(or alternate-conf config-user-conf user-conf etc-conf
))))
44 (print saved-conf-name
)
50 (defun load-contrib (file)
51 "Load a file in the contrib directory"
52 (let ((truename (concatenate 'string
*contrib-dir
* "contrib/" file
)))
53 (format t
"Loading contribution file: ~A~%" truename
)
54 (when (probe-file truename
)
55 (load truename
:verbose nil
))))
58 (defun reload-clfswm ()
60 (format t
"~&-*- Reloading CLFSWM -*-~%")
61 (asdf:oos
'asdf
:load-op
:clfswm
)
67 (defun rename-current-child ()
68 "Rename the current child"
69 (let ((name (query-string (format nil
"New child name: (last: ~A)" (child-name *current-child
*))
70 (child-name *current-child
*))))
71 (rename-child *current-child
* name
)
75 (defun renumber-current-frame ()
76 "Renumber the current frame"
77 (when (frame-p *current-child
*)
78 (let ((number (query-number (format nil
"New child number: (last: ~A)" (frame-number *current-child
*))
79 (frame-number *current-child
*))))
80 (setf (frame-number *current-child
*) number
)
81 (leave-second-mode))))
86 (defun add-default-frame ()
87 "Add a default frame in the current frame"
88 (when (frame-p *current-child
*)
89 (let ((name (query-string "Frame name")))
90 (push (create-frame :name name
) (frame-child *current-child
*))))
94 (defun add-placed-frame ()
95 "Add a placed frame in the current frame"
96 (when (frame-p *current-child
*)
97 (let ((name (query-string "Frame name"))
98 (x (/ (query-number "Frame x in percent (%)") 100))
99 (y (/ (query-number "Frame y in percent (%)") 100))
100 (w (/ (query-number "Frame width in percent (%)") 100))
101 (h (/ (query-number "Frame height in percent (%)") 100)))
102 (push (create-frame :name name
:x x
:y y
:w w
:h h
)
103 (frame-child *current-child
*))))
108 (defun delete-focus-window-generic (close-fun)
109 (let ((window (xlib:input-focus
*display
*)))
110 (when (and window
(not (xlib:window-equal window
*no-focus-window
*)))
111 (when (child-equal-p window
*current-child
*)
112 (setf *current-child
* *current-root
*))
114 (delete-child-and-children-in-all-frames window close-fun
)
115 (show-all-children))))
117 (defun delete-focus-window ()
118 "Close focus window: Delete the focus window in all frames and workspaces"
119 (delete-focus-window-generic 'delete-window
))
121 (defun destroy-focus-window ()
122 "Kill focus window: Destroy the focus window in all frames and workspaces"
123 (delete-focus-window-generic 'destroy-window
))
125 (defun remove-focus-window ()
126 "Remove the focus window from the current frame"
127 (let ((window (xlib:input-focus
*display
*)))
128 (when (and window
(not (xlib:window-equal window
*no-focus-window
*)))
129 (setf *current-child
* *current-root
*)
131 (remove-child-in-frame window
(find-parent-frame window
))
132 (show-all-children))))
135 (defun unhide-all-windows-in-current-child ()
136 "Unhide all hidden windows into the current child"
138 (dolist (window (get-hidden-windows))
139 (unhide-window window
)
140 (process-new-window window
)
141 (map-window window
)))
147 (defun find-window-under-mouse (x y
)
148 "Return the child window under the mouse"
151 (with-all-windows-frames-and-parent (*current-root
* child parent
)
152 (when (and (or (managed-window-p child parent
) (child-equal-p parent
*current-child
*))
153 (<= (xlib:drawable-x child
) x
(+ (xlib:drawable-x child
) (xlib:drawable-width child
)))
154 (<= (xlib:drawable-y child
) y
(+ (xlib:drawable-y child
) (xlib:drawable-height child
))))
156 (when (and (<= (frame-rx child
) x
(+ (frame-rx child
) (frame-rw child
)))
157 (<= (frame-ry child
) y
(+ (frame-ry child
) (frame-rh child
))))
158 (setf win
(frame-window child
))))
162 (defun find-child-under-mouse (x y
&optional first-foundp
)
163 "Return the child under the mouse"
166 (with-all-windows-frames-and-parent (*current-root
* child parent
)
167 (when (and (or (managed-window-p child parent
) (child-equal-p parent
*current-child
*))
168 (<= (xlib:drawable-x child
) x
(+ (xlib:drawable-x child
) (xlib:drawable-width child
)))
169 (<= (xlib:drawable-y child
) y
(+ (xlib:drawable-y child
) (xlib:drawable-height child
))))
171 (return-from find-child-under-mouse child
)
173 (when (and (<= (frame-rx child
) x
(+ (frame-rx child
) (frame-rw child
)))
174 (<= (frame-ry child
) y
(+ (frame-ry child
) (frame-rh child
))))
176 (return-from find-child-under-mouse child
)
185 ;;; Selection functions
186 (defun clear-selection ()
187 "Clear the current selection"
188 (setf *child-selection
* nil
)
189 (display-frame-info *current-root
*))
191 (defun copy-current-child ()
192 "Copy the current child to the selection"
193 (pushnew *current-child
* *child-selection
*)
194 (display-frame-info *current-root
*))
197 (defun cut-current-child ()
198 "Cut the current child to the selection"
200 (hide-all *current-child
*)
201 (remove-child-in-frame *current-child
* (find-parent-frame *current-child
* *current-root
*))
202 (setf *current-child
* *current-root
*)
205 (defun remove-current-child ()
206 "Remove the current child from its parent frame"
207 (hide-all *current-child
*)
208 (remove-child-in-frame *current-child
* (find-parent-frame *current-child
* *current-root
*))
209 (setf *current-child
* *current-root
*)
212 (defun delete-current-child ()
213 "Delete the current child and its children in all frames"
214 (hide-all *current-child
*)
215 (delete-child-and-children-in-all-frames *current-child
*)
219 (defun paste-selection-no-clear ()
220 "Paste the selection in the current frame - Do not clear the selection after paste"
221 (let ((frame-dest (typecase *current-child
*
222 (xlib:window
(find-parent-frame *current-child
* *current-root
*))
223 (frame *current-child
*))))
225 (dolist (child *child-selection
*)
226 (unless (find-child-in-parent child frame-dest
)
227 (pushnew child
(frame-child frame-dest
))))
228 (show-all-children))))
230 (defun paste-selection ()
231 "Paste the selection in the current frame"
232 (paste-selection-no-clear)
233 (setf *child-selection
* nil
)
234 (display-frame-info *current-root
*))
239 ;;; Maximize function
240 (defun frame-toggle-maximize ()
241 "Maximize/Unmaximize the current frame in its parent frame"
242 (when (frame-p *current-child
*)
243 (let ((unmaximized-coords (frame-data-slot *current-child
* :unmaximized-coords
)))
244 (if unmaximized-coords
245 (with-slots (x y w h
) *current-child
*
246 (destructuring-bind (nx ny nw nh
) unmaximized-coords
247 (setf (frame-data-slot *current-child
* :unmaximized-coords
) nil
248 x nx y ny w nw h nh
)))
249 (with-slots (x y w h
) *current-child
*
250 (setf (frame-data-slot *current-child
* :unmaximized-coords
)
253 (show-all-children (find-parent-frame *current-child
*))
254 (leave-second-mode)))
264 ;;; CONFIG - Identify mode
265 (defun identify-key ()
268 (font (xlib:open-font
*display
* *identify-font-string
*))
269 (window (xlib:create-window
:parent
*root
*
271 :width
(- (xlib:screen-width
*screen
*) 2)
272 :height
(* 5 (+ (xlib:max-char-ascent font
) (xlib:max-char-descent font
)))
273 :background
(get-color *identify-background
*)
275 :border
(get-color *identify-border
*)
276 :colormap
(xlib:screen-default-colormap
*screen
*)
277 :event-mask
'(:exposure
)))
278 (gc (xlib:create-gcontext
:drawable window
279 :foreground
(get-color *identify-foreground
*)
280 :background
(get-color *identify-background
*)
282 :line-style
:solid
)))
283 (labels ((print-doc (msg hash-table-key pos code state
)
284 (let ((function (find-key-from-code hash-table-key code state
)))
285 (when (and function
(fboundp (first function
)))
286 (xlib:draw-glyphs
*pixmap-buffer
* gc
10 (+ (* pos
(+ (xlib:max-char-ascent font
) (xlib:max-char-descent font
))) 5)
287 (format nil
"~A ~A" msg
(documentation (first function
) 'function
))))))
288 (print-key (code state keysym key modifiers
)
289 (clear-pixmap-buffer window gc
)
290 (setf (xlib:gcontext-foreground gc
) (get-color *identify-foreground
*))
291 (xlib:draw-glyphs
*pixmap-buffer
* gc
5 (+ (xlib:max-char-ascent font
) 5)
292 (format nil
"Press a key to identify. Press 'q' to stop the identify loop."))
294 (xlib:draw-glyphs
*pixmap-buffer
* gc
10 (+ (* 2 (+ (xlib:max-char-ascent font
) (xlib:max-char-descent font
))) 5)
295 (format nil
"Code=~A KeySym=~S Key=~S Modifiers=~A"
296 code keysym key modifiers
))
297 (print-doc "Main mode : " *main-keys
* 3 code state
)
298 (print-doc "Second mode: " *second-keys
* 4 code state
))
299 (copy-pixmap-buffer window gc
))
300 (handle-identify-key (&rest event-slots
&key root code state
&allow-other-keys
)
301 (declare (ignore event-slots root
))
302 (let* ((modifiers (state->modifiers state
))
303 (key (keycode->char code state
))
304 (keysym (keysym->keysym-name
(keycode->keysym code modifiers
))))
305 (setf done
(and (equal key
#\q
) (equal modifiers
*default-modifiers
*)))
306 (dbg code keysym key modifiers
)
307 (print-key code state keysym key modifiers
)
309 (handle-identify (&rest event-slots
&key display event-key
&allow-other-keys
)
310 (declare (ignore display
))
312 (:key-press
(apply #'handle-identify-key event-slots
) t
)
313 (:exposure
(print-key nil nil nil nil nil
)))
315 (xgrab-pointer *root
* 92 93)
317 (format t
"~&Press 'q' to stop the identify loop~%")
318 (print-key nil nil nil nil nil
)
322 (xlib:display-finish-output
*display
*)
323 (when (xlib:event-listen
*display
* *loop-timeout
*)
324 (xlib:process-event
*display
* :handler
#'handle-identify
)))
325 (xlib:destroy-window window
)
326 (xlib:close-font font
)
327 (xgrab-pointer *root
* 66 67)))))
334 (defun eval-from-query-string ()
335 "Eval a lisp form from the query input"
336 (let ((form (query-string "Eval:"))
338 (when (and form
(not (equal form
"")))
339 (let ((printed-result
340 (with-output-to-string (*standard-output
*)
341 (setf result
(handler-case
342 (loop for i in
(multiple-value-list
343 (eval (read-from-string form
)))
344 collect
(format nil
"~S" i
))
346 (format nil
"~A" condition
)))))))
347 (info-mode (expand-newline (append (ensure-list (format nil
"> ~A" form
))
348 (ensure-list printed-result
)
349 (ensure-list result
)))
350 :width
(- (xlib:screen-width
*screen
*) 2))
351 (eval-from-query-string)))))
356 (defun run-program-from-query-string ()
357 "Run a program from the query input"
358 (multiple-value-bind (program return
)
359 (query-string "Run:")
360 (when (and (equal return
:return
) program
(not (equal program
"")))
361 (setf *second-mode-program
* program
)
362 (leave-second-mode))))
367 ;;; Frame name actions
368 (defun ask-frame-name (msg)
370 (let ((all-frame-name nil
)
372 (with-all-frames (*root-frame
* frame
)
373 (awhen (frame-name frame
) (push it all-frame-name
)))
374 (labels ((selected-names ()
375 (loop :for str
:in all-frame-name
376 :when
(zerop (or (search name str
:test
#'string-equal
) -
1))
378 (complet-alone (req sel
)
379 (if (= 1 (length sel
)) (first sel
) req
))
381 (let* ((selected (selected-names))
382 (default (complet-alone name selected
)))
383 (multiple-value-bind (str done
)
384 (query-string (format nil
"~A: ~{~A~^, ~}" msg selected
) default
)
386 (when (or (not (string-equal name default
)) (eql done
:complet
))
393 ;;; Focus by functions
394 (defun focus-frame-by (frame)
395 (when (frame-p frame
)
396 (hide-all *current-root
*)
397 (focus-all-children frame
(or (find-parent-frame frame
*current-root
*)
398 (find-parent-frame frame
)
400 (show-all-children *current-root
*)))
403 (defun focus-frame-by-name ()
404 "Focus a frame by name"
405 (focus-frame-by (find-frame-by-name (ask-frame-name "Focus frame")))
408 (defun focus-frame-by-number ()
409 "Focus a frame by number"
410 (focus-frame-by (find-frame-by-number (query-number "Focus frame by number:")))
414 ;;; Open by functions
415 (defun open-frame-by (frame)
416 (when (frame-p frame
)
417 (push (create-frame :name
(query-string "Frame name")) (frame-child frame
))
418 (show-all-children *current-root
*)))
422 (defun open-frame-by-name ()
423 "Open a new frame in a named frame"
424 (open-frame-by (find-frame-by-name (ask-frame-name "Open a new frame in")))
427 (defun open-frame-by-number ()
428 "Open a new frame in a numbered frame"
429 (open-frame-by (find-frame-by-number (query-number "Open a new frame in the group numbered:")))
433 ;;; Delete by functions
434 (defun delete-frame-by (frame)
435 (hide-all *current-root
*)
436 (unless (child-equal-p frame
*root-frame
*)
437 (when (child-equal-p frame
*current-root
*)
438 (setf *current-root
* *root-frame
*))
439 (when (child-equal-p frame
*current-child
*)
440 (setf *current-child
* *current-root
*))
441 (remove-child-in-frame frame
(find-parent-frame frame
)))
442 (show-all-children *current-root
*))
445 (defun delete-frame-by-name ()
446 "Delete a frame by name"
447 (delete-frame-by (find-frame-by-name (ask-frame-name "Delete frame")))
450 (defun delete-frame-by-number ()
451 "Delete a frame by number"
452 (delete-frame-by (find-frame-by-number (query-number "Delete frame by number:")))
457 (defun move-child-to (child frame-dest
)
458 (when (and child
(frame-p frame-dest
))
459 (hide-all *current-root
*)
460 (remove-child-in-frame child
(find-parent-frame child
))
461 (pushnew child
(frame-child frame-dest
))
462 (focus-all-children child frame-dest
)
463 (show-all-children *current-root
*)))
465 (defun move-current-child-by-name ()
466 "Move current child in a named frame"
467 (move-child-to *current-child
*
469 (ask-frame-name (format nil
"Move '~A' to frame" (child-name *current-child
*)))))
472 (defun move-current-child-by-number ()
473 "Move current child in a numbered frame"
474 (move-child-to *current-child
*
475 (find-frame-by-number
476 (query-number (format nil
"Move '~A' to frame numbered:" (child-name *current-child
*)))))
481 (defun copy-child-to (child frame-dest
)
482 (when (and child
(frame-p frame-dest
))
483 (hide-all *current-root
*)
484 (pushnew child
(frame-child frame-dest
))
485 (focus-all-children child frame-dest
)
486 (show-all-children *current-root
*)))
488 (defun copy-current-child-by-name ()
489 "Copy current child in a named frame"
490 (copy-child-to *current-child
*
492 (ask-frame-name (format nil
"Copy '~A' to frame" (child-name *current-child
*)))))
495 (defun copy-current-child-by-number ()
496 "Copy current child in a numbered frame"
497 (copy-child-to *current-child
*
498 (find-frame-by-number
499 (query-number (format nil
"Copy '~A' to frame numbered:" (child-name *current-child
*)))))
506 (defun show-all-frames-info ()
507 "Show all frames info windows"
508 (let ((*show-root-frame-p
* t
))
510 (with-all-frames (*current-root
* frame
)
511 (raise-window (frame-window frame
))
512 (display-frame-info frame
))))
514 (defun hide-all-frames-info ()
515 "Hide all frames info windows"
516 (with-all-windows (*current-root
* window
)
517 (raise-window window
))
518 (hide-child *current-root
*)
521 (defun show-all-frames-info-key ()
522 "Show all frames info windows until a key is release"
523 (show-all-frames-info)
524 (wait-no-key-or-button-press)
525 (hide-all-frames-info))
532 (defun move-frame (frame parent orig-x orig-y
)
533 (when (and frame parent
)
534 (hide-all-children frame
)
535 (with-slots (window) frame
536 (move-window window orig-x orig-y
#'display-frame-info
(list frame
))
537 (setf (frame-x frame
) (x-px->fl
(xlib:drawable-x window
) parent
)
538 (frame-y frame
) (y-px->fl
(xlib:drawable-y window
) parent
)))
539 (show-all-children frame
)))
542 (defun resize-frame (frame parent orig-x orig-y
)
543 (when (and frame parent
)
544 (hide-all-children frame
)
545 (with-slots (window) frame
546 (resize-window window orig-x orig-y
#'display-frame-info
(list frame
))
547 (setf (frame-w frame
) (w-px->fl
(xlib:drawable-width window
) parent
)
548 (frame-h frame
) (h-px->fl
(xlib:drawable-height window
) parent
)))
549 (show-all-children frame
)))
553 (defun mouse-click-to-focus-generic (window root-x root-y mouse-fn
)
554 "Focus the current frame or focus the current window parent
555 mouse-fun is #'move-frame or #'resize-frame"
557 (child (find-child-under-mouse root-x root-y
))
558 (parent (find-parent-frame child
))
559 (root-p (or (child-equal-p window
*root
*)
560 (and (frame-p *current-root
*)
561 (child-equal-p child
(frame-window *current-root
*))))))
562 (labels ((add-new-frame ()
563 (setf child
(create-frame)
564 parent
*current-root
*
565 mouse-fn
#'resize-frame
)
566 (place-frame child parent root-x root-y
10 10)
567 (map-window (frame-window child
))
568 (pushnew child
(frame-child *current-root
*))))
569 (when (or (not root-p
) *create-frame-on-root
*)
574 (unless (equal (type-of child
) 'frame
)
575 (setf child
(find-frame-window child
*current-root
*)))
576 (setf parent
(find-parent-frame child
)))))
577 (when (equal (type-of child
) 'frame
)
578 (funcall mouse-fn child parent root-x root-y
))
579 (when (and child parent
(focus-all-children child parent
))
580 (when (show-all-children *current-root
*)
581 (setf to-replay nil
))))
583 (replay-button-event)
584 (stop-button-event)))))
587 (defun mouse-click-to-focus-and-move (window root-x root-y
)
588 "Move and focus the current frame or focus the current window parent.
589 Or do actions on corners"
590 (or (do-corner-action root-x root-y
*corner-main-mode-left-button
*)
591 (mouse-click-to-focus-generic window root-x root-y
#'move-frame
)))
593 (defun mouse-click-to-focus-and-resize (window root-x root-y
)
594 "Resize and focus the current frame or focus the current window parent.
595 Or do actions on corners"
596 (or (do-corner-action root-x root-y
*corner-main-mode-right-button
*)
597 (mouse-click-to-focus-generic window root-x root-y
#'resize-frame
)))
599 (defun mouse-middle-click (window root-x root-y
)
600 "Do actions on corners"
601 (declare (ignore window
))
602 (or (do-corner-action root-x root-y
*corner-main-mode-middle-button
*)
603 (replay-button-event)))
608 (defun mouse-focus-move/resize-generic
(root-x root-y mouse-fn window-parent
)
609 "Focus the current frame or focus the current window parent
610 mouse-fun is #'move-frame or #'resize-frame.
611 Focus child and its parents -
612 For window: set current child to window or its parent according to window-parent"
613 (let* ((child (find-child-under-mouse root-x root-y
))
614 (parent (find-parent-frame child
)))
615 (when (and (child-equal-p child
*current-root
*)
616 (frame-p *current-root
*))
617 (setf child
(create-frame)
618 parent
*current-root
*
619 mouse-fn
#'resize-frame
)
620 (place-frame child parent root-x root-y
10 10)
621 (map-window (frame-window child
))
622 (pushnew child
(frame-child *current-root
*)))
625 (if (managed-window-p child parent
)
626 (funcall mouse-fn parent
(find-parent-frame parent
) root-x root-y
)
627 (funcall(cond ((eql mouse-fn
#'move-frame
) #'move-window
)
628 ((eql mouse-fn
#'resize-frame
) #'resize-window
))
629 child root-x root-y
)))
630 (frame (funcall mouse-fn child parent root-x root-y
)))
631 (focus-all-children child parent window-parent
)
632 (show-all-children *current-root
*)))
637 (defun test-mouse-binding (window root-x root-y
)
638 (dbg window root-x root-y
)
639 (replay-button-event))
643 (defun mouse-select-next-level (window root-x root-y
)
644 "Select the next level in frame"
645 (declare (ignore root-x root-y
))
646 (let ((frame (find-frame-window window
)))
647 (when (or frame
(xlib:window-equal window
*root
*))
649 (replay-button-event)))
653 (defun mouse-select-previous-level (window root-x root-y
)
654 "Select the previous level in frame"
655 (declare (ignore root-x root-y
))
656 (let ((frame (find-frame-window window
)))
657 (when (or frame
(xlib:window-equal window
*root
*))
658 (select-previous-level))
659 (replay-button-event)))
663 (defun mouse-enter-frame (window root-x root-y
)
664 "Enter in the selected frame - ie make it the root frame"
665 (declare (ignore root-x root-y
))
666 (let ((frame (find-frame-window window
)))
667 (when (or frame
(xlib:window-equal window
*root
*))
669 (replay-button-event)))
673 (defun mouse-leave-frame (window root-x root-y
)
674 "Leave the selected frame - ie make its parent the root frame"
675 (declare (ignore root-x root-y
))
676 (let ((frame (find-frame-window window
)))
677 (when (or frame
(xlib:window-equal window
*root
*))
679 (replay-button-event)))
684 ;;;;;| Various definitions
687 (defun show-help (&optional
(browser "dillo") (tempfile "/tmp/clfswm.html"))
688 "Show current keys and buttons bindings"
690 (produce-doc-html-in-file tempfile
))
692 (do-shell (format nil
"~A ~A" browser tempfile
)))
696 ;;; Bind or jump functions
697 (let ((key-slots (make-array 10 :initial-element nil
))
699 (defun bind-on-slot ()
700 "Bind current child to slot"
701 (setf (aref key-slots current-slot
) *current-child
*))
703 (defun remove-binding-on-slot ()
704 "Remove binding on slot"
705 (setf (aref key-slots current-slot
) nil
))
707 (defun jump-to-slot ()
709 (let ((jump-child (aref key-slots current-slot
)))
710 (when (find-child jump-child
*root-frame
*)
711 (hide-all *current-root
*)
712 (setf *current-root
* jump-child
713 *current-child
* *current-root
*)
714 (focus-all-children *current-child
* *current-child
*)
715 (show-all-children *current-root
*))))
717 (defun bind-or-jump (n)
718 "Bind or jump to a slot (a frame or a window)"
719 (setf current-slot
(- n
1))
720 (let ((default-bind `("b" bind-on-slot
721 ,(format nil
"Bind slot ~A on child: ~A" n
(child-fullname *current-child
*)))))
722 (info-mode-menu (aif (aref key-slots current-slot
)
724 ("BackSpace" remove-binding-on-slot
725 ,(format nil
"Remove slot ~A binding on child: ~A" n
(child-fullname *current-child
*)))
728 ,(format nil
"Jump to child: ~A" (aif (aref key-slots current-slot
)
730 "Not set - Please, bind it with 'b'")))
731 ("Return" jump-to-slot
"Same thing")
732 ("space" jump-to-slot
"Same thing"))
733 (list default-bind
))))))
737 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
738 ;;; Useful function for the second mode ;;;
739 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
740 (defmacro with-movement
(&body body
)
741 `(when (frame-p *current-child
*)
744 (display-all-frame-info)
745 (draw-second-mode-window)
746 (open-menu (find-menu 'frame-movement-menu
))))
750 (defun current-frame-pack-up ()
751 "Pack the current frame up"
752 (with-movement (pack-frame-up *current-child
* (find-parent-frame *current-child
* *current-root
*))))
754 (defun current-frame-pack-down ()
755 "Pack the current frame down"
756 (with-movement (pack-frame-down *current-child
* (find-parent-frame *current-child
* *current-root
*))))
758 (defun current-frame-pack-left ()
759 "Pack the current frame left"
760 (with-movement (pack-frame-left *current-child
* (find-parent-frame *current-child
* *current-root
*))))
762 (defun current-frame-pack-right ()
763 "Pack the current frame right"
764 (with-movement (pack-frame-right *current-child
* (find-parent-frame *current-child
* *current-root
*))))
767 (defun center-current-frame ()
768 "Center the current frame"
769 (with-movement (center-frame *current-child
*)))
772 (defun current-frame-fill-up ()
773 "Fill the current frame up"
774 (with-movement (fill-frame-up *current-child
* (find-parent-frame *current-child
* *current-root
*))))
776 (defun current-frame-fill-down ()
777 "Fill the current frame down"
778 (with-movement (fill-frame-down *current-child
* (find-parent-frame *current-child
* *current-root
*))))
780 (defun current-frame-fill-left ()
781 "Fill the current frame left"
782 (with-movement (fill-frame-left *current-child
* (find-parent-frame *current-child
* *current-root
*))))
784 (defun current-frame-fill-right ()
785 "Fill the current frame right"
786 (with-movement (fill-frame-right *current-child
* (find-parent-frame *current-child
* *current-root
*))))
788 (defun current-frame-fill-all-dir ()
789 "Fill the current frame in all directions"
791 (let ((parent (find-parent-frame *current-child
* *current-root
*)))
792 (fill-frame-up *current-child
* parent
)
793 (fill-frame-down *current-child
* parent
)
794 (fill-frame-left *current-child
* parent
)
795 (fill-frame-right *current-child
* parent
))))
797 (defun current-frame-fill-vertical ()
798 "Fill the current frame vertically"
800 (let ((parent (find-parent-frame *current-child
* *current-root
*)))
801 (fill-frame-up *current-child
* parent
)
802 (fill-frame-down *current-child
* parent
))))
804 (defun current-frame-fill-horizontal ()
805 "Fill the current frame horizontally"
807 (let ((parent (find-parent-frame *current-child
* *current-root
*)))
808 (fill-frame-left *current-child
* parent
)
809 (fill-frame-right *current-child
* parent
))))
813 (defun current-frame-resize-up ()
814 "Resize the current frame up to its half height"
815 (with-movement (resize-half-height-up *current-child
*)))
817 (defun current-frame-resize-down ()
818 "Resize the current frame down to its half height"
819 (with-movement (resize-half-height-down *current-child
*)))
821 (defun current-frame-resize-left ()
822 "Resize the current frame left to its half width"
823 (with-movement (resize-half-width-left *current-child
*)))
825 (defun current-frame-resize-right ()
826 "Resize the current frame right to its half width"
827 (with-movement (resize-half-width-right *current-child
*)))
829 (defun current-frame-resize-all-dir ()
830 "Resize down the current frame"
831 (with-movement (resize-frame-down *current-child
*)))
833 (defun current-frame-resize-all-dir-minimal ()
834 "Resize down the current frame to its minimal size"
835 (with-movement (resize-minimal-frame *current-child
*)))
838 ;;; Children navigation
839 (defun with-movement-select-next-brother ()
840 "Select the next brother frame"
841 (with-movement (select-next-brother)))
843 (defun with-movement-select-previous-brother ()
844 "Select the previous brother frame"
845 (with-movement (select-previous-brother)))
847 (defun with-movement-select-next-level ()
848 "Select the next level"
849 (with-movement (select-next-level)))
851 (defun with-movement-select-previous-level ()
852 "Select the previous levelframe"
853 (with-movement (select-previous-level)))
855 (defun with-movement-select-next-child ()
856 "Select the next child"
857 (with-movement (select-next-child)))
861 ;;; Adapt frame functions
862 (defun adapt-current-frame-to-window-hints-generic (width-p height-p
)
863 "Adapt the current frame to the current window minimal size hints"
864 (when (frame-p *current-child
*)
865 (let ((window (first (frame-child *current-child
*))))
866 (when (xlib:window-p window
)
867 (let* ((hints (xlib:wm-normal-hints window
))
868 (min-width (and hints
(xlib:wm-size-hints-min-width hints
)))
869 (min-height (and hints
(xlib:wm-size-hints-min-height hints
))))
870 (when (and width-p min-width
)
871 (setf (frame-rw *current-child
*) min-width
))
872 (when (and height-p min-height
)
873 (setf (frame-rh *current-child
*) min-height
))
874 (fixe-real-size *current-child
* (find-parent-frame *current-child
*))
875 (leave-second-mode))))))
877 (defun adapt-current-frame-to-window-hints ()
878 "Adapt the current frame to the current window minimal size hints"
879 (adapt-current-frame-to-window-hints-generic t t
))
881 (defun adapt-current-frame-to-window-width-hint ()
882 "Adapt the current frame to the current window minimal width hint"
883 (adapt-current-frame-to-window-hints-generic t nil
))
885 (defun adapt-current-frame-to-window-height-hint ()
886 "Adapt the current frame to the current window minimal height hint"
887 (adapt-current-frame-to-window-hints-generic nil t
))
892 ;;; Managed window type functions
893 (defun current-frame-manage-window-type-generic (type-list)
894 (when (frame-p *current-child
*)
895 (setf (frame-managed-type *current-child
*) type-list
896 (frame-forced-managed-window *current-child
*) nil
897 (frame-forced-unmanaged-window *current-child
*) nil
))
901 (defun current-frame-manage-window-type ()
902 "Change window types to be managed by a frame"
903 (when (frame-p *current-child
*)
904 (let* ((type-str (query-string "Managed window type: (all, normal, transient, maxsize, desktop, dock, toolbar, menu, utility, splash, dialog)"
905 (format nil
"~{~:(~A~) ~}" (frame-managed-type *current-child
*))))
906 (type-list (loop :for type
:in
(split-string type-str
)
907 :collect
(intern (string-upcase type
) :keyword
))))
908 (current-frame-manage-window-type-generic type-list
))))
911 (defun current-frame-manage-all-window-type ()
912 "Manage all window type"
913 (current-frame-manage-window-type-generic '(:all
)))
915 (defun current-frame-manage-only-normal-window-type ()
916 "Manage only normal window type"
917 (current-frame-manage-window-type-generic '(:normal
)))
919 (defun current-frame-manage-no-window-type ()
920 "Do not manage any window type"
921 (current-frame-manage-window-type-generic nil
))
930 ;;; Force window functions
931 (defun force-window-in-frame ()
932 "Force the current window to move in the frame (Useful only for unmanaged windows)"
934 (let ((parent (find-parent-frame window
)))
936 (setf (xlib:drawable-x window
) (frame-rx parent
)
937 (xlib:drawable-y window
) (frame-ry parent
)))))
941 (defun force-window-center-in-frame ()
942 "Force the current window to move in the center of the frame (Useful only for unmanaged windows)"
944 (let ((parent (find-parent-frame window
)))
946 (setf (xlib:drawable-x window
) (truncate (+ (frame-rx parent
)
947 (/ (- (frame-rw parent
)
948 (xlib:drawable-width window
)) 2)))
949 (xlib:drawable-y window
) (truncate (+ (frame-ry parent
)
950 (/ (- (frame-rh parent
)
951 (xlib:drawable-height window
)) 2)))))))
956 (defun display-current-window-info ()
957 "Display information on the current window"
959 (info-mode (list (format nil
"Window: ~A" window
)
960 (format nil
"Window name: ~A" (xlib:wm-name window
))
961 (format nil
"Window class: ~A" (xlib:get-wm-class window
))
962 (format nil
"Window type: ~:(~A~)" (window-type window
))
963 (format nil
"Window id: 0x~X" (xlib:window-id window
)))))
967 (defun manage-current-window ()
968 "Force to manage the current window by its parent frame"
970 (let ((parent (find-parent-frame window
)))
971 (with-slots ((managed forced-managed-window
)
972 (unmanaged forced-unmanaged-window
)) parent
973 (setf unmanaged
(remove window unmanaged
:test
#'child-equal-p
)
974 unmanaged
(remove (xlib:wm-name window
) unmanaged
:test
#'string-equal-p
))
975 (pushnew window managed
))))
978 (defun unmanage-current-window ()
979 "Force to not manage the current window by its parent frame"
981 (let ((parent (find-parent-frame window
)))
982 (with-slots ((managed forced-managed-window
)
983 (unmanaged forced-unmanaged-window
)) parent
984 (setf managed
(remove window managed
:test
#'child-equal-p
)
985 managed
(remove (xlib:wm-name window
) managed
:test
#'string-equal-p
))
986 (pushnew window unmanaged
))))
991 ;;; Moving child with the mouse button
992 (defun mouse-move-child-over-frame (window root-x root-y
)
993 "Move the child under the mouse cursor to another frame"
994 (declare (ignore window
))
995 (let ((child (find-child-under-mouse root-x root-y
)))
996 (unless (child-equal-p child
*current-root
*)
998 (remove-child-in-frame child
(find-parent-frame child
))
999 (wait-mouse-button-release 50 51)
1000 (multiple-value-bind (x y
)
1001 (xlib:query-pointer
*root
*)
1002 (let ((dest (find-child-under-mouse x y
)))
1003 (when (xlib:window-p dest
)
1004 (setf dest
(find-parent-frame dest
)))
1005 (unless (child-equal-p child dest
)
1006 (move-child-to child dest
)
1007 (show-all-children *current-root
*))))))
1008 (stop-button-event))
1013 ;;; Hide/Show frame window functions
1014 (defun hide/show-frame-window
(frame value
)
1015 "Hide/show the frame window"
1016 (when (frame-p frame
)
1017 (setf (frame-show-window-p *current-child
*) value
)
1018 (show-all-children *current-root
*))
1019 (leave-second-mode))
1022 (defun hide-current-frame-window ()
1023 "Hide the current frame window"
1024 (hide/show-frame-window
*current-child
* nil
))
1026 (defun show-current-frame-window ()
1027 "Show the current frame window"
1028 (hide/show-frame-window
*current-child
* t
))
1032 ;;; Hide/Unhide current child
1033 (defun hide-current-child ()
1034 "Hide the current child"
1035 (let ((parent (find-parent-frame *current-child
*)))
1036 (when (frame-p parent
)
1037 (with-slots (child hidden-children
) parent
1038 (hide-all *current-child
*)
1039 (setf child
(remove *current-child
* child
:test
#'child-equal-p
))
1040 (pushnew *current-child
* hidden-children
)
1041 (setf *current-child
* parent
))
1042 (show-all-children)))
1043 (leave-second-mode))
1046 (defun frame-unhide-child (hidden frame-src frame-dest
)
1047 "Unhide a hidden child from frame-src in frame-dest"
1048 (with-slots (hidden-children) frame-src
1049 (setf hidden-children
(remove hidden hidden-children
:test
#'child-equal-p
)))
1050 (with-slots (child) frame-dest
1051 (pushnew hidden child
)))
1055 (defun unhide-a-child ()
1056 "Unhide a child in the current frame"
1057 (when (frame-p *current-child
*)
1058 (with-slots (child hidden-children
) *current-child
*
1059 (info-mode-menu (loop :for i
:from
0
1060 :for hidden
:in hidden-children
1061 :collect
(list (code-char (+ (char-code #\a) i
))
1064 (frame-unhide-child lhd
*current-child
* *current-child
*)))
1065 (format nil
"Unhide ~A" (child-fullname hidden
))))))
1066 (show-all-children))
1067 (leave-second-mode))
1070 (defun unhide-all-children ()
1071 "Unhide all current frame hidden children"
1072 (when (frame-p *current-child
*)
1073 (with-slots (child hidden-children
) *current-child
*
1074 (dolist (c hidden-children
)
1076 (setf hidden-children nil
))
1077 (show-all-children))
1078 (leave-second-mode))
1081 (defun unhide-a-child-from-all-frames ()
1082 "Unhide a child from all frames in the current frame"
1083 (when (frame-p *current-child
*)
1086 (with-all-frames (*root-frame
* frame
)
1087 (when (frame-hidden-children frame
)
1088 (push (format nil
"~A" (child-fullname frame
)) acc
)
1089 (dolist (hidden (frame-hidden-children frame
))
1090 (push (list (code-char (+ (char-code #\a) (incf keynum
)))
1093 (frame-unhide-child lhd frame
*current-child
*)))
1094 (format nil
"Unhide ~A" (child-fullname hidden
)))
1096 (info-mode-menu (nreverse acc
)))
1097 (show-all-children))
1098 (leave-second-mode))
1104 (let ((last-child nil
))
1105 (defun init-last-child ()
1106 (setf last-child nil
))
1107 (defun switch-to-last-child ()
1108 "Store the current child and switch to the previous one"
1109 (let ((current-child *current-child
*))
1111 (hide-all *current-root
*)
1112 (setf *current-root
* last-child
1113 *current-child
* *current-root
*)
1114 (focus-all-children *current-child
* *current-child
*)
1115 (show-all-children *current-root
*))
1116 (setf last-child current-child
))))
1124 ;;; Focus policy functions
1125 (defun set-focus-policy-generic (focus-policy)
1126 (when (frame-p *current-child
*)
1127 (setf (frame-focus-policy *current-child
*) focus-policy
))
1128 (leave-second-mode))
1131 (defun current-frame-set-click-focus-policy ()
1132 "Set a click focus policy for the current frame."
1133 (set-focus-policy-generic :click
))
1135 (defun current-frame-set-sloppy-focus-policy ()
1136 "Set a sloppy focus policy for the current frame."
1137 (set-focus-policy-generic :sloppy
))
1139 (defun current-frame-set-sloppy-strict-focus-policy ()
1140 "Set a (strict) sloppy focus policy only for windows in the current frame."
1141 (set-focus-policy-generic :sloppy-strict
))
1143 (defun current-frame-set-sloppy-select-policy ()
1144 "Set a sloppy select policy for the current frame."
1145 (set-focus-policy-generic :sloppy-select
))
1149 (defun set-focus-policy-generic-for-all (focus-policy)
1150 (with-all-frames (*root-frame
* frame
)
1151 (setf (frame-focus-policy frame
) focus-policy
))
1152 (leave-second-mode))
1155 (defun all-frames-set-click-focus-policy ()
1156 "Set a click focus policy for all frames."
1157 (set-focus-policy-generic-for-all :click
))
1159 (defun all-frames-set-sloppy-focus-policy ()
1160 "Set a sloppy focus policy for all frames."
1161 (set-focus-policy-generic-for-all :sloppy
))
1163 (defun all-frames-set-sloppy-strict-focus-policy ()
1164 "Set a (strict) sloppy focus policy for all frames."
1165 (set-focus-policy-generic-for-all :sloppy-strict
))
1167 (defun all-frames-set-sloppy-select-policy ()
1168 "Set a sloppy select policy for all frames."
1169 (set-focus-policy-generic-for-all :sloppy-select
))
1173 ;;; Ensure unique name/number functions
1174 (defun extract-number-from-name (name)
1175 (when (stringp name
)
1176 (let* ((pos (1+ (or (position #\. name
:from-end t
) -
1)))
1177 (number (parse-integer name
:junk-allowed t
:start pos
)))
1179 (if number
(subseq name
0 (1- pos
)) name
)))))
1184 (defun ensure-unique-name ()
1185 "Ensure that all children names are unique"
1186 (with-all-children (*root-frame
* child
)
1187 (multiple-value-bind (num1 name1
)
1188 (extract-number-from-name (child-name child
))
1189 (declare (ignore num1
))
1192 (with-all-children (*root-frame
* c
)
1193 (unless (child-equal-p child c
))
1194 (multiple-value-bind (num2 name2
)
1195 (extract-number-from-name (child-name c
))
1196 (when (string-equal name1 name2
)
1199 (when (> (length acc
) 1)
1200 (setf (child-name child
)
1201 (format nil
"~A.~A" name1
1202 (1+ (find-free-number (loop for i in acc when i collect
(1- i
)))))))))))
1203 (leave-second-mode))
1205 (defun ensure-unique-number ()
1206 "Ensure that all children numbers are unique"
1208 (with-all-frames (*root-frame
* frame
)
1209 (setf (frame-number frame
) (incf num
))))
1210 (leave-second-mode))
1214 ;;; Standard menu functions - Based on the 'update-menus' command
1215 (defun um-extract-value (name line
)
1216 (let* ((fullname (format nil
"~A=\"" name
))
1217 (pos (search fullname line
)))
1219 (let* ((start (+ pos
(length fullname
)))
1220 (end (position #\" line
:start start
)))
1222 (subseq line start end
))))))
1225 (defun um-create-section (menu section-list
)
1227 (let* ((sec (intern (string-upcase (first section-list
)) :clfswm
))
1228 (submenu (find-menu sec menu
)))
1230 (um-create-section submenu
(rest section-list
))
1232 (add-sub-menu (menu-name menu
) :next sec
(format nil
"~A" sec
) menu
)
1233 (um-create-section (find-menu sec menu
) (rest section-list
)))))
1237 (defun update-menus (&optional
(menu (make-menu :name
'main
:doc
"Main menu")))
1238 (let ((output (do-shell "update-menus --stdout")))
1239 (loop for line
= (read-line output nil nil
)
1241 do
(let ((command (um-extract-value "command" line
)))
1243 (let* ((sub-menu (um-create-section menu
(split-string (um-extract-value "section" line
) #\
/)))
1244 (title (um-extract-value " title" line
))
1245 (doc (um-extract-value "description" line
))
1246 (name (intern title
:clfswm
)))
1247 (setf (symbol-function name
) (lambda ()
1249 (leave-second-mode))
1250 (documentation name
'function
) (format nil
"~A~A" title
(if doc
(format nil
" - ~A" doc
) "")))
1251 (add-menu-key (menu-name sub-menu
) :next name sub-menu
)))))
1255 (defun show-standard-menu ()
1257 (let ((menu (update-menus)))
1258 (if (menu-item menu
)
1260 (info-mode '("Command 'update-menus' not found")))))
1264 ;;; Close/Kill focused window
1266 (defun ask-close/kill-current-window
()
1267 "Close or kill the current window (ask before doing anything)"
1268 (let ((window (xlib:input-focus
*display
*)))
1270 (if (and window
(not (xlib:window-equal window
*no-focus-window
*)))
1271 `(,(format nil
"Focus window: ~A" (xlib:wm-name window
))
1272 (#\c delete-focus-window
"Close the focus window")
1273 (#\k destroy-focus-window
"Kill the focus window")
1274 (#\r remove-focus-window
)
1275 (#\u unhide-all-windows-in-current-child
))
1276 `(,(format nil
"Focus window: None")
1277 (#\u unhide-all-windows-in-current-child
))))))
1281 ;;; Other window manager functions
1282 (defun get-proc-list ()
1283 (let ((proc (do-shell "ps x -o pid=" nil nil
))
1286 (loop for line
= (read-line proc nil nil
)
1288 do
(push line proc-list
))
1292 (defun run-other-window-manager ()
1293 (let ((proc-start (get-proc-list)))
1294 (do-shell *other-window-manager
* nil t
)
1295 (let* ((proc-end (get-proc-list))
1296 (proc-diff (set-difference proc-end proc-start
:test
#'equal
)))
1298 (dolist (proc proc-diff
)
1299 (dbg 'killing-sigterm proc
)
1300 (do-shell (format nil
"kill ~A 2> /dev/null" proc
) nil t
))
1302 (dolist (proc proc-diff
)
1303 (dbg 'killing-sigkill proc
)
1304 (do-shell (format nil
"kill -9 ~A 2> /dev/null" proc
) nil t
)))
1305 (setf *other-window-manager
* nil
)))
1308 (defun do-run-other-window-manager (window-manager)
1309 (setf *other-window-manager
* window-manager
)
1310 (throw 'exit-main-loop nil
))
1312 (defmacro def-run-other-window-manager
(name &optional definition
)
1313 (let ((definition (or definition name
)))
1314 `(defun ,(create-symbol "run-" name
) ()
1315 ,(format nil
"Run ~A" definition
)
1316 (do-run-other-window-manager ,(format nil
"~A" name
)))))
1318 (def-run-other-window-manager "xterm")
1319 (def-run-other-window-manager "icewm")
1320 (def-run-other-window-manager "twm")
1321 (def-run-other-window-manager "gnome-session" "Gnome")
1322 (def-run-other-window-manager "startkde" "KDE")
1323 (def-run-other-window-manager "xfce4-session" "XFCE")
1327 (do-run-other-window-manager "lxsession; xterm -e \"echo ' /----------------------------------\\' ; echo ' | CLFSWM Note: |' ; echo ' | Close this window when done. |' ; echo ' \\----------------------------------/'; echo; echo; $SHELL\""))
1330 (defun run-prompt-wm ()
1331 "Prompt for an other window manager"
1332 (let ((wm (query-string "Run an other window manager:" "icewm")))
1333 (do-run-other-window-manager wm
)))