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