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