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