src/clfswm-util.lisp

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