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 (find-parent-frame *current-child*))
 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 *current-root*)))
 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 *current-root*)))
 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 *current-root*))
 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 *current-root*)))
 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 *current-root*)))
 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 frame)))
 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 frame)))
 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 (focus-all-children child parent
 588                                                     (not (and (child-equal-p *current-child* *current-root*)
 589                                                               (xlib:window-p *current-root*)))))
 590           (when (show-all-children *current-root*)
 591             (setf to-replay nil))))
 592       (if to-replay
 593           (replay-button-event)
 594           (stop-button-event)))))
 595
 596
 597 (defun mouse-click-to-focus-and-move (window root-x root-y)
 598   "Move and focus the current frame or focus the current window parent.
 599 Or do actions on corners"
 600   (or (do-corner-action root-x root-y *corner-main-mode-left-button*)
 601       (mouse-click-to-focus-generic window root-x root-y #'move-frame)))
 602
 603 (defun mouse-click-to-focus-and-resize (window root-x root-y)
 604   "Resize and focus the current frame or focus the current window parent.
 605 Or do actions on corners"
 606   (or (do-corner-action root-x root-y *corner-main-mode-right-button*)
 607       (mouse-click-to-focus-generic window root-x root-y #'resize-frame)))
 608
 609 (defun mouse-middle-click (window root-x root-y)
 610   "Do actions on corners"
 611   (declare (ignore window))
 612   (or (do-corner-action root-x root-y *corner-main-mode-middle-button*)
 613       (replay-button-event)))
 614
 615
 616
 617
 618 (defun mouse-focus-move/resize-generic (root-x root-y mouse-fn window-parent)
 619   "Focus the current frame or focus the current window parent
 620 mouse-fun is #'move-frame or #'resize-frame.
 621 Focus child and its parents -
 622 For window: set current child to window or its parent according to window-parent"
 623   (labels ((move/resize-managed (child)
 624              (let ((parent (find-parent-frame child)))
 625                (when (and (child-equal-p child *current-root*)
 626                           (frame-p *current-root*))
 627                  (setf child (create-frame)
 628                        parent *current-root*
 629                        mouse-fn #'resize-frame)
 630                  (place-frame child parent root-x root-y 10 10)
 631                  (map-window (frame-window child))
 632                  (pushnew child (frame-child *current-root*)))
 633                (typecase child
 634                  (xlib:window
 635                   (if (managed-window-p child parent)
 636                       (funcall mouse-fn parent (find-parent-frame parent) root-x root-y)
 637                       (funcall (cond ((eql mouse-fn #'move-frame) #'move-window)
 638                                      ((eql mouse-fn #'resize-frame) #'resize-window))
 639                                child root-x root-y)))
 640                  (frame (funcall mouse-fn child parent root-x root-y)))
 641                (focus-all-children child parent window-parent)
 642                (show-all-children *current-root*)))
 643            (move/resize-never-managed (child raise-fun)
 644              (funcall raise-fun child)
 645              (funcall (cond ((eql mouse-fn #'move-frame) #'move-window)
 646                             ((eql mouse-fn #'resize-frame) #'resize-window))
 647                       child root-x root-y)))
 648     (let ((child (find-child-under-mouse root-x root-y nil t)))
 649       (multiple-value-bind (never-managed raise-fun)
 650           (never-managed-window-p child)
 651         (if (and (xlib:window-p child) never-managed raise-fun)
 652             (move/resize-never-managed child raise-fun)
 653             (move/resize-managed child))))))
 654
 655
 656
 657
 658
 659 (defun test-mouse-binding (window root-x root-y)
 660   (dbg window root-x root-y)
 661   (replay-button-event))
 662
 663
 664
 665 (defun mouse-select-next-level (window root-x root-y)
 666   "Select the next level in frame"
 667   (declare (ignore root-x root-y))
 668   (let ((frame (find-frame-window window)))
 669     (when (or frame (xlib:window-equal window *root*))
 670       (select-next-level))
 671     (replay-button-event)))
 672
 673
 674
 675 (defun mouse-select-previous-level (window root-x root-y)
 676   "Select the previous level in frame"
 677   (declare (ignore root-x root-y))
 678   (let ((frame (find-frame-window window)))
 679     (when (or frame (xlib:window-equal window *root*))
 680       (select-previous-level))
 681     (replay-button-event)))
 682
 683
 684
 685 (defun mouse-enter-frame (window root-x root-y)
 686   "Enter in the selected frame - ie make it the root frame"
 687   (declare (ignore root-x root-y))
 688   (let ((frame (find-frame-window window)))
 689     (when (or frame (xlib:window-equal window *root*))
 690       (enter-frame))
 691     (replay-button-event)))
 692
 693
 694
 695 (defun mouse-leave-frame (window root-x root-y)
 696   "Leave the selected frame - ie make its parent the root frame"
 697   (declare (ignore root-x root-y))
 698   (let ((frame (find-frame-window window)))
 699     (when (or frame (xlib:window-equal window *root*))
 700       (leave-frame))
 701     (replay-button-event)))
 702
 703
 704
 705 ;;;;;,-----
 706 ;;;;;| Various definitions
 707 ;;;;;`-----
 708
 709 (defun show-help (&optional (browser "dillo") (tempfile "/tmp/clfswm.html"))
 710   "Show current keys and buttons bindings"
 711   (ignore-errors
 712     (produce-doc-html-in-file tempfile))
 713   (sleep 1)
 714   (do-shell (format nil "~A ~A" browser tempfile)))
 715
 716
 717
 718 ;;;  Bind or jump functions
 719 (let ((key-slots (make-array 10 :initial-element nil))
 720       (current-slot 1))
 721   (defun bind-on-slot (&optional (slot current-slot))
 722     "Bind current child to slot"
 723     (setf (aref key-slots slot) *current-child*))
 724
 725   (defun remove-binding-on-slot ()
 726     "Remove binding on slot"
 727     (setf (aref key-slots current-slot) nil))
 728
 729   (defun jump-to-slot ()
 730     "Jump to slot"
 731     (let ((jump-child (aref key-slots current-slot)))
 732       (when (find-child jump-child *root-frame*)
 733         (hide-all *current-root*)
 734         (setf *current-root* jump-child
 735               *current-child* *current-root*)
 736         (focus-all-children *current-child* *current-child*)
 737         (show-all-children *current-root*))))
 738
 739   (defun bind-or-jump (n)
 740     "Bind or jump to a slot (a frame or a window)"
 741     (setf current-slot (- n 1))
 742     (let ((default-bind `("b" bind-on-slot
 743                               ,(format nil "Bind slot ~A on child: ~A" n (child-fullname *current-child*)))))
 744       (info-mode-menu (aif (aref key-slots current-slot)
 745                            `(,default-bind
 746                                 ("BackSpace" remove-binding-on-slot
 747                                              ,(format nil "Remove slot ~A binding on child: ~A" n (child-fullname *current-child*)))
 748                                 ("   -  " nil " -")
 749                               ("Tab" jump-to-slot
 750                                      ,(format nil "Jump to child: ~A" (aif (aref key-slots current-slot)
 751                                                                            (child-fullname it)
 752                                                                            "Not set - Please, bind it with 'b'")))
 753                               ("Return" jump-to-slot "Same thing")
 754                               ("space" jump-to-slot "Same thing"))
 755                            (list default-bind))))))
 756
 757
 758
 759 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 760 ;;; Useful function for the second mode ;;;
 761 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 762 (defmacro with-movement (&body body)
 763   `(when (frame-p *current-child*)
 764      ,@body
 765      (show-all-children)
 766      (display-all-frame-info)
 767      (draw-second-mode-window)
 768      (open-menu (find-menu 'frame-movement-menu))))
 769
 770
 771 ;;; Pack
 772 (defun current-frame-pack-up ()
 773   "Pack the current frame up"
 774   (with-movement (pack-frame-up *current-child* (find-parent-frame *current-child* *current-root*))))
 775
 776 (defun current-frame-pack-down ()
 777   "Pack the current frame down"
 778   (with-movement (pack-frame-down *current-child* (find-parent-frame *current-child* *current-root*))))
 779
 780 (defun current-frame-pack-left ()
 781   "Pack the current frame left"
 782   (with-movement (pack-frame-left *current-child* (find-parent-frame *current-child* *current-root*))))
 783
 784 (defun current-frame-pack-right ()
 785   "Pack the current frame right"
 786   (with-movement (pack-frame-right *current-child* (find-parent-frame *current-child* *current-root*))))
 787
 788 ;;; Center
 789 (defun center-current-frame ()
 790   "Center the current frame"
 791   (with-movement (center-frame *current-child*)))
 792
 793 ;;; Fill
 794 (defun current-frame-fill-up ()
 795   "Fill the current frame up"
 796   (with-movement (fill-frame-up *current-child* (find-parent-frame *current-child* *current-root*))))
 797
 798 (defun current-frame-fill-down ()
 799   "Fill the current frame down"
 800   (with-movement (fill-frame-down *current-child* (find-parent-frame *current-child* *current-root*))))
 801
 802 (defun current-frame-fill-left ()
 803   "Fill the current frame left"
 804   (with-movement (fill-frame-left *current-child* (find-parent-frame *current-child* *current-root*))))
 805
 806 (defun current-frame-fill-right ()
 807   "Fill the current frame right"
 808   (with-movement (fill-frame-right *current-child* (find-parent-frame *current-child* *current-root*))))
 809
 810 (defun current-frame-fill-all-dir ()
 811   "Fill the current frame in all directions"
 812   (with-movement
 813     (let ((parent (find-parent-frame *current-child* *current-root*)))
 814       (fill-frame-up *current-child* parent)
 815       (fill-frame-down *current-child* parent)
 816       (fill-frame-left *current-child* parent)
 817       (fill-frame-right *current-child* parent))))
 818
 819 (defun current-frame-fill-vertical ()
 820   "Fill the current frame vertically"
 821   (with-movement
 822     (let ((parent (find-parent-frame *current-child* *current-root*)))
 823       (fill-frame-up *current-child* parent)
 824       (fill-frame-down *current-child* parent))))
 825
 826 (defun current-frame-fill-horizontal ()
 827   "Fill the current frame horizontally"
 828   (with-movement
 829     (let ((parent (find-parent-frame *current-child* *current-root*)))
 830       (fill-frame-left *current-child* parent)
 831       (fill-frame-right *current-child* parent))))
 832
 833
 834 ;;; Resize
 835 (defun current-frame-resize-up ()
 836   "Resize the current frame up to its half height"
 837   (with-movement (resize-half-height-up *current-child*)))
 838
 839 (defun current-frame-resize-down ()
 840   "Resize the current frame down to its half height"
 841   (with-movement (resize-half-height-down *current-child*)))
 842
 843 (defun current-frame-resize-left ()
 844   "Resize the current frame left to its half width"
 845   (with-movement (resize-half-width-left *current-child*)))
 846
 847 (defun current-frame-resize-right ()
 848   "Resize the current frame right to its half width"
 849   (with-movement (resize-half-width-right *current-child*)))
 850
 851 (defun current-frame-resize-all-dir ()
 852   "Resize down the current frame"
 853   (with-movement (resize-frame-down *current-child*)))
 854
 855 (defun current-frame-resize-all-dir-minimal ()
 856   "Resize down the current frame to its minimal size"
 857   (with-movement (resize-minimal-frame *current-child*)))
 858
 859
 860 ;;; Children navigation
 861 (defun with-movement-select-next-brother ()
 862   "Select the next brother frame"
 863   (with-movement (select-next-brother)))
 864
 865 (defun with-movement-select-previous-brother ()
 866   "Select the previous brother frame"
 867   (with-movement (select-previous-brother)))
 868
 869 (defun with-movement-select-next-level ()
 870   "Select the next level"
 871   (with-movement (select-next-level)))
 872
 873 (defun with-movement-select-previous-level ()
 874   "Select the previous levelframe"
 875   (with-movement (select-previous-level)))
 876
 877 (defun with-movement-select-next-child ()
 878   "Select the next child"
 879   (with-movement (select-next-child)))
 880
 881
 882
 883 ;;; Adapt frame functions
 884 (defun adapt-current-frame-to-window-hints-generic (width-p height-p)
 885   "Adapt the current frame to the current window minimal size hints"
 886   (when (frame-p *current-child*)
 887     (let ((window (first (frame-child *current-child*))))
 888       (when (xlib:window-p window)
 889         (let* ((hints (xlib:wm-normal-hints window))
 890                (min-width (and hints (xlib:wm-size-hints-min-width hints)))
 891                (min-height (and hints (xlib:wm-size-hints-min-height hints))))
 892           (when (and width-p min-width)
 893             (setf (frame-rw *current-child*) min-width))
 894           (when (and height-p min-height)
 895             (setf (frame-rh *current-child*) min-height))
 896           (fixe-real-size *current-child* (find-parent-frame *current-child*))
 897           (leave-second-mode))))))
 898
 899 (defun adapt-current-frame-to-window-hints ()
 900   "Adapt the current frame to the current window minimal size hints"
 901   (adapt-current-frame-to-window-hints-generic t t))
 902
 903 (defun adapt-current-frame-to-window-width-hint ()
 904   "Adapt the current frame to the current window minimal width hint"
 905   (adapt-current-frame-to-window-hints-generic t nil))
 906
 907 (defun adapt-current-frame-to-window-height-hint ()
 908   "Adapt the current frame to the current window minimal height hint"
 909   (adapt-current-frame-to-window-hints-generic nil t))
 910
 911
 912
 913
 914 ;;; Managed window type functions
 915 (defun current-frame-manage-window-type-generic (type-list)
 916   (when (frame-p *current-child*)
 917     (setf (frame-managed-type *current-child*) type-list
 918           (frame-forced-managed-window *current-child*) nil
 919           (frame-forced-unmanaged-window *current-child*) nil))
 920   (leave-second-mode))
 921
 922
 923 (defun current-frame-manage-window-type ()
 924   "Change window types to be managed by a frame"
 925   (when (frame-p *current-child*)
 926     (let* ((type-str (query-string "Managed window type: (all, normal, transient, maxsize, desktop, dock, toolbar, menu, utility, splash, dialog)"
 927                                    (format nil "~{~:(~A~) ~}" (frame-managed-type *current-child*))))
 928            (type-list (loop :for type :in (split-string type-str)
 929                          :collect (intern (string-upcase type) :keyword))))
 930       (current-frame-manage-window-type-generic type-list))))
 931
 932
 933 (defun current-frame-manage-all-window-type ()
 934   "Manage all window type"
 935   (current-frame-manage-window-type-generic '(:all)))
 936
 937 (defun current-frame-manage-only-normal-window-type ()
 938   "Manage only normal window type"
 939   (current-frame-manage-window-type-generic '(:normal)))
 940
 941 (defun current-frame-manage-no-window-type ()
 942   "Do not manage any window type"
 943   (current-frame-manage-window-type-generic nil))
 944
 945
 946
 947
 948
 949
 950
 951
 952 ;;; Force window functions
 953 (defun force-window-in-frame ()
 954   "Force the current window to move in the frame (Useful only for unmanaged windows)"
 955   (with-current-window
 956     (let ((parent (find-parent-frame window)))
 957       (setf (xlib:drawable-x window) (frame-rx parent)
 958             (xlib:drawable-y window) (frame-ry parent))
 959       (xlib:display-finish-output *display*)))
 960   (leave-second-mode))
 961
 962
 963 (defun force-window-center-in-frame ()
 964   "Force the current window to move in the center of the frame (Useful only for unmanaged windows)"
 965   (with-current-window
 966     (let ((parent (find-parent-frame window)))
 967       (setf (xlib:drawable-x window) (truncate (+ (frame-rx parent)
 968                                                   (/ (- (frame-rw parent)
 969                                                         (xlib:drawable-width window)) 2)))
 970             (xlib:drawable-y window) (truncate (+ (frame-ry parent)
 971                                                   (/ (- (frame-rh parent)
 972                                                         (xlib:drawable-height window)) 2))))
 973       (xlib:display-finish-output *display*)))
 974   (leave-second-mode))
 975
 976
 977
 978 (defun display-current-window-info ()
 979   "Display information on the current window"
 980   (with-current-window
 981     (info-mode (list (format nil "Window:       ~A" window)
 982                      (format nil "Window name:  ~A" (xlib:wm-name window))
 983                      (format nil "Window class: ~A" (xlib:get-wm-class window))
 984                      (format nil "Window type:  ~:(~A~)" (window-type window))
 985                      (format nil "Window id:    0x~X" (xlib:window-id window)))))
 986   (leave-second-mode))
 987
 988
 989 (defun manage-current-window ()
 990   "Force to manage the current window by its parent frame"
 991   (with-current-window
 992     (let ((parent (find-parent-frame window)))
 993       (with-slots ((managed forced-managed-window)
 994                    (unmanaged forced-unmanaged-window)) parent
 995         (setf unmanaged (child-remove window unmanaged)
 996               unmanaged (remove (xlib:wm-name window) unmanaged :test #'string-equal-p))
 997         (pushnew window managed))))
 998   (leave-second-mode))
 999
1000 (defun unmanage-current-window ()
1001   "Force to not manage the current window by its parent frame"
1002   (with-current-window
1003     (let ((parent (find-parent-frame window)))
1004       (with-slots ((managed forced-managed-window)
1005                    (unmanaged forced-unmanaged-window)) parent
1006         (setf managed (child-remove window managed)
1007               managed (remove (xlib:wm-name window) managed :test #'string-equal-p))
1008         (pushnew window unmanaged))))
1009   (leave-second-mode))
1010
1011
1012
1013 ;;; Moving child with the mouse button
1014 (defun mouse-move-child-over-frame (window root-x root-y)
1015   "Move the child under the mouse cursor to another frame"
1016   (declare (ignore window))
1017   (let ((child (find-child-under-mouse root-x root-y)))
1018     (unless (child-equal-p child *current-root*)
1019       (hide-all child)
1020       (remove-child-in-frame child (find-parent-frame child))
1021       (wait-mouse-button-release 50 51)
1022       (multiple-value-bind (x y)
1023           (xlib:query-pointer *root*)
1024         (let ((dest (find-child-under-mouse x y)))
1025           (when (xlib:window-p dest)
1026             (setf dest (find-parent-frame dest)))
1027           (unless (child-equal-p child dest)
1028             (move-child-to child dest)
1029             (show-all-children *current-root*))))))
1030   (stop-button-event))
1031
1032
1033
1034
1035 ;;; Hide/Show frame window functions
1036 (defun hide/show-frame-window (frame value)
1037   "Hide/show the frame window"
1038   (when (frame-p frame)
1039     (setf (frame-show-window-p *current-child*) value)
1040     (show-all-children *current-root*))
1041   (leave-second-mode))
1042
1043
1044 (defun hide-current-frame-window ()
1045   "Hide the current frame window"
1046   (hide/show-frame-window *current-child* nil))
1047
1048 (defun show-current-frame-window ()
1049   "Show the current frame window"
1050   (hide/show-frame-window *current-child* t))
1051
1052
1053
1054 ;;; Hide/Unhide current child
1055 (defun hide-current-child ()
1056   "Hide the current child"
1057   (unless (child-equal-p *current-child* *current-root*)
1058     (let ((parent (find-parent-frame *current-child*)))
1059       (when (frame-p parent)
1060         (with-slots (child hidden-children) parent
1061           (hide-all *current-child*)
1062           (setf child (child-remove *current-child* child))
1063           (pushnew *current-child* hidden-children)
1064           (setf *current-child* parent))
1065         (show-all-children)))
1066     (leave-second-mode)))
1067
1068
1069 (defun frame-unhide-child (hidden frame-src frame-dest)
1070   "Unhide a hidden child from frame-src in frame-dest"
1071   (with-slots (hidden-children) frame-src
1072     (setf hidden-children (child-remove hidden hidden-children)))
1073   (with-slots (child) frame-dest
1074     (pushnew hidden child)))
1075
1076
1077
1078 (defun unhide-a-child ()
1079   "Unhide a child in the current frame"
1080   (when (frame-p *current-child*)
1081     (with-slots (child hidden-children) *current-child*
1082       (info-mode-menu (loop :for i :from 0
1083                          :for hidden :in hidden-children
1084                          :collect (list (code-char (+ (char-code #\a) i))
1085                                         (let ((lhd hidden))
1086                                           (lambda ()
1087                                             (frame-unhide-child lhd *current-child* *current-child*)))
1088                                         (format nil "Unhide ~A" (child-fullname hidden))))))
1089     (show-all-children))
1090   (leave-second-mode))
1091
1092
1093 (defun unhide-all-children ()
1094   "Unhide all current frame hidden children"
1095   (when (frame-p *current-child*)
1096     (with-slots (child hidden-children) *current-child*
1097       (dolist (c hidden-children)
1098         (pushnew c child))
1099       (setf hidden-children nil))
1100     (show-all-children))
1101   (leave-second-mode))
1102
1103
1104 (defun unhide-a-child-from-all-frames ()
1105   "Unhide a child from all frames in the current frame"
1106   (when (frame-p *current-child*)
1107     (let ((acc nil)
1108           (keynum -1))
1109       (with-all-frames (*root-frame* frame)
1110         (when (frame-hidden-children frame)
1111           (push (format nil "~A" (child-fullname frame)) acc)
1112           (dolist (hidden (frame-hidden-children frame))
1113             (push (list (code-char (+ (char-code #\a) (incf keynum)))
1114                         (let ((lhd hidden))
1115                           (lambda ()
1116                             (frame-unhide-child lhd frame *current-child*)))
1117                         (format nil "Unhide ~A" (child-fullname hidden)))
1118                   acc))))
1119       (info-mode-menu (nreverse acc)))
1120     (show-all-children))
1121   (leave-second-mode))
1122
1123
1124
1125
1126
1127 (let ((last-child nil))
1128   (defun init-last-child ()
1129     (setf last-child nil))
1130   (defun switch-to-last-child ()
1131     "Store the current child and switch to the previous one"
1132     (let ((current-child *current-child*))
1133       (when last-child
1134         (hide-all *current-root*)
1135         (setf *current-root* last-child
1136               *current-child* *current-root*)
1137         (focus-all-children *current-child* *current-child*)
1138         (show-all-children *current-root*))
1139       (setf last-child current-child))))
1140
1141
1142
1143
1144
1145
1146
1147 ;;; Focus policy functions
1148 (defun set-focus-policy-generic (focus-policy)
1149   (when (frame-p *current-child*)
1150     (setf (frame-focus-policy *current-child*) focus-policy))
1151   (leave-second-mode))
1152
1153
1154 (defun current-frame-set-click-focus-policy ()
1155   "Set a click focus policy for the current frame."
1156   (set-focus-policy-generic :click))
1157
1158 (defun current-frame-set-sloppy-focus-policy ()
1159   "Set a sloppy focus policy for the current frame."
1160   (set-focus-policy-generic :sloppy))
1161
1162 (defun current-frame-set-sloppy-strict-focus-policy ()
1163   "Set a (strict) sloppy focus policy only for windows in the current frame."
1164   (set-focus-policy-generic :sloppy-strict))
1165
1166 (defun current-frame-set-sloppy-select-policy ()
1167   "Set a sloppy select policy for the current frame."
1168     (set-focus-policy-generic :sloppy-select))
1169
1170
1171
1172 (defun set-focus-policy-generic-for-all (focus-policy)
1173   (with-all-frames (*root-frame* frame)
1174     (setf (frame-focus-policy frame) focus-policy))
1175   (leave-second-mode))
1176
1177
1178 (defun all-frames-set-click-focus-policy ()
1179   "Set a click focus policy for all frames."
1180   (set-focus-policy-generic-for-all :click))
1181
1182 (defun all-frames-set-sloppy-focus-policy ()
1183   "Set a sloppy focus policy for all frames."
1184   (set-focus-policy-generic-for-all :sloppy))
1185
1186 (defun all-frames-set-sloppy-strict-focus-policy ()
1187   "Set a (strict) sloppy focus policy for all frames."
1188   (set-focus-policy-generic-for-all :sloppy-strict))
1189
1190 (defun all-frames-set-sloppy-select-policy ()
1191   "Set a sloppy select policy for all frames."
1192     (set-focus-policy-generic-for-all :sloppy-select))
1193
1194
1195
1196 ;;; Ensure unique name/number functions
1197 (defun extract-number-from-name (name)
1198   (when (stringp name)
1199     (let* ((pos (1+ (or (position #\. name :from-end t) -1)))
1200            (number (parse-integer name :junk-allowed t :start pos)))
1201       (values number
1202               (if number (subseq name 0 (1- pos)) name)))))
1203
1204
1205
1206
1207 (defun ensure-unique-name ()
1208   "Ensure that all children names are unique"
1209   (with-all-children (*root-frame* child)
1210     (multiple-value-bind (num1 name1)
1211         (extract-number-from-name (child-name child))
1212       (declare (ignore num1))
1213       (when name1
1214         (let ((acc nil))
1215           (with-all-children (*root-frame* c)
1216             (unless (child-equal-p child c))
1217             (multiple-value-bind (num2 name2)
1218                 (extract-number-from-name (child-name c))
1219               (when (string-equal name1 name2)
1220                 (push num2 acc))))
1221           (dbg acc)
1222           (when (> (length acc) 1)
1223             (setf (child-name child)
1224                   (format nil "~A.~A" name1
1225                           (1+ (find-free-number (loop for i in acc when i collect (1- i)))))))))))
1226   (leave-second-mode))
1227
1228 (defun ensure-unique-number ()
1229   "Ensure that all children numbers are unique"
1230   (let ((num -1))
1231     (with-all-frames (*root-frame* frame)
1232       (setf (frame-number frame) (incf num))))
1233   (leave-second-mode))
1234
1235
1236
1237 ;;; Standard menu functions - Based on the XDG specifications
1238 (defparameter *xdg-section-list* (append '(TextEditor FileManager WebBrowser)
1239                                          '(AudioVideo Audio Video Development Education Game Graphics Network Office Settings System Utility)
1240                                          '(TerminalEmulator Archlinux Screensaver))
1241   "Config(Menu group): Standard menu sections")
1242
1243
1244 (defun um-create-xdg-section-list (menu)
1245   (dolist (section *xdg-section-list*)
1246     (add-sub-menu menu :next section (format nil "~A" section) menu)))
1247
1248 (defun um-find-submenu (menu section-list)
1249   (let ((acc nil))
1250     (dolist (section section-list)
1251       (awhen (find-toplevel-menu (intern (string-upcase section) :clfswm) menu)
1252         (push it acc)))
1253     (if acc
1254         acc
1255         (list (find-toplevel-menu 'Utility menu)))))
1256
1257
1258 (defun um-extract-value (line)
1259   (second (split-string line #\=)))
1260
1261
1262 (defun um-add-desktop (desktop menu)
1263   (let (name exec categories comment)
1264     (when (probe-file desktop)
1265       (with-open-file (stream desktop :direction :input)
1266         (loop for line = (read-line stream nil nil)
1267            while line
1268            do
1269            (cond ((first-position "Name=" line) (setf name (um-extract-value line)))
1270                  ((first-position "Exec=" line) (setf exec (um-extract-value line)))
1271                  ((first-position "Categories=" line) (setf categories (um-extract-value line)))
1272                  ((first-position "Comment=" line) (setf comment (um-extract-value line))))
1273            (when (and name exec categories)
1274              (let* ((sub-menu (um-find-submenu menu (split-string categories #\;)))
1275                     (fun-name (intern name :clfswm)))
1276                (setf (symbol-function fun-name) (let ((do-exec exec))
1277                                                   (lambda ()
1278                                                     (do-shell do-exec)
1279                                                     (leave-second-mode)))
1280                      (documentation fun-name 'function) (format nil "~A~A" name (if comment
1281                                                                                     (format nil " - ~A" comment)
1282                                                                                     "")))
1283                (dolist (m sub-menu)
1284                  (add-menu-key (menu-name m) :next fun-name m)))
1285              (setf name nil exec nil categories nil comment nil)))))))
1286
1287
1288 (defun update-menus (&optional (menu (make-menu :name 'main :doc "Main menu")))
1289   (um-create-xdg-section-list menu)
1290   (let ((count 0)
1291         (found (make-hash-table :test #'equal)))
1292     (dolist (dir (remove-duplicates
1293                   (split-string (getenv "XDG_DATA_DIRS") #\:) :test #'string-equal))
1294       (dolist (desktop (directory (concatenate 'string dir "/applications/**/*.desktop")))
1295         (unless (gethash (file-namestring desktop) found)
1296           (setf (gethash (file-namestring desktop) found) t)
1297           (um-add-desktop desktop menu)
1298           (incf count))))
1299     menu))
1300
1301
1302
1303 ;;; Close/Kill focused window
1304
1305 (defun ask-close/kill-current-window ()
1306   "Close or kill the current window (ask before doing anything)"
1307   (let ((window (xlib:input-focus *display*)))
1308     (info-mode-menu
1309      (if (and window (not (xlib:window-equal window *no-focus-window*)))
1310          `(,(format nil "Focus window: ~A" (xlib:wm-name window))
1311             (#\c delete-focus-window "Close the focus window")
1312             (#\k destroy-focus-window "Kill the focus window")
1313             (#\r remove-focus-window)
1314             (#\u unhide-all-windows-in-current-child))
1315          `(,(format nil "Focus window: None")
1316             (#\u unhide-all-windows-in-current-child))))))
1317
1318
1319
1320 ;;; Other window manager functions
1321 (defun get-proc-list ()
1322   (let ((proc (do-shell "ps x -o pid=" nil t))
1323         (proc-list nil))
1324     (loop for line = (read-line proc nil nil)
1325        while line
1326        do (push line proc-list))
1327     (dbg proc-list)
1328     proc-list))
1329
1330 (defun run-other-window-manager ()
1331   (let ((proc-start (get-proc-list)))
1332     (do-shell *other-window-manager* nil t :terminal)
1333     (let* ((proc-end (get-proc-list))
1334            (proc-diff (set-difference proc-end proc-start :test #'equal)))
1335       (dbg 'killing-sigterm proc-diff)
1336       (do-shell (format nil "kill ~{ ~A ~}  2> /dev/null" proc-diff) nil t :terminal)
1337       (dbg 'killing-sigkill proc-diff)
1338       (do-shell (format nil "kill -9 ~{ ~A ~} 2> /dev/null" proc-diff) nil t :terminal)
1339       (sleep 1))
1340     (setf *other-window-manager* nil)))
1341
1342
1343 (defun do-run-other-window-manager (window-manager)
1344   (setf *other-window-manager* window-manager)
1345   (throw 'exit-main-loop nil))
1346
1347 (defmacro def-run-other-window-manager (name &optional definition)
1348   (let ((definition (or definition name)))
1349     `(defun ,(create-symbol "run-" name) ()
1350        ,(format nil "Run ~A" definition)
1351        (do-run-other-window-manager ,(format nil "~A" name)))))
1352
1353 (def-run-other-window-manager "xterm")
1354 (def-run-other-window-manager "icewm")
1355 (def-run-other-window-manager "twm")
1356 (def-run-other-window-manager "gnome-session" "Gnome")
1357 (def-run-other-window-manager "startkde" "KDE")
1358 (def-run-other-window-manager "xfce4-session" "XFCE")
1359
1360 (defun run-lxde ()
1361   "Run LXDE"
1362   (do-run-other-window-manager "( lxsession & ); xterm -e \"echo '  /----------------------------------\\' ; echo '  |  CLFSWM Note:                    |' ; echo '  |    Close this window when done.  |' ; echo '  \\----------------------------------/'; echo; echo; $SHELL\""))
1363
1364 (defun run-xfce4 ()
1365   "Run LXDE (xterm)"
1366   (do-run-other-window-manager "( xfce4-session &) ; xterm -e \"echo '  /----------------------------------\\' ; echo '  |  CLFSWM Note:                    |' ; echo '  |    Close this window when done.  |' ; echo '  \\----------------------------------/'; echo; echo; $SHELL\""))
1367
1368
1369 (defun run-prompt-wm ()
1370   "Prompt for an other window manager"
1371   (let ((wm (query-string "Run an other window manager:" "icewm")))
1372     (do-run-other-window-manager wm)))
1373
1374
1375 ;;; Hide or show unmanaged windows utility.
1376 (defun set-hide-unmanaged-window ()
1377   "Hide unmanaged windows when frame is not selected"
1378   (when (frame-p *current-child*)
1379     (setf (frame-data-slot *current-child* :unmanaged-window-action) :hide)
1380     (leave-second-mode)))
1381
1382 (defun set-show-unmanaged-window ()
1383   "Show unmanaged windows when frame is not selected"
1384   (when (frame-p *current-child*)
1385     (setf (frame-data-slot *current-child* :unmanaged-window-action) :show)
1386     (leave-second-mode)))
1387
1388 (defun set-default-hide-unmanaged-window ()
1389   "Set default behaviour to hide or not unmanaged windows when frame is not selected"
1390   (when (frame-p *current-child*)
1391     (setf (frame-data-slot *current-child* :unmanaged-window-action) nil)
1392     (leave-second-mode)))
1393
1394 (defun set-globally-hide-unmanaged-window ()
1395   "Hide unmanaged windows by default. This is overriden by functions above"
1396   (setf *hide-unmanaged-window* t)
1397   (leave-second-mode))
1398
1399 (defun set-globally-show-unmanaged-window ()
1400   "Show unmanaged windows by default. This is overriden by functions above"
1401   (setf *hide-unmanaged-window* nil)
1402   (leave-second-mode))
1403
1404
1405 ;;; Speed mouse movement.
1406 (let (minx miny maxx maxy history lx ly)
1407   (labels ((middle (x1 x2)
1408              (round (/ (+ x1 x2) 2)))
1409            (reset-if-moved (x y)
1410              (when (or (/= x (or lx x)) (/= y (or ly y)))
1411                (speed-mouse-reset)))
1412            (add-in-history (x y)
1413              (push (list x y) history)))
1414     (defun speed-mouse-reset ()
1415       "Reset speed mouse coordinates"
1416       (setf minx nil miny nil maxx nil maxy nil history nil lx nil ly nil))
1417     (defun speed-mouse-left ()
1418       "Speed move mouse to left"
1419       (with-x-pointer
1420         (reset-if-moved x y)
1421         (setf maxx x)
1422         (add-in-history x y)
1423         (setf lx (middle (or minx 0) maxx))
1424         (xlib:warp-pointer *root* lx y)))
1425     (defun speed-mouse-right ()
1426       "Speed move mouse to right"
1427       (with-x-pointer
1428         (reset-if-moved x y)
1429         (setf minx x)
1430         (add-in-history x y)
1431         (setf lx (middle minx (or maxx (xlib:screen-width *screen*))))
1432         (xlib:warp-pointer *root* lx y)))
1433     (defun speed-mouse-up ()
1434       "Speed move mouse to up"
1435       (with-x-pointer
1436         (reset-if-moved x y)
1437         (setf maxy y)
1438         (add-in-history x y)
1439         (setf ly (middle (or miny 0) maxy))
1440         (xlib:warp-pointer *root* x ly)))
1441     (defun speed-mouse-down ()
1442       "Speed move mouse to down"
1443       (with-x-pointer
1444         (reset-if-moved x y)
1445         (setf miny y)
1446         (add-in-history x y)
1447         (setf ly (middle miny (or maxy (xlib:screen-height *screen*))))
1448         (xlib:warp-pointer *root* x ly)))
1449     (defun speed-mouse-undo ()
1450       "Undo last speed mouse move"
1451       (when history
1452         (let ((h (pop history)))
1453           (when h
1454             (destructuring-bind (bx by) h
1455               (setf lx bx ly by
1456                     minx nil  maxx nil
1457                     miny nil  maxy nil)
1458               (xlib:warp-pointer *root* lx ly))))))
1459     (defun speed-mouse-first-history ()
1460       "Revert to the first speed move mouse"
1461       (when history
1462         (let ((h (first (last history))))
1463           (when h
1464             (setf lx (first h)
1465                   ly (second h))
1466             (xlib:warp-pointer *root* lx ly)))))))
1467
1468
1469
1470 ;;; Notify window functions
1471 (let (font
1472       window
1473       gc
1474       width height
1475       text
1476       current-child)
1477   (labels ((text-string (tx)
1478              (typecase tx
1479                (cons (first tx))
1480                (t tx)))
1481            (text-color (tx)
1482              (get-color (typecase tx
1483                           (cons (second tx))
1484                           (t *notify-window-foreground*)))))
1485     (defun is-notify-window-p (win)
1486       (when (and (xlib:window-p win) (xlib:window-p window))
1487         (xlib:window-equal win window)))
1488
1489     (defun refresh-notify-window ()
1490       (add-timer 0.1 #'refresh-notify-window :refresh-notify-window)
1491       (raise-window window)
1492       (let ((text-height (- (xlib:font-ascent font) (xlib:font-descent font))))
1493         (loop for tx in text
1494            for i from 1 do
1495              (setf (xlib:gcontext-foreground gc) (text-color tx))
1496              (xlib:draw-glyphs window gc
1497                                (truncate (/ (- width (* (xlib:max-char-width font) (length (text-string tx)))) 2))
1498                                (* text-height i 2)
1499                                (text-string tx)))))
1500
1501     (defun close-notify-window ()
1502       (erase-timer :refresh-notify-window)
1503       (setf *never-managed-window-list*
1504             (remove (list #'is-notify-window-p 'raise-window)
1505                     *never-managed-window-list* :test #'equal))
1506       (when gc
1507         (xlib:free-gcontext gc))
1508       (when window
1509         (xlib:destroy-window window))
1510       (when font
1511         (xlib:close-font font))
1512       (xlib:display-finish-output *display*)
1513       (setf window nil
1514             gc nil
1515             font nil))
1516
1517     (defun open-notify-window (text-list)
1518       (close-notify-window)
1519       (setf font (xlib:open-font *display* *notify-window-font-string*))
1520       (let ((text-height (- (xlib:font-ascent font) (xlib:font-descent font))))
1521         (setf text text-list)
1522         (setf width (* (xlib:max-char-width font) (+ (loop for tx in text-list
1523                                                         maximize (length (text-string tx))) 2))
1524               height (+ (* text-height (length text-list) 2) text-height))
1525         (with-placement (*notify-window-placement* x y width height)
1526           (setf window (xlib:create-window :parent *root*
1527                                            :x x
1528                                            :y y
1529                                            :width width
1530                                            :height height
1531                                            :background (get-color *notify-window-background*)
1532                                            :border-width 1
1533                                            :border (get-color *notify-window-border*)
1534                                            :colormap (xlib:screen-default-colormap *screen*)
1535                                            :event-mask '(:exposure :key-press))
1536                 gc (xlib:create-gcontext :drawable window
1537                                          :foreground (get-color *notify-window-foreground*)
1538                                          :background (get-color *notify-window-background*)
1539                                          :font font
1540                                          :line-style :solid))
1541           (when (frame-p *current-child*)
1542             (setf current-child *current-child*)
1543             (push (list #'is-notify-window-p 'raise-window) *never-managed-window-list*))
1544           (map-window window)
1545           (refresh-notify-window)
1546           (xlib:display-finish-output *display*))))))
1547
1548
1549 (defun display-hello-window ()
1550   (open-notify-window '(("Welcome to CLFSWM" "yellow")
1551                         "Press Alt+F1 for help"))
1552   (add-timer *notify-window-delay* #'close-notify-window))
1553
1554
1555 ;;; Run or raise functions
1556 (defun run-or-raise (raisep run-fn &key (maximized nil))
1557   (let ((window (with-all-windows (*root-frame* win)
1558                   (when (funcall raisep win)
1559                     (return win)))))
1560     (if window
1561         (let ((parent (find-parent-frame window)))
1562           (hide-all-children *current-root*)
1563           (setf *current-child* parent)
1564           (put-child-on-top window parent)
1565           (when maximized
1566             (setf *current-root* parent))
1567           (focus-all-children window parent)
1568           (show-all-children *current-root*))
1569         (funcall run-fn))))
1570
1571