src/clfswm-util.lisp

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