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