src/clfswm-util.lisp

   1 ;;; --------------------------------------------------------------------------
   2 ;;; CLFSWM - FullScreen Window Manager
   3 ;;;
   4 ;;; --------------------------------------------------------------------------
   5 ;;; Documentation: Utility
   6 ;;; --------------------------------------------------------------------------
   7 ;;;
   8 ;;; (C) 2011 Philippe Brochard <hocwp@free.fr>
   9 ;;;
  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.
  14 ;;;
  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.
  19 ;;;
  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.
  23 ;;;
  24 ;;; --------------------------------------------------------------------------
  25
  26 (in-package :clfswm)
  27
  28
  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"))))
  34
  35
  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"))
  42                                                           :name "clfswmrc")))
  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)
  46     saved-conf-name))
  47
  48
  49
  50
  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     (when (probe-file truename)
  56       (load truename :verbose nil))))
  57
  58
  59 (defun reload-clfswm ()
  60   "Reload clfswm"
  61   (format t "~&-*- Reloading CLFSWM -*-~%")
  62   (asdf:oos 'asdf:load-op :clfswm)
  63   (reset-clfswm))
  64
  65
  66
  67 (defun query-yes-or-no (formatter &rest args)
  68   (let ((rep (query-string (apply #'format nil formatter args) "" '("yes" "no"))))
  69     (or (string= rep "")
  70         (char= (char rep 0) #\y)
  71         (char= (char rep 0) #\Y))))
  72
  73
  74
  75 (defun banish-pointer ()
  76   "Move the pointer to the lower right corner of the screen"
  77   (with-placement (*banish-pointer-placement* x y)
  78     (xlib:warp-pointer *root* x y)))
  79
  80
  81
  82
  83 ;;; Root functions utility
  84 (defun select-generic-root (fun restart-menu)
  85   (no-focus)
  86   (let* ((current-root (find-root (current-child)))
  87          (parent (find-parent-frame (root-original current-root))))
  88     (when parent
  89       (setf (frame-child parent) (funcall fun (frame-child parent)))
  90       (let ((new-root (find-root (frame-selected-child parent))))
  91         (setf (current-child) (aif (root-current-child new-root)
  92                                    it
  93                                    (frame-selected-child parent))))))
  94   (show-all-children t)
  95   (if restart-menu
  96       (open-menu (find-menu 'root-menu))
  97       (leave-second-mode)))
  98
  99 (defun select-next-root ()
 100   "Select the next root"
 101   (select-generic-root #'rotate-list nil))
 102
 103 (defun select-previous-root ()
 104   "Select the previous root"
 105   (select-generic-root #'anti-rotate-list nil))
 106
 107
 108 (defun select-next-root-restart-menu ()
 109   "Select the next root"
 110   (select-generic-root #'rotate-list t))
 111
 112 (defun select-previous-root-restart-menu ()
 113   "Select the previous root"
 114   (select-generic-root #'anti-rotate-list t))
 115
 116
 117 (defun rotate-root-geometry-generic (fun restart-menu)
 118   (no-focus)
 119   (funcall fun)
 120   (show-all-children t)
 121   (if restart-menu
 122       (open-menu (find-menu 'root-menu))
 123       (leave-second-mode)))
 124
 125
 126 (defun rotate-root-geometry-next ()
 127   "Rotate root geometry to next root"
 128   (rotate-root-geometry-generic #'rotate-root-geometry nil))
 129
 130 (defun rotate-root-geometry-previous ()
 131   "Rotate root geometry to previous root"
 132   (rotate-root-geometry-generic #'anti-rotate-root-geometry nil))
 133
 134 (defun rotate-root-geometry-next-restart-menu ()
 135   "Rotate root geometry to next root"
 136   (rotate-root-geometry-generic #'rotate-root-geometry t))
 137
 138 (defun rotate-root-geometry-previous-restart-menu ()
 139   "Rotate root geometry to previous root"
 140   (rotate-root-geometry-generic #'anti-rotate-root-geometry t))
 141
 142
 143
 144 (defun exchange-root-geometry-with-mouse ()
 145   "Exchange two root geometry pointed with the mouse"
 146   (open-notify-window '("Select the first root to exchange"))
 147   (wait-no-key-or-button-press)
 148   (wait-mouse-button-release)
 149   (close-notify-window)
 150   (multiple-value-bind (x1 y1) (xlib:query-pointer *root*)
 151     (open-notify-window '("Select the second root to exchange"))
 152     (wait-no-key-or-button-press)
 153     (wait-mouse-button-release)
 154     (close-notify-window)
 155     (multiple-value-bind (x2 y2) (xlib:query-pointer *root*)
 156       (exchange-root-geometry (find-root-by-coordinates x1 y1)
 157                               (find-root-by-coordinates x2 y2))))
 158   (show-all-children)
 159   (leave-second-mode))
 160
 161 (defun change-current-root-geometry ()
 162   "Change the current root geometry"
 163   (let* ((root (find-root (current-child)))
 164          (x (query-number "New root X position" (root-x root)))
 165          (y (query-number "New root Y position" (root-y root)))
 166          (w (query-number "New root width" (root-w root)))
 167          (h (query-number "New root height" (root-h root))))
 168     (setf (root-x root) x  (root-y root) y
 169           (root-w root) w  (root-h root) h)
 170     (show-all-children)
 171     (leave-second-mode)))
 172
 173
 174
 175 (defun place-window-from-hints (window)
 176   "Place a window from its hints"
 177   (let* ((hints (xlib:wm-normal-hints window))
 178          (min-width (or (and hints (xlib:wm-size-hints-min-width hints)) 0))
 179          (min-height (or (and hints (xlib:wm-size-hints-min-height hints)) 0))
 180          (max-width (or (and hints (xlib:wm-size-hints-max-width hints)) (x-drawable-width *root*)))
 181          (max-height (or (and hints (xlib:wm-size-hints-max-height hints)) (x-drawable-height *root*)))
 182          (rwidth (or (and hints (or (xlib:wm-size-hints-width hints) (xlib:wm-size-hints-base-width hints)))
 183                      (x-drawable-width window)))
 184          (rheight (or (and hints (or (xlib:wm-size-hints-height hints) (xlib:wm-size-hints-base-height hints)))
 185                       (x-drawable-height window))))
 186     (setf (x-drawable-width window) (min (max min-width rwidth *default-window-width*) max-width)
 187           (x-drawable-height window) (min (max min-height rheight *default-window-height*) max-height))
 188     (with-placement (*unmanaged-window-placement* x y (x-drawable-width window) (x-drawable-height window))
 189       (setf (x-drawable-x window) x
 190             (x-drawable-y window) y))
 191     (xlib:display-finish-output *display*)))
 192
 193
 194 (defun rename-current-child ()
 195   "Rename the current child"
 196   (let ((name (query-string (format nil "New child name: (last: ~A)" (child-name (current-child)))
 197                             (child-name (current-child)))))
 198     (rename-child (current-child) name)
 199     (leave-second-mode)))
 200
 201
 202 (defun ask-child-transparency (msg child)
 203   (let ((trans (query-number (format nil "New ~A transparency: (last: ~A)"
 204                                      msg
 205                                      (* 100 (child-transparency child)))
 206                              (* 100 (child-transparency child)))))
 207     (when (numberp trans)
 208       (setf (child-transparency child) (float (/ trans 100))))))
 209
 210 (defun set-current-child-transparency ()
 211   "Set the current child transparency"
 212   (ask-child-transparency "child" (current-child))
 213   (leave-second-mode))
 214
 215
 216 (defun ask-child-border-size (msg child)
 217   (let ((size (query-number (format nil "New ~A border size: (last: ~A)"
 218                                     msg
 219                                     (child-border-size child))
 220                             (child-border-size child))))
 221     (when (numberp size)
 222       (setf (child-border-size child) size))))
 223
 224
 225 (defun set-current-child-border-size ()
 226   "Set the current child border size"
 227   (ask-child-border-size "child" (current-child))
 228   (leave-second-mode))
 229
 230
 231 (defun renumber-current-frame ()
 232   "Renumber the current frame"
 233   (when (frame-p (current-child))
 234     (let ((number (query-number (format nil "New child number: (last: ~A)" (frame-number (current-child)))
 235                                 (frame-number (current-child)))))
 236       (setf (frame-number (current-child)) number)
 237       (leave-second-mode))))
 238
 239
 240
 241
 242 (defun add-default-frame ()
 243   "Add a default frame in the current frame"
 244   (when (frame-p (current-child))
 245     (let ((name (query-string "Frame name")))
 246       (push (create-frame :name name) (frame-child (current-child)))))
 247   (leave-second-mode))
 248
 249 (defun add-frame-in-parent-frame ()
 250   "Add a frame in the parent frame (and reorganize parent frame)"
 251   (let ((parent (find-parent-frame (current-child))))
 252     (when (and parent (not (child-original-root-p (current-child))))
 253       (let ((new-frame (create-frame)))
 254         (pushnew new-frame (frame-child parent))
 255         (awhen (child-root-p (current-child))
 256           (change-root it parent))
 257         (setf (current-child) parent)
 258         (set-layout-once #'tile-space-layout)
 259         (setf (current-child) new-frame)
 260         (leave-second-mode)))))
 261
 262
 263
 264
 265 (defun add-placed-frame ()
 266   "Add a placed frame in the current frame"
 267   (when (frame-p (current-child))
 268     (let ((name (query-string "Frame name"))
 269           (x (/ (query-number "Frame x in percent (%)") 100))
 270           (y (/ (query-number "Frame y in percent (%)") 100))
 271           (w (/ (query-number "Frame width in percent (%)" 100) 100))
 272           (h (/ (query-number "Frame height in percent (%)" 100) 100)))
 273       (push (create-frame :name name :x x :y y :w w :h h)
 274             (frame-child (current-child)))))
 275   (leave-second-mode))
 276
 277
 278
 279 (defun delete-focus-window-generic (close-fun)
 280   (with-focus-window (window)
 281     (when (child-equal-p window (current-child))
 282       (setf (current-child) (find-current-root)))
 283     (delete-child-and-children-in-all-frames window close-fun)))
 284
 285 (defun delete-focus-window ()
 286   "Close focus window: Delete the focus window in all frames and workspaces"
 287   (delete-focus-window-generic 'delete-window))
 288
 289 (defun destroy-focus-window ()
 290   "Kill focus window: Destroy the focus window in all frames and workspaces"
 291   (delete-focus-window-generic 'destroy-window))
 292
 293 (defun remove-focus-window ()
 294   "Remove the focus window from the current frame"
 295   (with-focus-window (window)
 296     (setf (current-child) (find-current-root))
 297     (hide-child window)
 298     (remove-child-in-frame window (find-parent-frame window))
 299     (show-all-children)))
 300
 301
 302 (defun unhide-all-windows-in-current-child ()
 303   "Unhide all hidden windows into the current child"
 304   (dolist (window (get-hidden-windows))
 305     (unhide-window window)
 306     (process-new-window window)
 307     (map-window window))
 308   (show-all-children))
 309
 310
 311
 312
 313 (defun find-window-under-mouse (x y)
 314   "Return the child window under the mouse"
 315   (let ((win *root*))
 316     (with-all-windows-frames-and-parent (*root-frame* child parent)
 317       (when (and (or (managed-window-p child parent) (child-equal-p parent (current-child)))
 318                  (not (window-hidden-p child))
 319                  (in-window child x y))
 320         (setf win child))
 321       (when (in-frame child x y)
 322         (setf win (frame-window child))))
 323     win))
 324
 325
 326
 327
 328 (defun find-child-under-mouse-in-never-managed-windows (x y)
 329   "Return the child under mouse from never managed windows"
 330   (let ((ret nil))
 331     (dolist (win (xlib:query-tree *root*))
 332       (unless (window-hidden-p win)
 333         (multiple-value-bind (never-managed raise)
 334             (never-managed-window-p win)
 335           (when (and never-managed raise (in-window win x y))
 336             (setf ret win)))))
 337     ret))
 338
 339
 340 (defun find-child-under-mouse-in-child-tree (x y &optional first-foundp)
 341   "Return the child under the mouse"
 342   (let ((ret nil))
 343     (with-all-windows-frames-and-parent (*root-frame* child parent)
 344       (when (and (not (window-hidden-p child))
 345                  (or (managed-window-p child parent) (child-equal-p parent (current-child)))
 346                  (in-window child x y))
 347         (if first-foundp
 348             (return-from find-child-under-mouse-in-child-tree child)
 349             (setf ret child)))
 350       (when (in-frame child x y)
 351         (if first-foundp
 352             (return-from find-child-under-mouse-in-child-tree child)
 353             (setf ret child))))
 354     ret))
 355
 356
 357 (defun find-child-under-mouse (x y &optional first-foundp also-never-managed)
 358   "Return the child under the mouse"
 359   (or (and also-never-managed
 360            (find-child-under-mouse-in-never-managed-windows x y))
 361       (find-child-under-mouse-in-child-tree x y first-foundp)))
 362
 363
 364
 365
 366
 367 ;;; Selection functions
 368 (defun clear-selection ()
 369   "Clear the current selection"
 370   (setf *child-selection* nil)
 371   (display-all-root-frame-info))
 372
 373 (defun copy-current-child ()
 374   "Copy the current child to the selection"
 375   (pushnew (current-child) *child-selection*)
 376   (display-all-root-frame-info))
 377
 378
 379 (defun cut-current-child (&optional (show-now t))
 380   "Cut the current child to the selection"
 381   (unless (child-root-p (current-child))
 382     (let ((parent (find-parent-frame (current-child))))
 383       (hide-all (current-child))
 384       (copy-current-child)
 385       (remove-child-in-frame (current-child) (find-parent-frame (current-child) (find-current-root)))
 386       (when parent
 387         (setf (current-child) parent))
 388       (when show-now
 389         (show-all-children t))
 390       (current-child))))
 391
 392 (defun remove-current-child ()
 393   "Remove the current child from its parent frame"
 394   (unless (child-root-p (current-child))
 395     (let ((parent (find-parent-frame (current-child))))
 396       (hide-all (current-child))
 397       (remove-child-in-frame (current-child) (find-parent-frame (current-child) (find-current-root)))
 398       (when parent
 399         (setf (current-child) parent))
 400       (show-all-children t)
 401       (leave-second-mode))))
 402
 403 (defun delete-current-child ()
 404   "Delete the current child and its children in all frames"
 405   (unless (child-root-p (current-child))
 406     (hide-all (current-child))
 407     (delete-child-and-children-in-all-frames (current-child))
 408     (show-all-children t)
 409     (leave-second-mode)))
 410
 411
 412 (defun paste-selection-no-clear ()
 413   "Paste the selection in the current frame - Do not clear the selection after paste"
 414   (when (frame-p (current-child))
 415     (dolist (child *child-selection*)
 416       (unless (find-child-in-parent child (current-child))
 417         (pushnew child (frame-child (current-child)) :test #'child-equal-p)))
 418     (show-all-children)))
 419
 420 (defun paste-selection ()
 421   "Paste the selection in the current frame"
 422   (when (frame-p (current-child))
 423     (paste-selection-no-clear)
 424     (setf *child-selection* nil)
 425     (display-all-root-frame-info)))
 426
 427
 428 (defun copy-focus-window ()
 429   "Copy the focus window to the selection"
 430   (with-focus-window (window)
 431     (with-current-child (window)
 432       (copy-current-child))))
 433
 434
 435 (defun cut-focus-window ()
 436   "Cut the focus window to the selection"
 437   (with-focus-window (window)
 438     (setf (current-child) (with-current-child (window)
 439                             (cut-current-child nil)))
 440     (show-all-children t)))
 441
 442
 443
 444
 445
 446
 447 ;;; Maximize function
 448 (defun frame-toggle-maximize ()
 449   "Maximize/Unmaximize the current frame in its parent frame"
 450   (when (frame-p (current-child))
 451     (let ((unmaximized-coords (frame-data-slot (current-child) :unmaximized-coords)))
 452       (if unmaximized-coords
 453           (with-slots (x y w h) (current-child)
 454             (destructuring-bind (nx ny nw nh) unmaximized-coords
 455               (setf (frame-data-slot (current-child) :unmaximized-coords) nil
 456                     x nx y ny w nw h nh)))
 457           (with-slots (x y w h) (current-child)
 458             (setf (frame-data-slot (current-child) :unmaximized-coords)
 459                   (list x y w h)
 460                   x 0 y 0 w 1 h 1))))
 461     (show-all-children)
 462     (leave-second-mode)))
 463
 464
 465
 466
 467
 468
 469
 470
 471
 472 ;;; CONFIG - Identify mode
 473 (defun identify-key ()
 474   "Identify a key"
 475   (let* ((done nil)
 476          (font (xlib:open-font *display* *identify-font-string*))
 477          (window (xlib:create-window :parent *root*
 478                                      :x 0 :y 0
 479                                      :width (- (xlib:screen-width *screen*) (* *border-size* 2))
 480                                      :height (* 5 (+ (xlib:max-char-ascent font) (xlib:max-char-descent font)))
 481                                      :background (get-color *identify-background*)
 482                                      :border-width *border-size*
 483                                      :border (get-color *identify-border*)
 484                                      :colormap (xlib:screen-default-colormap *screen*)
 485                                      :event-mask '(:exposure)))
 486          (gc (xlib:create-gcontext :drawable window
 487                                    :foreground (get-color *identify-foreground*)
 488                                    :background (get-color *identify-background*)
 489                                    :font font
 490                                    :line-style :solid)))
 491     (setf (window-transparency window) *identify-transparency*)
 492     (labels ((print-doc (msg hash-table-key pos code state)
 493                (let ((function (find-key-from-code hash-table-key code state)))
 494                  (when (and function (fboundp (first function)))
 495                    (xlib:draw-glyphs *pixmap-buffer* gc 10 (+ (* pos (+ (xlib:max-char-ascent font) (xlib:max-char-descent font))) 5)
 496                                      (format nil "~A ~A" msg (documentation (first function) 'function))))))
 497              (print-key (code state keysym key modifiers)
 498                (clear-pixmap-buffer window gc)
 499                (setf (xlib:gcontext-foreground gc) (get-color *identify-foreground*))
 500                (xlib:draw-glyphs *pixmap-buffer* gc 5 (+ (xlib:max-char-ascent font) 5)
 501                                  (format nil "Press a key to identify. Press 'q' to stop the identify loop."))
 502                (when code
 503                  (xlib:draw-glyphs *pixmap-buffer* gc 10 (+ (* 2 (+ (xlib:max-char-ascent font) (xlib:max-char-descent font))) 5)
 504                                    (format nil "Code=~A  KeySym=~S  Key=~S  Modifiers=~A"
 505                                            code keysym key modifiers))
 506                  (print-doc "Main mode  : " *main-keys* 3 code state)
 507                  (print-doc "Second mode: " *second-keys* 4 code state))
 508                (copy-pixmap-buffer window gc))
 509              (handle-identify-key (&rest event-slots &key root code state &allow-other-keys)
 510                (declare (ignore event-slots root))
 511                (let* ((modifiers (state->modifiers state))
 512                       (key (keycode->char code state))
 513                       (keysym (keysym->keysym-name (keycode->keysym code modifiers))))
 514                  (setf done (and (equal key #\q) (equal modifiers *default-modifiers*)))
 515                  (dbg code keysym key modifiers)
 516                  (print-key code state keysym key modifiers)
 517                  (force-output)))
 518              (handle-identify (&rest event-slots &key display event-key &allow-other-keys)
 519                (declare (ignore display))
 520                (case event-key
 521                  (:key-press (apply #'handle-identify-key event-slots) t)
 522                  (:exposure (print-key nil nil nil nil nil)))
 523                t))
 524       (xgrab-pointer *root* 92 93)
 525       (map-window window)
 526       (format t "~&Press 'q' to stop the identify loop~%")
 527       (print-key nil nil nil nil nil)
 528       (force-output)
 529       (unwind-protect
 530            (loop until done do
 531                 (when (xlib:event-listen *display* *loop-timeout*)
 532                   (xlib:process-event *display* :handler #'handle-identify))
 533                 (xlib:display-finish-output *display*))
 534         (xlib:destroy-window window)
 535         (xlib:close-font font)
 536         (xgrab-pointer *root* 66 67)))))
 537
 538
 539
 540
 541
 542
 543 (defun eval-from-query-string ()
 544   "Eval a lisp form from the query input"
 545   (let ((form (query-string (format nil "Eval Lisp - ~A" (package-name *package*))))
 546         (result nil))
 547     (when (and form (not (equal form "")))
 548       (let ((printed-result
 549              (with-output-to-string (*standard-output*)
 550                (setf result (handler-case
 551                                 (loop for i in (multiple-value-list
 552                                                 (eval (read-from-string form)))
 553                                    collect (format nil "~S" i))
 554                               (error (condition)
 555                                 (format nil "~A" condition)))))))
 556         (info-mode (expand-newline (append (ensure-list (format nil "> ~A" form))
 557                                            (ensure-list printed-result)
 558                                            (ensure-list result)))
 559                    :width (- (xlib:screen-width *screen*) 2))
 560         (eval-from-query-string)))))
 561
 562
 563
 564
 565 (defun run-program-from-query-string ()
 566   "Run a program from the query input"
 567   (multiple-value-bind (program return)
 568       (query-string "Run:")
 569     (when (and (equal return :return) program (not (equal program "")))
 570       (setf *second-mode-leave-function* (let ((cmd (concatenate 'string "cd $HOME && " program)))
 571                                            (lambda ()
 572                                              (do-shell cmd))))
 573       (leave-second-mode))))
 574
 575
 576
 577
 578 ;;; Frame name actions
 579 (defun ask-frame-name (msg)
 580   "Ask a frame name"
 581   (let ((all-frame-name nil))
 582     (with-all-frames (*root-frame* frame)
 583       (awhen (frame-name frame) (push it all-frame-name)))
 584     (query-string msg "" all-frame-name)))
 585
 586
 587 ;;; Focus by functions
 588 (defun focus-frame-by (frame)
 589   (when (frame-p frame)
 590     (focus-all-children frame (or (find-parent-frame frame (find-current-root))
 591                                   (find-parent-frame frame)
 592                                   *root-frame*))
 593     (show-all-children t)))
 594
 595
 596 (defun focus-frame-by-name ()
 597   "Focus a frame by name"
 598   (focus-frame-by (find-frame-by-name (ask-frame-name "Focus frame:")))
 599   (leave-second-mode))
 600
 601 (defun focus-frame-by-number ()
 602   "Focus a frame by number"
 603   (focus-frame-by (find-frame-by-number (query-number "Focus frame by number:")))
 604   (leave-second-mode))
 605
 606
 607 ;;; Open by functions
 608 (defun open-frame-by (frame)
 609   (when (frame-p frame)
 610     (push (create-frame :name (query-string "Frame name")) (frame-child frame))
 611     (show-all-children)))
 612
 613
 614
 615 (defun open-frame-by-name ()
 616   "Open a new frame in a named frame"
 617   (open-frame-by (find-frame-by-name (ask-frame-name "Open a new frame in: ")))
 618   (leave-second-mode))
 619
 620 (defun open-frame-by-number ()
 621   "Open a new frame in a numbered frame"
 622   (open-frame-by (find-frame-by-number (query-number "Open a new frame in the group numbered:")))
 623   (leave-second-mode))
 624
 625
 626 ;;; Delete by functions
 627 (defun delete-frame-by (frame)
 628   (unless (or (child-equal-p frame *root-frame*)
 629               (child-root-p frame))
 630     (when (child-equal-p frame (current-child))
 631       (setf (current-child) (find-current-root)))
 632     (remove-child-in-frame frame (find-parent-frame frame)))
 633   (show-all-children t))
 634
 635
 636 (defun delete-frame-by-name ()
 637   "Delete a frame by name"
 638   (delete-frame-by (find-frame-by-name (ask-frame-name "Delete frame: ")))
 639   (leave-second-mode))
 640
 641 (defun delete-frame-by-number ()
 642   "Delete a frame by number"
 643   (delete-frame-by (find-frame-by-number (query-number "Delete frame by number:")))
 644   (leave-second-mode))
 645
 646
 647 ;;; Move by function
 648 (defun move-child-to (child frame-dest)
 649   (when (and child (frame-p frame-dest))
 650     (remove-child-in-frame child (find-parent-frame child))
 651     (pushnew child (frame-child frame-dest))
 652     (focus-all-children child frame-dest)
 653     (show-all-children t)))
 654
 655 (defun move-current-child-by-name ()
 656   "Move current child in a named frame"
 657   (move-child-to (current-child)
 658                  (find-frame-by-name
 659                   (ask-frame-name (format nil "Move '~A' to frame: " (child-name (current-child))))))
 660   (leave-second-mode))
 661
 662 (defun move-current-child-by-number ()
 663   "Move current child in a numbered frame"
 664   (move-child-to (current-child)
 665                  (find-frame-by-number
 666                   (query-number (format nil "Move '~A' to frame numbered:" (child-name (current-child))))))
 667   (leave-second-mode))
 668
 669
 670 ;;; Copy by function
 671 (defun copy-child-to (child frame-dest)
 672   (when (and child (frame-p frame-dest))
 673     (pushnew child (frame-child frame-dest))
 674     (focus-all-children child frame-dest)
 675     (show-all-children t)))
 676
 677 (defun copy-current-child-by-name ()
 678   "Copy current child in a named frame"
 679   (copy-child-to (current-child)
 680                  (find-frame-by-name
 681                   (ask-frame-name (format nil "Copy '~A' to frame: " (child-name (current-child))))))
 682   (leave-second-mode))
 683
 684 (defun copy-current-child-by-number ()
 685   "Copy current child in a numbered frame"
 686   (copy-child-to (current-child)
 687                  (find-frame-by-number
 688                   (query-number (format nil "Copy '~A' to frame numbered:" (child-name (current-child))))))
 689   (leave-second-mode))
 690
 691
 692
 693
 694 ;;; Show frame info
 695 (defun show-all-frames-info ()
 696   "Show all frames info windows"
 697   (let ((*show-root-frame-p* t))
 698     (show-all-children)
 699     (dolist (root (all-root-child))
 700       (with-all-frames (root frame)
 701         (raise-window (frame-window frame))
 702         (display-frame-info frame)))))
 703
 704 (defun hide-all-frames-info ()
 705   "Hide all frames info windows"
 706   (show-all-children))
 707
 708 (defun show-all-frames-info-key ()
 709   "Show all frames info windows until a key is release"
 710   (show-all-frames-info)
 711   (wait-no-key-or-button-press)
 712   (hide-all-frames-info))
 713
 714
 715 (defun move-frame (frame parent orig-x orig-y)
 716   (when (and frame parent (not (child-root-p frame)))
 717     (hide-all-children frame)
 718     (with-slots (window) frame
 719       (move-window window orig-x orig-y #'display-frame-info (list frame))
 720       (setf (frame-x frame) (x-px->fl (x-drawable-x window) parent)
 721             (frame-y frame) (y-px->fl (x-drawable-y window) parent)))
 722     (show-all-children)))
 723
 724 (defun resize-frame (frame parent orig-x orig-y)
 725   (when (and frame parent (not (child-root-p frame)))
 726     (hide-all-children frame)
 727     (with-slots (window) frame
 728       (resize-window window orig-x orig-y #'display-frame-info (list frame))
 729       (setf (frame-w frame) (w-px->fl (anti-adj-border-wh (x-drawable-width window) frame) parent)
 730             (frame-h frame) (h-px->fl (anti-adj-border-wh (x-drawable-height window) frame) parent)))
 731     (show-all-children)))
 732
 733
 734
 735 (defun mouse-click-to-focus-generic (root-x root-y mouse-fn)
 736   "Focus the current frame or focus the current window parent
 737 mouse-fun is #'move-frame or #'resize-frame"
 738   (let* ((to-replay t)
 739          (child (find-child-under-mouse root-x root-y))
 740          (parent (find-parent-frame child))
 741          (root-p (child-root-p child)))
 742     (labels ((add-new-frame ()
 743                (when (frame-p child)
 744                  (setf parent child
 745                        child (create-frame)
 746                        mouse-fn #'resize-frame
 747                        (current-child) child)
 748                  (place-frame child parent root-x root-y 10 10)
 749                  (map-window (frame-window child))
 750                  (pushnew child (frame-child parent)))))
 751       (when (and root-p  *create-frame-on-root*)
 752         (add-new-frame))
 753       (when (and (frame-p child) (not (child-root-p child)))
 754         (funcall mouse-fn child parent root-x root-y))
 755       (when (and child parent
 756                  (focus-all-children child parent (not (child-root-p child))))
 757         (when (show-all-children)
 758           (setf to-replay nil)))
 759       (if to-replay
 760           (replay-button-event)
 761           (stop-button-event)))))
 762
 763
 764 (defun mouse-click-to-focus-and-move (window root-x root-y)
 765   "Move and focus the current frame or focus the current window parent.
 766 Or do actions on corners"
 767   (declare (ignore window))
 768   (or (do-corner-action root-x root-y *corner-main-mode-left-button*)
 769       (mouse-click-to-focus-generic root-x root-y #'move-frame)))
 770
 771 (defun mouse-click-to-focus-and-resize (window root-x root-y)
 772   "Resize and focus the current frame or focus the current window parent.
 773 Or do actions on corners"
 774   (declare (ignore window))
 775   (or (do-corner-action root-x root-y *corner-main-mode-right-button*)
 776       (mouse-click-to-focus-generic root-x root-y #'resize-frame)))
 777
 778 (defun mouse-middle-click (window root-x root-y)
 779   "Do actions on corners"
 780   (declare (ignore window))
 781   (or (do-corner-action root-x root-y *corner-main-mode-middle-button*)
 782       (replay-button-event)))
 783
 784
 785
 786
 787 (defun mouse-focus-move/resize-generic (root-x root-y mouse-fn window-parent)
 788   "Focus the current frame or focus the current window parent
 789 mouse-fun is #'move-frame or #'resize-frame.
 790 Focus child and its parents -
 791 For window: set current child to window or its parent according to window-parent"
 792   (labels ((move/resize-managed (child)
 793              (let ((parent (find-parent-frame child)))
 794                (when (and child
 795                           (frame-p child)
 796                           (child-root-p child))
 797                  (setf parent child
 798                        child (create-frame)
 799                        mouse-fn #'resize-frame)
 800                  (place-frame child parent root-x root-y 10 10)
 801                  (map-window (frame-window child))
 802                  (push child (frame-child parent)))
 803                (focus-all-children child parent window-parent)
 804                (show-all-children)
 805                (typecase child
 806                  (xlib:window
 807                   (if (managed-window-p child parent)
 808                       (funcall mouse-fn parent (find-parent-frame parent) root-x root-y)
 809                       (funcall (cond ((or (eql mouse-fn #'move-frame)
 810                                           (eql mouse-fn #'move-frame-constrained))
 811                                       #'move-window)
 812                                      ((or (eql mouse-fn #'resize-frame)
 813                                           (eql mouse-fn #'resize-frame-constrained))
 814                                       #'resize-window))
 815                                child root-x root-y)))
 816                  (frame (funcall mouse-fn child parent root-x root-y)))
 817                (show-all-children)))
 818            (move/resize-never-managed (child raise-fun)
 819              (funcall raise-fun child)
 820              (funcall (cond ((eql mouse-fn #'move-frame) #'move-window)
 821                             ((eql mouse-fn #'resize-frame) #'resize-window))
 822                       child root-x root-y)))
 823     (let ((child (find-child-under-mouse root-x root-y nil t)))
 824       (multiple-value-bind (never-managed raise-fun)
 825           (never-managed-window-p child)
 826         (if (and (xlib:window-p child) never-managed raise-fun)
 827             (move/resize-never-managed child raise-fun)
 828             (move/resize-managed child))))))
 829
 830
 831 (defun test-mouse-binding (window root-x root-y)
 832   (dbg window root-x root-y)
 833   (replay-button-event))
 834
 835
 836
 837 (defun mouse-select-next-level (window root-x root-y)
 838   "Select the next level in frame"
 839   (declare (ignore root-x root-y))
 840   (let ((frame (find-frame-window window)))
 841     (when (or frame (xlib:window-equal window *root*))
 842       (select-next-level))
 843     (replay-button-event)))
 844
 845
 846
 847 (defun mouse-select-previous-level (window root-x root-y)
 848   "Select the previous level in frame"
 849   (declare (ignore root-x root-y))
 850   (let ((frame (find-frame-window window)))
 851     (when (or frame (xlib:window-equal window *root*))
 852       (select-previous-level))
 853     (replay-button-event)))
 854
 855
 856
 857 (defun mouse-enter-frame (window root-x root-y)
 858   "Enter in the selected frame - ie make it the root frame"
 859   (declare (ignore root-x root-y))
 860   (let ((frame (find-frame-window window)))
 861     (when (or frame (xlib:window-equal window *root*))
 862       (enter-frame))
 863     (replay-button-event)))
 864
 865
 866
 867 (defun mouse-leave-frame (window root-x root-y)
 868   "Leave the selected frame - ie make its parent the root frame"
 869   (declare (ignore root-x root-y))
 870   (let ((frame (find-frame-window window)))
 871     (when (or frame (xlib:window-equal window *root*))
 872       (leave-frame))
 873     (replay-button-event)))
 874
 875
 876
 877 ;;;;;,-----
 878 ;;;;;| Various definitions
 879 ;;;;;`-----
 880
 881 (defun show-help (&optional (browser "dillo") (tempfile "/tmp/clfswm.html"))
 882   "Show current keys and buttons bindings"
 883   (ignore-errors
 884     (produce-doc-html-in-file tempfile))
 885   (sleep 1)
 886   (do-shell (format nil "~A ~A" browser tempfile)))
 887
 888
 889
 890 ;;;  Bind or jump functions
 891 (let ((key-slots (make-array 10 :initial-element nil))
 892       (current-slot 1))
 893   (defun bind-on-slot (&optional (slot current-slot))
 894     "Bind current child to slot"
 895     (setf (aref key-slots slot) (current-child)))
 896
 897   (defun remove-binding-on-slot ()
 898     "Remove binding on slot"
 899     (setf (aref key-slots current-slot) nil))
 900
 901   (defun jump-to-slot ()
 902     "Jump to slot"
 903     (let ((jump-child (aref key-slots current-slot)))
 904       (when (find-child jump-child *root-frame*)
 905         (unless (find-child-in-all-root jump-child)
 906           (change-root (find-root jump-child) jump-child))
 907         (setf (current-child) jump-child)
 908         (focus-all-children (current-child) (current-child))
 909         (show-all-children t))))
 910
 911   (defun bind-or-jump (n)
 912     "Bind or jump to a slot (a frame or a window)"
 913     (setf current-slot (- n 1))
 914     (let ((default-bind `("b" bind-on-slot
 915                               ,(format nil "Bind slot ~A on child: ~A" n (child-fullname (current-child))))))
 916       (info-mode-menu (aif (aref key-slots current-slot)
 917                            `(,default-bind
 918                                 ("BackSpace" remove-binding-on-slot
 919                                              ,(format nil "Remove slot ~A binding on child: ~A" n (child-fullname (current-child))))
 920                                 ("   -  " nil " -")
 921                               ("Tab" jump-to-slot
 922                                      ,(format nil "Jump to child: ~A" (aif (aref key-slots current-slot)
 923                                                                            (child-fullname it)
 924                                                                            "Not set - Please, bind it with 'b'")))
 925                               ("Return" jump-to-slot "Same thing")
 926                               ("space" jump-to-slot "Same thing"))
 927                            (list default-bind))))))
 928
 929
 930
 931 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 932 ;;; Useful function for the second mode ;;;
 933 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 934 (defmacro with-movement (&body body)
 935   `(when (frame-p (current-child))
 936      ,@body
 937      (show-all-children)
 938      (display-all-frame-info)
 939      (draw-second-mode-window)
 940      (open-menu (find-menu 'frame-movement-menu))))
 941
 942
 943 ;;; Pack
 944 (defun current-frame-pack-up ()
 945   "Pack the current frame up"
 946   (with-movement (pack-frame-up (current-child) (find-parent-frame (current-child) (find-current-root)))))
 947
 948 (defun current-frame-pack-down ()
 949   "Pack the current frame down"
 950   (with-movement (pack-frame-down (current-child) (find-parent-frame (current-child) (find-current-root)))))
 951
 952 (defun current-frame-pack-left ()
 953   "Pack the current frame left"
 954   (with-movement (pack-frame-left (current-child) (find-parent-frame (current-child) (find-current-root)))))
 955
 956 (defun current-frame-pack-right ()
 957   "Pack the current frame right"
 958   (with-movement (pack-frame-right (current-child) (find-parent-frame (current-child) (find-current-root)))))
 959
 960 ;;; Center
 961 (defun center-current-frame ()
 962   "Center the current frame"
 963   (with-movement (center-frame (current-child))))
 964
 965 ;;; Fill
 966 (defun current-frame-fill-up ()
 967   "Fill the current frame up"
 968   (with-movement (fill-frame-up (current-child) (find-parent-frame (current-child) (find-current-root)))))
 969
 970 (defun current-frame-fill-down ()
 971   "Fill the current frame down"
 972   (with-movement (fill-frame-down (current-child) (find-parent-frame (current-child) (find-current-root)))))
 973
 974 (defun current-frame-fill-left ()
 975   "Fill the current frame left"
 976   (with-movement (fill-frame-left (current-child) (find-parent-frame (current-child) (find-current-root)))))
 977
 978 (defun current-frame-fill-right ()
 979   "Fill the current frame right"
 980   (with-movement (fill-frame-right (current-child) (find-parent-frame (current-child) (find-current-root)))))
 981
 982 (defun current-frame-fill-all-dir ()
 983   "Fill the current frame in all directions"
 984   (with-movement
 985     (let ((parent (find-parent-frame (current-child) (find-current-root))))
 986       (fill-frame-up (current-child) parent)
 987       (fill-frame-down (current-child) parent)
 988       (fill-frame-left (current-child) parent)
 989       (fill-frame-right (current-child) parent))))
 990
 991 (defun current-frame-fill-vertical ()
 992   "Fill the current frame vertically"
 993   (with-movement
 994     (let ((parent (find-parent-frame (current-child) (find-current-root))))
 995       (fill-frame-up (current-child) parent)
 996       (fill-frame-down (current-child) parent))))
 997
 998 (defun current-frame-fill-horizontal ()
 999   "Fill the current frame horizontally"
1000   (with-movement
1001     (let ((parent (find-parent-frame (current-child) (find-current-root))))
1002       (fill-frame-left (current-child) parent)
1003       (fill-frame-right (current-child) parent))))
1004
1005
1006 ;;; Resize
1007 (defun current-frame-resize-up ()
1008   "Resize the current frame up to its half height"
1009   (with-movement (resize-half-height-up (current-child))))
1010
1011 (defun current-frame-resize-down ()
1012   "Resize the current frame down to its half height"
1013   (with-movement (resize-half-height-down (current-child))))
1014
1015 (defun current-frame-resize-left ()
1016   "Resize the current frame left to its half width"
1017   (with-movement (resize-half-width-left (current-child))))
1018
1019 (defun current-frame-resize-right ()
1020   "Resize the current frame right to its half width"
1021   (with-movement (resize-half-width-right (current-child))))
1022
1023 (defun current-frame-resize-all-dir ()
1024   "Resize down the current frame"
1025   (with-movement (resize-frame-down (current-child))))
1026
1027 (defun current-frame-resize-all-dir-minimal ()
1028   "Resize down the current frame to its minimal size"
1029   (with-movement (resize-minimal-frame (current-child))))
1030
1031
1032 ;;; Children navigation
1033 (defun with-movement-select-next-brother ()
1034   "Select the next brother frame"
1035   (with-movement (select-next-brother-simple)))
1036
1037 (defun with-movement-select-previous-brother ()
1038   "Select the previous brother frame"
1039   (with-movement (select-previous-brother-simple)))
1040
1041 (defun with-movement-select-next-level ()
1042   "Select the next level"
1043   (with-movement (select-next-level)))
1044
1045 (defun with-movement-select-previous-level ()
1046   "Select the previous levelframe"
1047   (with-movement (select-previous-level)))
1048
1049 (defun with-movement-select-next-child ()
1050   "Select the next child"
1051   (with-movement (select-next-child-simple)))
1052
1053
1054
1055 ;;; Adapt frame functions
1056 (defun adapt-current-frame-to-window-hints-generic (width-p height-p)
1057   "Adapt the current frame to the current window minimal size hints"
1058   (when (frame-p (current-child))
1059     (let ((window (first (frame-child (current-child)))))
1060       (when (xlib:window-p window)
1061         (let* ((hints (xlib:wm-normal-hints window))
1062                (min-width (and hints (xlib:wm-size-hints-min-width hints)))
1063                (min-height (and hints (xlib:wm-size-hints-min-height hints))))
1064           (when (and width-p min-width)
1065             (setf (frame-rw (current-child)) min-width))
1066           (when (and height-p min-height)
1067             (setf (frame-rh (current-child)) min-height))
1068           (fixe-real-size (current-child) (find-parent-frame (current-child)))
1069           (leave-second-mode))))))
1070
1071 (defun adapt-current-frame-to-window-hints ()
1072   "Adapt the current frame to the current window minimal size hints"
1073   (adapt-current-frame-to-window-hints-generic t t))
1074
1075 (defun adapt-current-frame-to-window-width-hint ()
1076   "Adapt the current frame to the current window minimal width hint"
1077   (adapt-current-frame-to-window-hints-generic t nil))
1078
1079 (defun adapt-current-frame-to-window-height-hint ()
1080   "Adapt the current frame to the current window minimal height hint"
1081   (adapt-current-frame-to-window-hints-generic nil t))
1082
1083
1084
1085
1086 ;;; Managed window type functions
1087 (defun current-frame-manage-window-type-generic (type-list)
1088   (when (frame-p (current-child))
1089     (setf (frame-managed-type (current-child)) type-list
1090           (frame-forced-managed-window (current-child)) nil
1091           (frame-forced-unmanaged-window (current-child)) nil))
1092   (leave-second-mode))
1093
1094
1095 (defun current-frame-manage-window-type ()
1096   "Change window types to be managed by a frame"
1097   (when (frame-p (current-child))
1098     (let* ((type-str (query-string "Managed window type: (all, normal, transient, maxsize, desktop, dock, toolbar, menu, utility, splash, dialog)"
1099                                    (format nil "~{~:(~A~) ~}" (frame-managed-type (current-child)))))
1100            (type-list (loop :for type :in (split-string type-str)
1101                          :collect (intern (string-upcase type) :keyword))))
1102       (current-frame-manage-window-type-generic type-list))))
1103
1104
1105 (defun current-frame-manage-all-window-type ()
1106   "Manage all window type"
1107   (current-frame-manage-window-type-generic '(:all)))
1108
1109 (defun current-frame-manage-only-normal-window-type ()
1110   "Manage only normal window type"
1111   (current-frame-manage-window-type-generic '(:normal)))
1112
1113 (defun current-frame-manage-no-window-type ()
1114   "Do not manage any window type"
1115   (current-frame-manage-window-type-generic nil))
1116
1117
1118
1119
1120
1121
1122
1123
1124 ;;; Force window functions
1125 (defun force-window-in-frame ()
1126   "Force the current window to move in the frame (Useful only for unmanaged windows)"
1127   (with-current-window
1128     (let ((parent (find-parent-frame window)))
1129       (setf (x-drawable-x window) (frame-rx parent)
1130             (x-drawable-y window) (frame-ry parent))
1131       (xlib:display-finish-output *display*)))
1132   (leave-second-mode))
1133
1134
1135 (defun force-window-center-in-frame ()
1136   "Force the current window to move in the center of the frame (Useful only for unmanaged windows)"
1137   (with-current-window
1138     (let ((parent (find-parent-frame window)))
1139       (setf (x-drawable-x window) (truncate (+ (frame-rx parent)
1140                                                   (/ (- (frame-rw parent)
1141                                                         (x-drawable-width window)) 2)))
1142             (x-drawable-y window) (truncate (+ (frame-ry parent)
1143                                                   (/ (- (frame-rh parent)
1144                                                         (x-drawable-height window)) 2))))
1145       (xlib:display-finish-output *display*)))
1146   (leave-second-mode))
1147
1148
1149
1150 (defun display-current-window-info ()
1151   "Display information on the current window"
1152   (with-current-window
1153     (info-mode (list (format nil "Window:       ~A" window)
1154                      (format nil "Window name:  ~A" (xlib:wm-name window))
1155                      (format nil "Window class: ~A" (xlib:get-wm-class window))
1156                      (format nil "Window type:  ~:(~A~)" (window-type window))
1157                      (format nil "Window id:    0x~X" (xlib:window-id window))
1158                      (format nil "Window transparency: ~A" (* 100 (window-transparency window))))))
1159   (leave-second-mode))
1160
1161 (defun set-current-window-transparency ()
1162   "Set the current window transparency"
1163   (with-current-window
1164       (ask-child-transparency "window" window))
1165   (leave-second-mode))
1166
1167
1168 (defun manage-current-window ()
1169   "Force to manage the current window by its parent frame"
1170   (with-current-window
1171     (let ((parent (find-parent-frame window)))
1172       (with-slots ((managed forced-managed-window)
1173                    (unmanaged forced-unmanaged-window)) parent
1174         (setf unmanaged (child-remove window unmanaged)
1175               unmanaged (remove (xlib:wm-name window) unmanaged :test #'string-equal-p))
1176         (pushnew window managed))))
1177   (leave-second-mode))
1178
1179 (defun unmanage-current-window ()
1180   "Force to not manage the current window by its parent frame"
1181   (with-current-window
1182     (let ((parent (find-parent-frame window)))
1183       (with-slots ((managed forced-managed-window)
1184                    (unmanaged forced-unmanaged-window)) parent
1185         (setf managed (child-remove window managed)
1186               managed (remove (xlib:wm-name window) managed :test #'string-equal-p))
1187         (pushnew window unmanaged))))
1188   (leave-second-mode))
1189
1190
1191
1192 ;;; Moving child with the mouse button
1193 (defun mouse-move-child-over-frame (window root-x root-y)
1194   "Move the child under the mouse cursor to another frame"
1195   (declare (ignore window))
1196   (let ((child (find-child-under-mouse root-x root-y)))
1197     (unless (child-root-p child)
1198       (hide-all child)
1199       (remove-child-in-frame child (find-parent-frame child))
1200       (wait-mouse-button-release 50 51)
1201       (multiple-value-bind (x y)
1202           (xlib:query-pointer *root*)
1203         (let ((dest (find-child-under-mouse x y)))
1204           (when (xlib:window-p dest)
1205             (setf dest (find-parent-frame dest)))
1206           (unless (child-equal-p child dest)
1207             (move-child-to child dest)
1208             (show-all-children))))))
1209   (stop-button-event))
1210
1211
1212
1213
1214 ;;; Hide/Show frame window functions
1215 (defun hide/show-frame-window (frame value)
1216   "Hide/show the frame window"
1217   (when (frame-p frame)
1218     (setf (frame-show-window-p (current-child)) value)
1219     (show-all-children))
1220   (leave-second-mode))
1221
1222
1223 (defun hide-current-frame-window ()
1224   "Hide the current frame window"
1225   (hide/show-frame-window (current-child) nil))
1226
1227 (defun show-current-frame-window ()
1228   "Show the current frame window"
1229   (hide/show-frame-window (current-child) t))
1230
1231
1232
1233 ;;; Hide/Unhide current child
1234 (defun hide-current-child ()
1235   "Hide the current child"
1236   (unless (child-root-p (current-child))
1237     (let ((parent (find-parent-frame (current-child))))
1238       (when (frame-p parent)
1239         (with-slots (child hidden-children) parent
1240           (hide-all (current-child))
1241           (setf child (child-remove (current-child) child))
1242           (pushnew (current-child) hidden-children)
1243           (setf (current-child) parent))
1244         (show-all-children)))
1245     (leave-second-mode)))
1246
1247
1248 (defun frame-unhide-child (hidden frame-src frame-dest)
1249   "Unhide a hidden child from frame-src in frame-dest"
1250   (with-slots (hidden-children) frame-src
1251     (setf hidden-children (child-remove hidden hidden-children)))
1252   (with-slots (child) frame-dest
1253     (pushnew hidden child)))
1254
1255
1256
1257 (defun unhide-a-child ()
1258   "Unhide a child in the current frame"
1259   (when (frame-p (current-child))
1260     (with-slots (child hidden-children) (current-child)
1261       (info-mode-menu (loop :for i :from 0
1262                          :for hidden :in hidden-children
1263                          :collect (list (code-char (+ (char-code #\a) i))
1264                                         (let ((lhd hidden))
1265                                           (lambda ()
1266                                             (frame-unhide-child lhd (current-child) (current-child))))
1267                                         (format nil "Unhide ~A" (child-fullname hidden))))))
1268     (show-all-children))
1269   (leave-second-mode))
1270
1271
1272 (defun unhide-all-children ()
1273   "Unhide all current frame hidden children"
1274   (when (frame-p (current-child))
1275     (with-slots (child hidden-children) (current-child)
1276       (dolist (c hidden-children)
1277         (pushnew c child))
1278       (setf hidden-children nil))
1279     (show-all-children))
1280   (leave-second-mode))
1281
1282
1283 (defun unhide-a-child-from-all-frames ()
1284   "Unhide a child from all frames in the current frame"
1285   (when (frame-p (current-child))
1286     (let ((acc nil)
1287           (keynum -1))
1288       (with-all-frames (*root-frame* frame)
1289         (when (frame-hidden-children frame)
1290           (push (format nil "~A" (child-fullname frame)) acc)
1291           (dolist (hidden (frame-hidden-children frame))
1292             (push (list (code-char (+ (char-code #\a) (incf keynum)))
1293                         (let ((lhd hidden))
1294                           (lambda ()
1295                             (frame-unhide-child lhd frame (current-child))))
1296                         (format nil "Unhide ~A" (child-fullname hidden)))
1297                   acc))))
1298       (info-mode-menu (nreverse acc)))
1299     (show-all-children))
1300   (leave-second-mode))
1301
1302
1303
1304
1305
1306 (let ((last-child nil))
1307   (defun init-last-child ()
1308     (setf last-child nil))
1309   (defun switch-to-last-child ()
1310     "Store the current child and switch to the previous one"
1311     (let ((current-child (current-child)))
1312       (when last-child
1313         (change-root (find-root last-child) last-child)
1314         (setf (current-child) last-child)
1315         (focus-all-children (current-child) (current-child))
1316         (show-all-children t))
1317       (setf last-child current-child))
1318     (leave-second-mode)))
1319
1320
1321
1322
1323
1324
1325
1326 ;;; Focus policy functions
1327 (defun set-focus-policy-generic (focus-policy)
1328   (when (frame-p (current-child))
1329     (setf (frame-focus-policy (current-child)) focus-policy))
1330   (leave-second-mode))
1331
1332
1333 (defun current-frame-set-click-focus-policy ()
1334   "Set a click focus policy for the current frame."
1335   (set-focus-policy-generic :click))
1336
1337 (defun current-frame-set-sloppy-focus-policy ()
1338   "Set a sloppy focus policy for the current frame."
1339   (set-focus-policy-generic :sloppy))
1340
1341 (defun current-frame-set-sloppy-strict-focus-policy ()
1342   "Set a (strict) sloppy focus policy only for windows in the current frame."
1343   (set-focus-policy-generic :sloppy-strict))
1344
1345 (defun current-frame-set-sloppy-select-policy ()
1346   "Set a sloppy select policy for the current frame."
1347     (set-focus-policy-generic :sloppy-select))
1348
1349
1350
1351 (defun set-focus-policy-generic-for-all (focus-policy)
1352   (with-all-frames (*root-frame* frame)
1353     (setf (frame-focus-policy frame) focus-policy))
1354   (leave-second-mode))
1355
1356
1357 (defun all-frames-set-click-focus-policy ()
1358   "Set a click focus policy for all frames."
1359   (set-focus-policy-generic-for-all :click))
1360
1361 (defun all-frames-set-sloppy-focus-policy ()
1362   "Set a sloppy focus policy for all frames."
1363   (set-focus-policy-generic-for-all :sloppy))
1364
1365 (defun all-frames-set-sloppy-strict-focus-policy ()
1366   "Set a (strict) sloppy focus policy for all frames."
1367   (set-focus-policy-generic-for-all :sloppy-strict))
1368
1369 (defun all-frames-set-sloppy-select-policy ()
1370   "Set a sloppy select policy for all frames."
1371     (set-focus-policy-generic-for-all :sloppy-select))
1372
1373
1374
1375 ;;; Ensure unique name/number functions
1376 (defun extract-number-from-name (name)
1377   (when (stringp name)
1378     (let* ((pos (1+ (or (position #\. name :from-end t) -1)))
1379            (number (parse-integer name :junk-allowed t :start pos)))
1380       (values number
1381               (if number (subseq name 0 (1- pos)) name)))))
1382
1383
1384
1385
1386 (defun ensure-unique-name ()
1387   "Ensure that all children names are unique"
1388   (with-all-children (*root-frame* child)
1389     (multiple-value-bind (num1 name1)
1390         (extract-number-from-name (child-name child))
1391       (declare (ignore num1))
1392       (when name1
1393         (let ((acc nil))
1394           (with-all-children (*root-frame* c)
1395             (unless (child-equal-p child c))
1396             (multiple-value-bind (num2 name2)
1397                 (extract-number-from-name (child-name c))
1398               (when (string-equal name1 name2)
1399                 (push num2 acc))))
1400           (dbg acc)
1401           (when (> (length acc) 1)
1402             (setf (child-name child)
1403                   (format nil "~A.~A" name1
1404                           (1+ (find-free-number (loop for i in acc when i collect (1- i)))))))))))
1405   (leave-second-mode))
1406
1407 (defun ensure-unique-number ()
1408   "Ensure that all children numbers are unique"
1409   (let ((num -1))
1410     (with-all-frames (*root-frame* frame)
1411       (setf (frame-number frame) (incf num))))
1412   (leave-second-mode))
1413
1414
1415
1416 ;;; Standard menu functions - Based on the XDG specifications
1417 (defun um-create-xdg-section-list (menu)
1418   (dolist (section *xdg-section-list*)
1419     (add-sub-menu menu :next section (format nil "~A" section) menu))
1420   (unless (find-toplevel-menu 'Utility menu)
1421     (add-sub-menu menu :next 'Utility (format nil "~A" 'Utility) menu)))
1422
1423 (defun um-find-submenu (menu section-list)
1424   (let ((acc nil))
1425     (dolist (section section-list)
1426       (awhen (find-toplevel-menu (intern (string-upcase section) :clfswm) menu)
1427         (push it acc)))
1428     (if acc
1429         acc
1430         (list (find-toplevel-menu 'Utility menu)))))
1431
1432
1433 (defun um-extract-value (line)
1434   (second (split-string line #\=)))
1435
1436
1437 (defun um-add-desktop (desktop menu)
1438   (let (name exec categories comment)
1439     (when (probe-file desktop)
1440       (with-open-file (stream desktop :direction :input)
1441         (loop for line = (read-line stream nil nil)
1442            while line
1443            do
1444            (cond ((first-position "Name=" line) (setf name (um-extract-value line)))
1445                  ((first-position "Exec=" line) (setf exec (um-extract-value line)))
1446                  ((first-position "Categories=" line) (setf categories (um-extract-value line)))
1447                  ((first-position "Comment=" line) (setf comment (um-extract-value line))))
1448            (when (and name exec categories)
1449              (let* ((sub-menu (um-find-submenu menu (split-string categories #\;)))
1450                     (fun-name (intern name :clfswm)))
1451                (setf (symbol-function fun-name) (let ((do-exec exec))
1452                                                   (lambda ()
1453                                                     (do-shell do-exec)
1454                                                     (leave-second-mode)))
1455                      (documentation fun-name 'function) (format nil "~A~A" name (if comment
1456                                                                                     (format nil " - ~A" comment)
1457                                                                                     "")))
1458                (dolist (m sub-menu)
1459                  (add-menu-key (menu-name m) :next fun-name m)))
1460              (setf name nil exec nil categories nil comment nil)))))))
1461
1462
1463 (defun update-menus (&optional (menu (make-menu :name 'main :doc "Main menu")))
1464   (um-create-xdg-section-list menu)
1465   (let ((count 0)
1466         (found (make-hash-table :test #'equal)))
1467     (dolist (dir (remove-duplicates
1468                   (split-string (or (getenv "XDG_DATA_DIRS") "/usr/local/share/:/usr/share/")
1469                                 #\:) :test #'string-equal))
1470       (dolist (desktop (directory (concatenate 'string dir "/applications/**/*.desktop")))
1471         (unless (gethash (file-namestring desktop) found)
1472           (setf (gethash (file-namestring desktop) found) t)
1473           (um-add-desktop desktop menu)
1474           (incf count))))
1475     menu))
1476
1477
1478
1479 ;;; Close/Kill focused window
1480
1481 (defun ask-close/kill-current-window ()
1482   "Close or kill the current window (ask before doing anything)"
1483   (let ((window (xlib:input-focus *display*))
1484         (*info-mode-placement* *ask-close/kill-placement*))
1485     (info-mode-menu
1486      (if (and window (not (xlib:window-equal window *no-focus-window*)))
1487          `(,(format nil "Focus window: ~A" (xlib:wm-name window))
1488             (#\s delete-focus-window "Close the focus window")
1489             (#\k destroy-focus-window "Kill the focus window")
1490             (#\x cut-focus-window)
1491             (#\c copy-focus-window)
1492             (#\v paste-selection))
1493          `(,(format nil "Focus window: None")
1494             (#\v paste-selection))))
1495     t))
1496
1497
1498
1499 ;;; Other window manager functions
1500 (defun get-proc-list ()
1501   (let ((proc (do-shell "ps x -o pid=" nil t))
1502         (proc-list nil))
1503     (loop for line = (read-line proc nil nil)
1504        while line
1505        do (push line proc-list))
1506     (dbg proc-list)
1507     proc-list))
1508
1509 (defun run-other-window-manager ()
1510   (let ((proc-start (get-proc-list)))
1511     (do-shell *other-window-manager* nil t :terminal)
1512     (let* ((proc-end (get-proc-list))
1513            (proc-diff (set-difference proc-end proc-start :test #'equal)))
1514       (dbg 'killing-sigterm proc-diff)
1515       (do-shell (format nil "kill ~{ ~A ~}  2> /dev/null" proc-diff) nil t :terminal)
1516       (dbg 'killing-sigkill proc-diff)
1517       (do-shell (format nil "kill -9 ~{ ~A ~} 2> /dev/null" proc-diff) nil t :terminal)
1518       (sleep 1))
1519     (setf *other-window-manager* nil)))
1520
1521
1522 (defun do-run-other-window-manager (window-manager)
1523   (setf *other-window-manager* window-manager)
1524   (throw 'exit-main-loop nil))
1525
1526 (defmacro def-run-other-window-manager (name &optional definition)
1527   (let ((definition (or definition name)))
1528     `(defun ,(create-symbol "run-" name) ()
1529        ,(format nil "Run ~A" definition)
1530        (do-run-other-window-manager ,(format nil "~A" name)))))
1531
1532 (def-run-other-window-manager "xterm")
1533 (def-run-other-window-manager "icewm")
1534 (def-run-other-window-manager "twm")
1535 (def-run-other-window-manager "gnome-session" "Gnome")
1536 (def-run-other-window-manager "startkde" "KDE")
1537 (def-run-other-window-manager "xfce4-session" "XFCE")
1538
1539 (defun run-lxde ()
1540   "Run LXDE"
1541   (do-run-other-window-manager "( lxsession & ); xterm -e \"echo '  /----------------------------------\\' ; echo '  |  CLFSWM Note:                    |' ; echo '  |    Close this window when done.  |' ; echo '  \\----------------------------------/'; echo; echo; $SHELL\""))
1542
1543 (defun run-xfce4 ()
1544   "Run LXDE (xterm)"
1545   (do-run-other-window-manager "( xfce4-session &) ; xterm -e \"echo '  /----------------------------------\\' ; echo '  |  CLFSWM Note:                    |' ; echo '  |    Close this window when done.  |' ; echo '  \\----------------------------------/'; echo; echo; $SHELL\""))
1546
1547
1548 (defun run-prompt-wm ()
1549   "Prompt for an other window manager"
1550   (let ((wm (query-string "Run an other window manager:" "icewm")))
1551     (do-run-other-window-manager wm)))
1552
1553
1554 ;;; Hide or show unmanaged windows utility.
1555 (defun set-hide-unmanaged-window ()
1556   "Hide unmanaged windows when frame is not selected"
1557   (when (frame-p (current-child))
1558     (setf (frame-data-slot (current-child) :unmanaged-window-action) :hide)
1559     (leave-second-mode)))
1560
1561 (defun set-show-unmanaged-window ()
1562   "Show unmanaged windows when frame is not selected"
1563   (when (frame-p (current-child))
1564     (setf (frame-data-slot (current-child) :unmanaged-window-action) :show)
1565     (leave-second-mode)))
1566
1567 (defun set-default-hide-unmanaged-window ()
1568   "Set default behaviour to hide or not unmanaged windows when frame is not selected"
1569   (when (frame-p (current-child))
1570     (setf (frame-data-slot (current-child) :unmanaged-window-action) nil)
1571     (leave-second-mode)))
1572
1573 (defun set-globally-hide-unmanaged-window ()
1574   "Hide unmanaged windows by default. This is overriden by functions above"
1575   (setf *hide-unmanaged-window* t)
1576   (leave-second-mode))
1577
1578 (defun set-globally-show-unmanaged-window ()
1579   "Show unmanaged windows by default. This is overriden by functions above"
1580   (setf *hide-unmanaged-window* nil)
1581   (leave-second-mode))
1582
1583
1584 ;;; Speed mouse movement.
1585 (let (minx miny maxx maxy history lx ly)
1586   (labels ((middle (x1 x2)
1587              (round (/ (+ x1 x2) 2)))
1588            (reset-if-moved (x y)
1589              (when (or (/= x (or lx x)) (/= y (or ly y)))
1590                (speed-mouse-reset)))
1591            (add-in-history (x y)
1592              (push (list x y) history)))
1593     (defun speed-mouse-reset ()
1594       "Reset speed mouse coordinates"
1595       (setf minx nil miny nil maxx nil maxy nil history nil lx nil ly nil))
1596     (defun speed-mouse-left ()
1597       "Speed move mouse to left"
1598       (with-x-pointer
1599         (reset-if-moved x y)
1600         (setf maxx x)
1601         (add-in-history x y)
1602         (setf lx (middle (or minx 0) maxx))
1603         (xlib:warp-pointer *root* lx y)))
1604     (defun speed-mouse-right ()
1605       "Speed move mouse to right"
1606       (with-x-pointer
1607         (reset-if-moved x y)
1608         (setf minx x)
1609         (add-in-history x y)
1610         (setf lx (middle minx (or maxx (xlib:screen-width *screen*))))
1611         (xlib:warp-pointer *root* lx y)))
1612     (defun speed-mouse-up ()
1613       "Speed move mouse to up"
1614       (with-x-pointer
1615         (reset-if-moved x y)
1616         (setf maxy y)
1617         (add-in-history x y)
1618         (setf ly (middle (or miny 0) maxy))
1619         (xlib:warp-pointer *root* x ly)))
1620     (defun speed-mouse-down ()
1621       "Speed move mouse to down"
1622       (with-x-pointer
1623         (reset-if-moved x y)
1624         (setf miny y)
1625         (add-in-history x y)
1626         (setf ly (middle miny (or maxy (xlib:screen-height *screen*))))
1627         (xlib:warp-pointer *root* x ly)))
1628     (defun speed-mouse-undo ()
1629       "Undo last speed mouse move"
1630       (when history
1631         (let ((h (pop history)))
1632           (when h
1633             (destructuring-bind (bx by) h
1634               (setf lx bx ly by
1635                     minx nil  maxx nil
1636                     miny nil  maxy nil)
1637               (xlib:warp-pointer *root* lx ly))))))
1638     (defun speed-mouse-first-history ()
1639       "Revert to the first speed move mouse"
1640       (when history
1641         (let ((h (first (last history))))
1642           (when h
1643             (setf lx (first h)
1644                   ly (second h))
1645             (xlib:warp-pointer *root* lx ly)))))))
1646
1647
1648
1649 ;;; Notify window functions
1650 (let (font
1651       window
1652       gc
1653       width height
1654       text
1655       current-child)
1656   (labels ((text-string (tx)
1657              (typecase tx
1658                (cons (first tx))
1659                (t tx)))
1660            (text-color (tx)
1661              (get-color (typecase tx
1662                           (cons (second tx))
1663                           (t *notify-window-foreground*)))))
1664     (defun is-notify-window-p (win)
1665       (when (and (xlib:window-p win) (xlib:window-p window))
1666         (xlib:window-equal win window)))
1667
1668     (defun refresh-notify-window ()
1669       (add-timer 0.1 #'refresh-notify-window :refresh-notify-window)
1670       (raise-window window)
1671       (let ((text-height (- (xlib:font-ascent font) (xlib:font-descent font))))
1672         (loop for tx in text
1673            for i from 1 do
1674              (setf (xlib:gcontext-foreground gc) (text-color tx))
1675              (xlib:draw-glyphs window gc
1676                                (truncate (/ (- width (* (xlib:max-char-width font) (length (text-string tx)))) 2))
1677                                (* text-height i 2)
1678                                (text-string tx)))))
1679
1680     (defun close-notify-window ()
1681       (erase-timer :refresh-notify-window)
1682       (setf *never-managed-window-list*
1683             (remove (list #'is-notify-window-p 'raise-window)
1684                     *never-managed-window-list* :test #'equal))
1685       (when gc
1686         (xlib:free-gcontext gc))
1687       (when window
1688         (xlib:destroy-window window))
1689       (when font
1690         (xlib:close-font font))
1691       (xlib:display-finish-output *display*)
1692       (setf window nil
1693             gc nil
1694             font nil))
1695
1696     (defun open-notify-window (text-list)
1697       (close-notify-window)
1698       (setf font (xlib:open-font *display* *notify-window-font-string*))
1699       (let ((text-height (- (xlib:font-ascent font) (xlib:font-descent font))))
1700         (setf text text-list)
1701         (setf width (* (xlib:max-char-width font) (+ (loop for tx in text-list
1702                                                         maximize (length (text-string tx))) 2))
1703               height (+ (* text-height (length text-list) 2) text-height))
1704         (with-placement (*notify-window-placement* x y width height)
1705           (setf window (xlib:create-window :parent *root*
1706                                            :x x
1707                                            :y y
1708                                            :width width
1709                                            :height height
1710                                            :background (get-color *notify-window-background*)
1711                                            :border-width *border-size*
1712                                            :border (get-color *notify-window-border*)
1713                                            :colormap (xlib:screen-default-colormap *screen*)
1714                                            :event-mask '(:exposure :key-press))
1715                 gc (xlib:create-gcontext :drawable window
1716                                          :foreground (get-color *notify-window-foreground*)
1717                                          :background (get-color *notify-window-background*)
1718                                          :font font
1719                                          :line-style :solid))
1720           (setf (window-transparency window) *notify-window-transparency*)
1721           (when (frame-p (current-child))
1722             (setf current-child (current-child)))
1723           (push (list #'is-notify-window-p 'raise-window) *never-managed-window-list*)
1724           (map-window window)
1725           (refresh-notify-window)
1726           (xlib:display-finish-output *display*))))))
1727
1728 (defun notify-message (delay &rest messages)
1729   (erase-timer :close-notify-window)
1730   (funcall #'open-notify-window messages)
1731   (add-timer delay #'close-notify-window :close-notify-window))
1732
1733
1734 (defun display-hello-window ()
1735   (notify-message *notify-window-delay*
1736                   '("Welcome to CLFSWM" "yellow")
1737                   "Press Alt+F1 for help"))
1738
1739
1740 ;;; Run or raise functions
1741 (defun run-or-raise (raisep run-fn &key (maximized nil))
1742   (let ((window (with-all-windows (*root-frame* win)
1743                   (when (funcall raisep win)
1744                     (return win)))))
1745     (if window
1746         (let ((parent (find-parent-frame window)))
1747           (setf (current-child) parent)
1748           (put-child-on-top window parent)
1749           (when maximized
1750             (change-root (find-root parent) parent))
1751           (focus-all-children window parent)
1752           (show-all-children t))
1753         (funcall run-fn))))
1754
1755 ;;; Transparency setting
1756 (defun inc-transparency (window root-x root-y)
1757   "Increment the child under mouse transparency"
1758   (declare (ignore root-x root-y))
1759   (unless *in-second-mode* (stop-button-event))
1760   (incf (child-transparency window) 0.1))
1761
1762 (defun dec-transparency (window root-x root-y)
1763   "Decrement the child under mouse transparency"
1764   (declare (ignore root-x root-y))
1765   (unless *in-second-mode* (stop-button-event))
1766   (decf (child-transparency window) 0.1))
1767
1768 (defun inc-transparency-slow (window root-x root-y)
1769   "Increment slowly the child under mouse transparency"
1770   (declare (ignore root-x root-y))
1771   (unless *in-second-mode* (stop-button-event))
1772   (incf (child-transparency window) 0.01))
1773
1774 (defun dec-transparency-slow (window root-x root-y)
1775   "Decrement slowly the child under mouse transparency"
1776   (declare (ignore root-x root-y))
1777   (unless *in-second-mode* (stop-button-event))
1778   (decf (child-transparency window) 0.01))
1779
1780
1781 (defun key-inc-transparency ()
1782   "Increment the current window transparency"
1783   (with-current-window
1784       (incf (child-transparency window) 0.1)))
1785
1786 (defun key-dec-transparency ()
1787   "Decrement the current window transparency"
1788   (with-current-window
1789       (decf (child-transparency window) 0.1)))
1790
1791
1792
1793
1794
1795 ;;; Geometry change functions
1796 (defun swap-frame-geometry ()
1797   "Swap current brother frame geometry"
1798   (when (frame-p (current-child))
1799     (let ((parent (find-parent-frame (current-child))))
1800       (when (frame-p parent)
1801         (let ((brother (second (frame-child parent))))
1802           (when (frame-p brother)
1803             (rotatef (frame-x (current-child)) (frame-x brother))
1804             (rotatef (frame-y (current-child)) (frame-y brother))
1805             (rotatef (frame-w (current-child)) (frame-w brother))
1806             (rotatef (frame-h (current-child)) (frame-h brother))
1807             (show-all-children t)
1808             (leave-second-mode)))))))
1809
1810 (defun rotate-frame-geometry-generic (fun)
1811   "(Rotate brother frame geometry"
1812   (when (frame-p (current-child))
1813     (let ((parent (find-parent-frame (current-child))))
1814       (when (frame-p parent)
1815         (let* ((child-list (funcall fun (frame-child parent)))
1816                (first (first child-list)))
1817           (dolist (child (rest child-list))
1818             (when (and (frame-p first) (frame-p child))
1819               (rotatef (frame-x first) (frame-x child))
1820               (rotatef (frame-y first) (frame-y child))
1821               (rotatef (frame-w first) (frame-w child))
1822               (rotatef (frame-h first) (frame-h child))
1823               (setf first child)))
1824           (show-all-children t))))))
1825
1826
1827 (defun rotate-frame-geometry ()
1828   "Rotate brother frame geometry"
1829   (rotate-frame-geometry-generic #'identity))
1830
1831 (defun anti-rotate-frame-geometry ()
1832   "Anti rotate brother frame geometry"
1833   (rotate-frame-geometry-generic #'reverse))
1834