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