src/clfswm-util.lisp

   1 ;;; --------------------------------------------------------------------------
   2 ;;; CLFSWM - FullScreen Window Manager
   3 ;;;
   4 ;;; --------------------------------------------------------------------------
   5 ;;; Documentation: Utility
   6 ;;; --------------------------------------------------------------------------
   7 ;;;
   8 ;;; (C) 2010 Philippe Brochard <hocwp@free.fr>
   9 ;;;
  10 ;;; This program is free software; you can redistribute it and/or modify
  11 ;;; it under the terms of the GNU General Public License as published by
  12 ;;; the Free Software Foundation; either version 3 of the License, or
  13 ;;; (at your option) any later version.
  14 ;;;
  15 ;;; This program is distributed in the hope that it will be useful,
  16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;;; GNU General Public License for more details.
  19 ;;;
  20 ;;; You should have received a copy of the GNU General Public License
  21 ;;; along with this program; if not, write to the Free Software
  22 ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  23 ;;;
  24 ;;; --------------------------------------------------------------------------
  25
  26 (in-package :clfswm)
  27
  28
  29 ;;; Configuration file
  30 (defun xdg-config-home ()
  31   (pathname-directory (concatenate 'string (or (getenv "XDG_CONFIG_HOME")
  32                                                (getenv "HOME"))
  33                                    "/")))
  34
  35 (let ((saved-conf-name nil))
  36   (defun conf-file-name (&optional alternate-name)
  37     (unless (and saved-conf-name (not alternate-name))
  38       (let* ((user-conf (probe-file (merge-pathnames (user-homedir-pathname) #p".clfswmrc")))
  39              (etc-conf (probe-file #p"/etc/clfswmrc"))
  40              (config-user-conf (probe-file (make-pathname :directory (append (xdg-config-home) '("clfswm"))
  41                                                           :name "clfswmrc")))
  42              (alternate-conf (and alternate-name (probe-file alternate-name))))
  43         (setf saved-conf-name (or alternate-conf config-user-conf user-conf etc-conf))))
  44     (print saved-conf-name)
  45     saved-conf-name))
  46
  47
  48
  49
  50 (defun load-contrib (file)
  51   "Load a file in the contrib directory"
  52   (let ((truename (concatenate 'string *contrib-dir* "contrib/" file)))
  53     (format t "Loading contribution file: ~A~%" truename)
  54     (when (probe-file truename)
  55       (load truename :verbose nil))))
  56
  57
  58 (defun reload-clfswm ()
  59   "Reload clfswm"
  60   (format t "~&-*- Reloading CLFSWM -*-~%")
  61   (asdf:oos 'asdf:load-op :clfswm)
  62   (reset-clfswm))
  63
  64
  65
  66
  67 (defun rename-current-child ()
  68   "Rename the current child"
  69   (let ((name (query-string (format nil "New child name: (last: ~A)" (child-name *current-child*))
  70                             (child-name *current-child*))))
  71     (rename-child *current-child* name)
  72     (leave-second-mode)))
  73
  74
  75 (defun renumber-current-frame ()
  76   "Renumber the current frame"
  77   (when (frame-p *current-child*)
  78     (let ((number (query-number (format nil "New child number: (last: ~A)" (frame-number *current-child*))
  79                                 (frame-number *current-child*))))
  80       (setf (frame-number *current-child*) number)
  81       (leave-second-mode))))
  82
  83
  84
  85
  86 (defun add-default-frame ()
  87   "Add a default frame in the current frame"
  88   (when (frame-p *current-child*)
  89     (let ((name (query-string "Frame name")))
  90       (push (create-frame :name name) (frame-child *current-child*))))
  91   (leave-second-mode))
  92
  93
  94 (defun add-placed-frame ()
  95   "Add a placed frame in the current frame"
  96   (when (frame-p *current-child*)
  97     (let ((name (query-string "Frame name"))
  98           (x (/ (query-number "Frame x in percent (%)") 100))
  99           (y (/ (query-number "Frame y in percent (%)") 100))
 100           (w (/ (query-number "Frame width in percent (%)") 100))
 101           (h (/ (query-number "Frame height in percent (%)") 100)))
 102       (push (create-frame :name name :x x :y y :w w :h h)
 103             (frame-child *current-child*))))
 104   (leave-second-mode))
 105
 106
 107
 108 (defun delete-focus-window-generic (close-fun)
 109   (let ((window (xlib:input-focus *display*)))
 110     (when (and window (not (xlib:window-equal window *no-focus-window*)))
 111       (when (child-equal-p window *current-child*)
 112         (setf *current-child* *current-root*))
 113       (hide-child window)
 114       (delete-child-and-children-in-all-frames window close-fun)
 115       (show-all-children))))
 116
 117 (defun delete-focus-window ()
 118   "Close focus window: Delete the focus window in all frames and workspaces"
 119   (delete-focus-window-generic 'delete-window))
 120
 121 (defun destroy-focus-window ()
 122   "Kill focus window: Destroy the focus window in all frames and workspaces"
 123   (delete-focus-window-generic 'destroy-window))
 124
 125 (defun remove-focus-window ()
 126   "Remove the focus window from the current frame"
 127   (let ((window (xlib:input-focus *display*)))
 128     (when (and window (not (xlib:window-equal window *no-focus-window*)))
 129       (setf *current-child* *current-root*)
 130       (hide-child window)
 131       (remove-child-in-frame window (find-parent-frame window))
 132       (show-all-children))))
 133
 134
 135 (defun unhide-all-windows-in-current-child ()
 136   "Unhide all hidden windows into the current child"
 137   (with-xlib-protect
 138     (dolist (window (get-hidden-windows))
 139       (unhide-window window)
 140       (process-new-window window)
 141       (map-window window)))
 142   (show-all-children))
 143
 144
 145
 146
 147 (defun find-window-under-mouse (x y)
 148   "Return the child window under the mouse"
 149   (with-xlib-protect
 150     (let ((win *root*))
 151       (with-all-windows-frames-and-parent (*current-root* child parent)
 152         (when (and (or (managed-window-p child parent) (child-equal-p parent *current-child*))
 153                    (<= (xlib:drawable-x child) x (+ (xlib:drawable-x child) (xlib:drawable-width child)))
 154                    (<= (xlib:drawable-y child) y (+ (xlib:drawable-y child) (xlib:drawable-height child))))
 155           (setf win child))
 156         (when (and (<= (frame-rx child) x (+ (frame-rx child) (frame-rw child)))
 157                    (<= (frame-ry child) y (+ (frame-ry child) (frame-rh child))))
 158           (setf win (frame-window child))))
 159       win)))
 160
 161
 162 (defun find-child-under-mouse (x y &optional first-foundp)
 163   "Return the child under the mouse"
 164   (with-xlib-protect
 165     (let ((ret nil))
 166       (with-all-windows-frames-and-parent (*current-root* child parent)
 167         (when (and (or (managed-window-p child parent) (child-equal-p parent *current-child*))
 168                    (<= (xlib:drawable-x child) x (+ (xlib:drawable-x child) (xlib:drawable-width child)))
 169                    (<= (xlib:drawable-y child) y (+ (xlib:drawable-y child) (xlib:drawable-height child))))
 170           (if first-foundp
 171               (return-from find-child-under-mouse child)
 172               (setf ret child)))
 173         (when (and (<= (frame-rx child) x (+ (frame-rx child) (frame-rw child)))
 174                    (<= (frame-ry child) y (+ (frame-ry child) (frame-rh child))))
 175           (if first-foundp
 176               (return-from find-child-under-mouse child)
 177               (setf ret child))))
 178       ret)))
 179
 180
 181
 182
 183
 184
 185 ;;; Selection functions
 186 (defun clear-selection ()
 187   "Clear the current selection"
 188   (setf *child-selection* nil)
 189   (display-frame-info *current-root*))
 190
 191 (defun copy-current-child ()
 192   "Copy the current child to the selection"
 193   (pushnew *current-child* *child-selection*)
 194   (display-frame-info *current-root*))
 195
 196
 197 (defun cut-current-child ()
 198   "Cut the current child to the selection"
 199   (copy-current-child)
 200   (hide-all *current-child*)
 201   (remove-child-in-frame *current-child* (find-parent-frame *current-child* *current-root*))
 202   (setf *current-child* *current-root*)
 203   (show-all-children))
 204
 205 (defun remove-current-child ()
 206   "Remove the current child from its parent frame"
 207   (hide-all *current-child*)
 208   (remove-child-in-frame *current-child* (find-parent-frame *current-child* *current-root*))
 209   (setf *current-child* *current-root*)
 210   (leave-second-mode))
 211
 212 (defun delete-current-child ()
 213   "Delete the current child and its children in all frames"
 214   (hide-all *current-child*)
 215   (delete-child-and-children-in-all-frames *current-child*)
 216   (leave-second-mode))
 217
 218
 219 (defun paste-selection-no-clear ()
 220   "Paste the selection in the current frame - Do not clear the selection after paste"
 221   (let ((frame-dest (typecase *current-child*
 222                       (xlib:window (find-parent-frame *current-child* *current-root*))
 223                       (frame *current-child*))))
 224     (when frame-dest
 225       (dolist (child *child-selection*)
 226         (unless (find-child-in-parent child frame-dest)
 227           (pushnew child (frame-child frame-dest))))
 228       (show-all-children))))
 229
 230 (defun paste-selection ()
 231   "Paste the selection in the current frame"
 232   (paste-selection-no-clear)
 233   (setf *child-selection* nil)
 234   (display-frame-info *current-root*))
 235
 236
 237
 238
 239 ;;; Maximize function
 240 (defun frame-toggle-maximize ()
 241   "Maximize/Unmaximize the current frame in its parent frame"
 242   (when (frame-p *current-child*)
 243     (let ((unmaximized-coords (frame-data-slot *current-child* :unmaximized-coords)))
 244       (if unmaximized-coords
 245           (with-slots (x y w h) *current-child*
 246             (destructuring-bind (nx ny nw nh) unmaximized-coords
 247               (setf (frame-data-slot *current-child* :unmaximized-coords) nil
 248                     x nx y ny w nw h nh)))
 249           (with-slots (x y w h) *current-child*
 250             (setf (frame-data-slot *current-child* :unmaximized-coords)
 251                   (list x y w h)
 252                   x 0 y 0 w 1 h 1))))
 253     (show-all-children (find-parent-frame *current-child*))
 254     (leave-second-mode)))
 255
 256
 257
 258
 259
 260
 261
 262
 263
 264 ;;; CONFIG - Identify mode
 265 (defun identify-key ()
 266   "Identify a key"
 267   (let* ((done nil)
 268          (font (xlib:open-font *display* *identify-font-string*))
 269          (window (xlib:create-window :parent *root*
 270                                      :x 0 :y 0
 271                                      :width (- (xlib:screen-width *screen*) 2)
 272                                      :height (* 5 (+ (xlib:max-char-ascent font) (xlib:max-char-descent font)))
 273                                      :background (get-color *identify-background*)
 274                                      :border-width 1
 275                                      :border (get-color *identify-border*)
 276                                      :colormap (xlib:screen-default-colormap *screen*)
 277                                      :event-mask '(:exposure)))
 278          (gc (xlib:create-gcontext :drawable window
 279                                    :foreground (get-color *identify-foreground*)
 280                                    :background (get-color *identify-background*)
 281                                    :font font
 282                                    :line-style :solid)))
 283     (labels ((print-doc (msg hash-table-key pos code state)
 284                (let ((function (find-key-from-code hash-table-key code state)))
 285                  (when (and function (fboundp (first function)))
 286                    (xlib:draw-glyphs *pixmap-buffer* gc 10 (+ (* pos (+ (xlib:max-char-ascent font) (xlib:max-char-descent font))) 5)
 287                                      (format nil "~A ~A" msg (documentation (first function) 'function))))))
 288              (print-key (code state keysym key modifiers)
 289                (clear-pixmap-buffer window gc)
 290                (setf (xlib:gcontext-foreground gc) (get-color *identify-foreground*))
 291                (xlib:draw-glyphs *pixmap-buffer* gc 5 (+ (xlib:max-char-ascent font) 5)
 292                                  (format nil "Press a key to identify. Press 'q' to stop the identify loop."))
 293                (when code
 294                  (xlib:draw-glyphs *pixmap-buffer* gc 10 (+ (* 2 (+ (xlib:max-char-ascent font) (xlib:max-char-descent font))) 5)
 295                                    (format nil "Code=~A  KeySym=~S  Key=~S  Modifiers=~A"
 296                                            code keysym key modifiers))
 297                  (print-doc "Main mode  : " *main-keys* 3 code state)
 298                  (print-doc "Second mode: " *second-keys* 4 code state))
 299                (copy-pixmap-buffer window gc))
 300              (handle-identify-key (&rest event-slots &key root code state &allow-other-keys)
 301                (declare (ignore event-slots root))
 302                (let* ((modifiers (state->modifiers state))
 303                       (key (keycode->char code state))
 304                       (keysym (keysym->keysym-name (keycode->keysym code modifiers))))
 305                  (setf done (and (equal key #\q) (equal modifiers *default-modifiers*)))
 306                  (dbg code keysym key modifiers)
 307                  (print-key code state keysym key modifiers)
 308                  (force-output)))
 309              (handle-identify (&rest event-slots &key display event-key &allow-other-keys)
 310                (declare (ignore display))
 311                (case event-key
 312                  (:key-press (apply #'handle-identify-key event-slots) t)
 313                  (:exposure (print-key nil nil nil nil nil)))
 314                t))
 315       (xgrab-pointer *root* 92 93)
 316       (map-window window)
 317       (format t "~&Press 'q' to stop the identify loop~%")
 318       (print-key nil nil nil nil nil)
 319       (force-output)
 320       (unwind-protect
 321            (loop until done do
 322                 (xlib:display-finish-output *display*)
 323                 (when (xlib:event-listen *display* *loop-timeout*)
 324                   (xlib:process-event *display* :handler #'handle-identify)))
 325         (xlib:destroy-window window)
 326         (xlib:close-font font)
 327         (xgrab-pointer *root* 66 67)))))
 328
 329
 330
 331
 332
 333
 334 (defun eval-from-query-string ()
 335   "Eval a lisp form from the query input"
 336   (let ((form (query-string "Eval:"))
 337         (result nil))
 338     (when (and form (not (equal form "")))
 339       (let ((printed-result
 340              (with-output-to-string (*standard-output*)
 341                (setf result (handler-case
 342                                 (loop for i in (multiple-value-list
 343                                                 (eval (read-from-string form)))
 344                                    collect (format nil "~S" i))
 345                               (error (condition)
 346                                 (format nil "~A" condition)))))))
 347         (info-mode (expand-newline (append (ensure-list (format nil "> ~A" form))
 348                                            (ensure-list printed-result)
 349                                            (ensure-list result)))
 350                    :width (- (xlib:screen-width *screen*) 2))
 351         (eval-from-query-string)))))
 352
 353
 354
 355
 356 (defun run-program-from-query-string ()
 357   "Run a program from the query input"
 358   (multiple-value-bind (program return)
 359       (query-string "Run:")
 360     (when (and (equal return :return) program (not (equal program "")))
 361       (setf *second-mode-program* program)
 362       (leave-second-mode))))
 363
 364
 365
 366
 367 ;;; Frame name actions
 368 (defun ask-frame-name (msg)
 369   "Ask a frame name"
 370   (let ((all-frame-name nil)
 371         (name ""))
 372     (with-all-frames (*root-frame* frame)
 373       (awhen (frame-name frame) (push it all-frame-name)))
 374     (labels ((selected-names ()
 375                (loop :for str :in all-frame-name
 376                   :when (zerop (or (search name str :test #'string-equal) -1))
 377                   :collect str))
 378              (complet-alone (req sel)
 379                (if (= 1 (length sel)) (first sel) req))
 380              (ask ()
 381                (let* ((selected (selected-names))
 382                       (default (complet-alone name selected)))
 383                  (multiple-value-bind (str done)
 384                      (query-string (format nil "~A: ~{~A~^, ~}" msg selected) default)
 385                    (setf name str)
 386                    (when (or (not (string-equal name default)) (eql done :complet))
 387                      (ask))))))
 388       (ask))
 389     name))
 390
 391
 392
 393 ;;; Focus by functions
 394 (defun focus-frame-by (frame)
 395   (when (frame-p frame)
 396     (hide-all *current-root*)
 397     (focus-all-children frame (or (find-parent-frame frame *current-root*)
 398                                   (find-parent-frame frame)
 399                                   *root-frame*))
 400     (show-all-children *current-root*)))
 401
 402
 403 (defun focus-frame-by-name ()
 404   "Focus a frame by name"
 405   (focus-frame-by (find-frame-by-name (ask-frame-name "Focus frame")))
 406   (leave-second-mode))
 407
 408 (defun focus-frame-by-number ()
 409   "Focus a frame by number"
 410   (focus-frame-by (find-frame-by-number (query-number "Focus frame by number:")))
 411   (leave-second-mode))
 412
 413
 414 ;;; Open by functions
 415 (defun open-frame-by (frame)
 416   (when (frame-p frame)
 417     (push (create-frame :name (query-string "Frame name")) (frame-child frame))
 418     (show-all-children *current-root*)))
 419
 420
 421
 422 (defun open-frame-by-name ()
 423   "Open a new frame in a named frame"
 424   (open-frame-by (find-frame-by-name (ask-frame-name "Open a new frame in")))
 425   (leave-second-mode))
 426
 427 (defun open-frame-by-number ()
 428   "Open a new frame in a numbered frame"
 429   (open-frame-by (find-frame-by-number (query-number "Open a new frame in the group numbered:")))
 430   (leave-second-mode))
 431
 432
 433 ;;; Delete by functions
 434 (defun delete-frame-by (frame)
 435   (hide-all *current-root*)
 436   (unless (child-equal-p frame *root-frame*)
 437     (when (child-equal-p frame *current-root*)
 438       (setf *current-root* *root-frame*))
 439     (when (child-equal-p frame *current-child*)
 440       (setf *current-child* *current-root*))
 441     (remove-child-in-frame frame (find-parent-frame frame)))
 442   (show-all-children *current-root*))
 443
 444
 445 (defun delete-frame-by-name ()
 446   "Delete a frame by name"
 447   (delete-frame-by (find-frame-by-name (ask-frame-name "Delete frame")))
 448   (leave-second-mode))
 449
 450 (defun delete-frame-by-number ()
 451   "Delete a frame by number"
 452   (delete-frame-by (find-frame-by-number (query-number "Delete frame by number:")))
 453   (leave-second-mode))
 454
 455
 456 ;;; Move by function
 457 (defun move-child-to (child frame-dest)
 458   (when (and child (frame-p frame-dest))
 459     (hide-all *current-root*)
 460     (remove-child-in-frame child (find-parent-frame child))
 461     (pushnew child (frame-child frame-dest))
 462     (focus-all-children child frame-dest)
 463     (show-all-children *current-root*)))
 464
 465 (defun move-current-child-by-name ()
 466   "Move current child in a named frame"
 467   (move-child-to *current-child*
 468                  (find-frame-by-name
 469                   (ask-frame-name (format nil "Move '~A' to frame" (child-name *current-child*)))))
 470   (leave-second-mode))
 471
 472 (defun move-current-child-by-number ()
 473   "Move current child in a numbered frame"
 474   (move-child-to *current-child*
 475                  (find-frame-by-number
 476                   (query-number (format nil "Move '~A' to frame numbered:" (child-name *current-child*)))))
 477   (leave-second-mode))
 478
 479
 480 ;;; Copy by function
 481 (defun copy-child-to (child frame-dest)
 482   (when (and child (frame-p frame-dest))
 483     (hide-all *current-root*)
 484     (pushnew child (frame-child frame-dest))
 485     (focus-all-children child frame-dest)
 486     (show-all-children *current-root*)))
 487
 488 (defun copy-current-child-by-name ()
 489   "Copy current child in a named frame"
 490   (copy-child-to *current-child*
 491                  (find-frame-by-name
 492                   (ask-frame-name (format nil "Copy '~A' to frame" (child-name *current-child*)))))
 493   (leave-second-mode))
 494
 495 (defun copy-current-child-by-number ()
 496   "Copy current child in a numbered frame"
 497   (copy-child-to *current-child*
 498                  (find-frame-by-number
 499                   (query-number (format nil "Copy '~A' to frame numbered:" (child-name *current-child*)))))
 500   (leave-second-mode))
 501
 502
 503
 504
 505 ;;; Show frame info
 506 (defun show-all-frames-info ()
 507   "Show all frames info windows"
 508   (let ((*show-root-frame-p* t))
 509     (show-all-children)
 510     (with-all-frames (*current-root* frame)
 511       (raise-window (frame-window frame))
 512       (display-frame-info frame))))
 513
 514 (defun hide-all-frames-info ()
 515   "Hide all frames info windows"
 516   (with-all-windows (*current-root* window)
 517     (raise-window window))
 518   (hide-child *current-root*)
 519   (show-all-children))
 520
 521 (defun show-all-frames-info-key ()
 522   "Show all frames info windows until a key is release"
 523   (show-all-frames-info)
 524   (wait-no-key-or-button-press)
 525   (hide-all-frames-info))
 526
 527
 528
 529
 530
 531
 532 (defun move-frame (frame parent orig-x orig-y)
 533   (when (and frame parent)
 534     (hide-all-children frame)
 535     (with-slots (window) frame
 536       (move-window window orig-x orig-y #'display-frame-info (list frame))
 537       (setf (frame-x frame) (x-px->fl (xlib:drawable-x window) parent)
 538             (frame-y frame) (y-px->fl (xlib:drawable-y window) parent)))
 539     (show-all-children frame)))
 540
 541
 542 (defun resize-frame (frame parent orig-x orig-y)
 543   (when (and frame parent)
 544     (hide-all-children frame)
 545     (with-slots (window) frame
 546       (resize-window window orig-x orig-y #'display-frame-info (list frame))
 547       (setf (frame-w frame) (w-px->fl (xlib:drawable-width window) parent)
 548             (frame-h frame) (h-px->fl (xlib:drawable-height window) parent)))
 549     (show-all-children frame)))
 550
 551
 552
 553 (defun mouse-click-to-focus-generic (window root-x root-y mouse-fn)
 554   "Focus the current frame or focus the current window parent
 555 mouse-fun is #'move-frame or #'resize-frame"
 556   (let* ((to-replay t)
 557          (child (find-child-under-mouse root-x root-y))
 558          (parent (find-parent-frame child))
 559          (root-p (or (child-equal-p window *root*)
 560                      (and (frame-p *current-root*)
 561                           (child-equal-p child (frame-window *current-root*))))))
 562     (labels ((add-new-frame ()
 563                (setf child (create-frame)
 564                      parent *current-root*
 565                      mouse-fn #'resize-frame)
 566                (place-frame child parent root-x root-y 10 10)
 567                (map-window (frame-window child))
 568                (pushnew child (frame-child *current-root*))))
 569       (when (or (not root-p) *create-frame-on-root*)
 570         (unless parent
 571           (if root-p
 572               (add-new-frame)
 573               (progn
 574                 (unless (equal (type-of child) 'frame)
 575                   (setf child (find-frame-window child *current-root*)))
 576                 (setf parent (find-parent-frame child)))))
 577         (when (equal (type-of child) 'frame)
 578           (funcall mouse-fn child parent root-x root-y))
 579         (when (and child parent (focus-all-children child parent))
 580           (when (show-all-children *current-root*)
 581             (setf to-replay nil))))
 582       (if to-replay
 583           (replay-button-event)
 584           (stop-button-event)))))
 585
 586
 587 (defun mouse-click-to-focus-and-move (window root-x root-y)
 588   "Move and focus the current frame or focus the current window parent.
 589 Or do actions on corners"
 590   (or (do-corner-action root-x root-y *corner-main-mode-left-button*)
 591       (mouse-click-to-focus-generic window root-x root-y #'move-frame)))
 592
 593 (defun mouse-click-to-focus-and-resize (window root-x root-y)
 594   "Resize and focus the current frame or focus the current window parent.
 595 Or do actions on corners"
 596   (or (do-corner-action root-x root-y *corner-main-mode-right-button*)
 597       (mouse-click-to-focus-generic window root-x root-y #'resize-frame)))
 598
 599 (defun mouse-middle-click (window root-x root-y)
 600   "Do actions on corners"
 601   (declare (ignore window))
 602   (or (do-corner-action root-x root-y *corner-main-mode-middle-button*)
 603       (replay-button-event)))
 604
 605
 606
 607
 608 (defun mouse-focus-move/resize-generic (root-x root-y mouse-fn window-parent)
 609   "Focus the current frame or focus the current window parent
 610 mouse-fun is #'move-frame or #'resize-frame.
 611 Focus child and its parents -
 612 For window: set current child to window or its parent according to window-parent"
 613   (let* ((child (find-child-under-mouse root-x root-y))
 614          (parent (find-parent-frame child)))
 615     (when (and (child-equal-p child *current-root*)
 616                (frame-p *current-root*))
 617       (setf child (create-frame)
 618             parent *current-root*
 619             mouse-fn #'resize-frame)
 620       (place-frame child parent root-x root-y 10 10)
 621       (map-window (frame-window child))
 622       (pushnew child (frame-child *current-root*)))
 623     (typecase child
 624       (xlib:window
 625        (if (managed-window-p child parent)
 626            (funcall mouse-fn parent (find-parent-frame parent) root-x root-y)
 627            (funcall(cond ((eql mouse-fn #'move-frame) #'move-window)
 628                          ((eql mouse-fn #'resize-frame) #'resize-window))
 629                    child root-x root-y)))
 630       (frame (funcall mouse-fn child parent root-x root-y)))
 631     (focus-all-children child parent window-parent)
 632     (show-all-children *current-root*)))
 633
 634
 635
 636
 637 (defun test-mouse-binding (window root-x root-y)
 638   (dbg window root-x root-y)
 639   (replay-button-event))
 640
 641
 642
 643 (defun mouse-select-next-level (window root-x root-y)
 644   "Select the next level in frame"
 645   (declare (ignore root-x root-y))
 646   (let ((frame (find-frame-window window)))
 647     (when (or frame (xlib:window-equal window *root*))
 648       (select-next-level))
 649     (replay-button-event)))
 650
 651
 652
 653 (defun mouse-select-previous-level (window root-x root-y)
 654   "Select the previous level in frame"
 655   (declare (ignore root-x root-y))
 656   (let ((frame (find-frame-window window)))
 657     (when (or frame (xlib:window-equal window *root*))
 658       (select-previous-level))
 659     (replay-button-event)))
 660
 661
 662
 663 (defun mouse-enter-frame (window root-x root-y)
 664   "Enter in the selected frame - ie make it the root frame"
 665   (declare (ignore root-x root-y))
 666   (let ((frame (find-frame-window window)))
 667     (when (or frame (xlib:window-equal window *root*))
 668       (enter-frame))
 669     (replay-button-event)))
 670
 671
 672
 673 (defun mouse-leave-frame (window root-x root-y)
 674   "Leave the selected frame - ie make its parent the root frame"
 675   (declare (ignore root-x root-y))
 676   (let ((frame (find-frame-window window)))
 677     (when (or frame (xlib:window-equal window *root*))
 678       (leave-frame))
 679     (replay-button-event)))
 680
 681
 682
 683 ;;;;;,-----
 684 ;;;;;| Various definitions
 685 ;;;;;`-----
 686
 687 (defun show-help (&optional (browser "dillo") (tempfile "/tmp/clfswm.html"))
 688   "Show current keys and buttons bindings"
 689   (ignore-errors
 690     (produce-doc-html-in-file tempfile))
 691   (sleep 1)
 692   (do-shell (format nil "~A ~A" browser tempfile)))
 693
 694
 695
 696 ;;;  Bind or jump functions
 697 (let ((key-slots (make-array 10 :initial-element nil))
 698       (current-slot 1))
 699   (defun bind-on-slot ()
 700     "Bind current child to slot"
 701     (setf (aref key-slots current-slot) *current-child*))
 702
 703   (defun remove-binding-on-slot ()
 704     "Remove binding on slot"
 705     (setf (aref key-slots current-slot) nil))
 706
 707   (defun jump-to-slot ()
 708     "Jump to slot"
 709     (let ((jump-child (aref key-slots current-slot)))
 710       (when (find-child jump-child *root-frame*)
 711         (hide-all *current-root*)
 712         (setf *current-root* jump-child
 713               *current-child* *current-root*)
 714         (focus-all-children *current-child* *current-child*)
 715         (show-all-children *current-root*))))
 716
 717   (defun bind-or-jump (n)
 718     "Bind or jump to a slot (a frame or a window)"
 719     (setf current-slot (- n 1))
 720     (let ((default-bind `("b" bind-on-slot
 721                               ,(format nil "Bind slot ~A on child: ~A" n (child-fullname *current-child*)))))
 722       (info-mode-menu (aif (aref key-slots current-slot)
 723                            `(,default-bind
 724                                 ("BackSpace" remove-binding-on-slot
 725                                              ,(format nil "Remove slot ~A binding on child: ~A" n (child-fullname *current-child*)))
 726                                 ("   -  " nil " -")
 727                               ("Tab" jump-to-slot
 728                                      ,(format nil "Jump to child: ~A" (aif (aref key-slots current-slot)
 729                                                                            (child-fullname it)
 730                                                                            "Not set - Please, bind it with 'b'")))
 731                               ("Return" jump-to-slot "Same thing")
 732                               ("space" jump-to-slot "Same thing"))
 733                            (list default-bind))))))
 734
 735
 736
 737 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 738 ;;; Useful function for the second mode ;;;
 739 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 740 (defmacro with-movement (&body body)
 741   `(when (frame-p *current-child*)
 742      ,@body
 743      (show-all-children)
 744      (display-all-frame-info)
 745      (draw-second-mode-window)
 746      (open-menu (find-menu 'frame-movement-menu))))
 747
 748
 749 ;;; Pack
 750 (defun current-frame-pack-up ()
 751   "Pack the current frame up"
 752   (with-movement (pack-frame-up *current-child* (find-parent-frame *current-child* *current-root*))))
 753
 754 (defun current-frame-pack-down ()
 755   "Pack the current frame down"
 756   (with-movement (pack-frame-down *current-child* (find-parent-frame *current-child* *current-root*))))
 757
 758 (defun current-frame-pack-left ()
 759   "Pack the current frame left"
 760   (with-movement (pack-frame-left *current-child* (find-parent-frame *current-child* *current-root*))))
 761
 762 (defun current-frame-pack-right ()
 763   "Pack the current frame right"
 764   (with-movement (pack-frame-right *current-child* (find-parent-frame *current-child* *current-root*))))
 765
 766 ;;; Center
 767 (defun center-current-frame ()
 768   "Center the current frame"
 769   (with-movement (center-frame *current-child*)))
 770
 771 ;;; Fill
 772 (defun current-frame-fill-up ()
 773   "Fill the current frame up"
 774   (with-movement (fill-frame-up *current-child* (find-parent-frame *current-child* *current-root*))))
 775
 776 (defun current-frame-fill-down ()
 777   "Fill the current frame down"
 778   (with-movement (fill-frame-down *current-child* (find-parent-frame *current-child* *current-root*))))
 779
 780 (defun current-frame-fill-left ()
 781   "Fill the current frame left"
 782   (with-movement (fill-frame-left *current-child* (find-parent-frame *current-child* *current-root*))))
 783
 784 (defun current-frame-fill-right ()
 785   "Fill the current frame right"
 786   (with-movement (fill-frame-right *current-child* (find-parent-frame *current-child* *current-root*))))
 787
 788 (defun current-frame-fill-all-dir ()
 789   "Fill the current frame in all directions"
 790   (with-movement
 791     (let ((parent (find-parent-frame *current-child* *current-root*)))
 792       (fill-frame-up *current-child* parent)
 793       (fill-frame-down *current-child* parent)
 794       (fill-frame-left *current-child* parent)
 795       (fill-frame-right *current-child* parent))))
 796
 797 (defun current-frame-fill-vertical ()
 798   "Fill the current frame vertically"
 799   (with-movement
 800     (let ((parent (find-parent-frame *current-child* *current-root*)))
 801       (fill-frame-up *current-child* parent)
 802       (fill-frame-down *current-child* parent))))
 803
 804 (defun current-frame-fill-horizontal ()
 805   "Fill the current frame horizontally"
 806   (with-movement
 807     (let ((parent (find-parent-frame *current-child* *current-root*)))
 808       (fill-frame-left *current-child* parent)
 809       (fill-frame-right *current-child* parent))))
 810
 811
 812 ;;; Resize
 813 (defun current-frame-resize-up ()
 814   "Resize the current frame up to its half height"
 815   (with-movement (resize-half-height-up *current-child*)))
 816
 817 (defun current-frame-resize-down ()
 818   "Resize the current frame down to its half height"
 819   (with-movement (resize-half-height-down *current-child*)))
 820
 821 (defun current-frame-resize-left ()
 822   "Resize the current frame left to its half width"
 823   (with-movement (resize-half-width-left *current-child*)))
 824
 825 (defun current-frame-resize-right ()
 826   "Resize the current frame right to its half width"
 827   (with-movement (resize-half-width-right *current-child*)))
 828
 829 (defun current-frame-resize-all-dir ()
 830   "Resize down the current frame"
 831   (with-movement (resize-frame-down *current-child*)))
 832
 833 (defun current-frame-resize-all-dir-minimal ()
 834   "Resize down the current frame to its minimal size"
 835   (with-movement (resize-minimal-frame *current-child*)))
 836
 837
 838 ;;; Children navigation
 839 (defun with-movement-select-next-brother ()
 840   "Select the next brother frame"
 841   (with-movement (select-next-brother)))
 842
 843 (defun with-movement-select-previous-brother ()
 844   "Select the previous brother frame"
 845   (with-movement (select-previous-brother)))
 846
 847 (defun with-movement-select-next-level ()
 848   "Select the next level"
 849   (with-movement (select-next-level)))
 850
 851 (defun with-movement-select-previous-level ()
 852   "Select the previous levelframe"
 853   (with-movement (select-previous-level)))
 854
 855 (defun with-movement-select-next-child ()
 856   "Select the next child"
 857   (with-movement (select-next-child)))
 858
 859
 860
 861 ;;; Adapt frame functions
 862 (defun adapt-current-frame-to-window-hints-generic (width-p height-p)
 863   "Adapt the current frame to the current window minimal size hints"
 864   (when (frame-p *current-child*)
 865     (let ((window (first (frame-child *current-child*))))
 866       (when (xlib:window-p window)
 867         (let* ((hints (xlib:wm-normal-hints window))
 868                (min-width (and hints (xlib:wm-size-hints-min-width hints)))
 869                (min-height (and hints (xlib:wm-size-hints-min-height hints))))
 870           (when (and width-p min-width)
 871             (setf (frame-rw *current-child*) min-width))
 872           (when (and height-p min-height)
 873             (setf (frame-rh *current-child*) min-height))
 874           (fixe-real-size *current-child* (find-parent-frame *current-child*))
 875           (leave-second-mode))))))
 876
 877 (defun adapt-current-frame-to-window-hints ()
 878   "Adapt the current frame to the current window minimal size hints"
 879   (adapt-current-frame-to-window-hints-generic t t))
 880
 881 (defun adapt-current-frame-to-window-width-hint ()
 882   "Adapt the current frame to the current window minimal width hint"
 883   (adapt-current-frame-to-window-hints-generic t nil))
 884
 885 (defun adapt-current-frame-to-window-height-hint ()
 886   "Adapt the current frame to the current window minimal height hint"
 887   (adapt-current-frame-to-window-hints-generic nil t))
 888
 889
 890
 891
 892 ;;; Managed window type functions
 893 (defun current-frame-manage-window-type-generic (type-list)
 894   (when (frame-p *current-child*)
 895     (setf (frame-managed-type *current-child*) type-list
 896           (frame-forced-managed-window *current-child*) nil
 897           (frame-forced-unmanaged-window *current-child*) nil))
 898   (leave-second-mode))
 899
 900
 901 (defun current-frame-manage-window-type ()
 902   "Change window types to be managed by a frame"
 903   (when (frame-p *current-child*)
 904     (let* ((type-str (query-string "Managed window type: (all, normal, transient, maxsize, desktop, dock, toolbar, menu, utility, splash, dialog)"
 905                                    (format nil "~{~:(~A~) ~}" (frame-managed-type *current-child*))))
 906            (type-list (loop :for type :in (split-string type-str)
 907                          :collect (intern (string-upcase type) :keyword))))
 908       (current-frame-manage-window-type-generic type-list))))
 909
 910
 911 (defun current-frame-manage-all-window-type ()
 912   "Manage all window type"
 913   (current-frame-manage-window-type-generic '(:all)))
 914
 915 (defun current-frame-manage-only-normal-window-type ()
 916   "Manage only normal window type"
 917   (current-frame-manage-window-type-generic '(:normal)))
 918
 919 (defun current-frame-manage-no-window-type ()
 920   "Do not manage any window type"
 921   (current-frame-manage-window-type-generic nil))
 922
 923
 924
 925
 926
 927
 928
 929
 930 ;;; Force window functions
 931 (defun force-window-in-frame ()
 932   "Force the current window to move in the frame (Useful only for unmanaged windows)"
 933   (with-current-window
 934     (let ((parent (find-parent-frame window)))
 935       (with-xlib-protect
 936         (setf (xlib:drawable-x window) (frame-rx parent)
 937               (xlib:drawable-y window) (frame-ry parent)))))
 938   (leave-second-mode))
 939
 940
 941 (defun force-window-center-in-frame ()
 942   "Force the current window to move in the center of the frame (Useful only for unmanaged windows)"
 943   (with-current-window
 944     (let ((parent (find-parent-frame window)))
 945       (with-xlib-protect
 946         (setf (xlib:drawable-x window) (truncate (+ (frame-rx parent)
 947                                                     (/ (- (frame-rw parent)
 948                                                           (xlib:drawable-width window)) 2)))
 949               (xlib:drawable-y window) (truncate (+ (frame-ry parent)
 950                                                     (/ (- (frame-rh parent)
 951                                                           (xlib:drawable-height window)) 2)))))))
 952   (leave-second-mode))
 953
 954
 955
 956 (defun display-current-window-info ()
 957   "Display information on the current window"
 958   (with-current-window
 959     (info-mode (list (format nil "Window:       ~A" window)
 960                      (format nil "Window name:  ~A" (xlib:wm-name window))
 961                      (format nil "Window class: ~A" (xlib:get-wm-class window))
 962                      (format nil "Window type:  ~:(~A~)" (window-type window))
 963                      (format nil "Window id:    0x~X" (xlib:window-id window)))))
 964   (leave-second-mode))
 965
 966
 967 (defun manage-current-window ()
 968   "Force to manage the current window by its parent frame"
 969   (with-current-window
 970     (let ((parent (find-parent-frame window)))
 971       (with-slots ((managed forced-managed-window)
 972                    (unmanaged forced-unmanaged-window)) parent
 973         (setf unmanaged (remove window unmanaged :test #'child-equal-p)
 974               unmanaged (remove (xlib:wm-name window) unmanaged :test #'string-equal-p))
 975         (pushnew window managed))))
 976   (leave-second-mode))
 977
 978 (defun unmanage-current-window ()
 979   "Force to not manage the current window by its parent frame"
 980   (with-current-window
 981     (let ((parent (find-parent-frame window)))
 982       (with-slots ((managed forced-managed-window)
 983                    (unmanaged forced-unmanaged-window)) parent
 984         (setf managed (remove window managed :test #'child-equal-p)
 985               managed (remove (xlib:wm-name window) managed :test #'string-equal-p))
 986         (pushnew window unmanaged))))
 987   (leave-second-mode))
 988
 989
 990
 991 ;;; Moving child with the mouse button
 992 (defun mouse-move-child-over-frame (window root-x root-y)
 993   "Move the child under the mouse cursor to another frame"
 994   (declare (ignore window))
 995   (let ((child (find-child-under-mouse root-x root-y)))
 996     (unless (child-equal-p child *current-root*)
 997       (hide-all child)
 998       (remove-child-in-frame child (find-parent-frame child))
 999       (wait-mouse-button-release 50 51)
1000       (multiple-value-bind (x y)
1001           (xlib:query-pointer *root*)
1002         (let ((dest (find-child-under-mouse x y)))
1003           (when (xlib:window-p dest)
1004             (setf dest (find-parent-frame dest)))
1005           (unless (child-equal-p child dest)
1006             (move-child-to child dest)
1007             (show-all-children *current-root*))))))
1008   (stop-button-event))
1009
1010
1011
1012
1013 ;;; Hide/Show frame window functions
1014 (defun hide/show-frame-window (frame value)
1015   "Hide/show the frame window"
1016   (when (frame-p frame)
1017     (setf (frame-show-window-p *current-child*) value)
1018     (show-all-children *current-root*))
1019   (leave-second-mode))
1020
1021
1022 (defun hide-current-frame-window ()
1023   "Hide the current frame window"
1024   (hide/show-frame-window *current-child* nil))
1025
1026 (defun show-current-frame-window ()
1027   "Show the current frame window"
1028   (hide/show-frame-window *current-child* t))
1029
1030
1031
1032 ;;; Hide/Unhide current child
1033 (defun hide-current-child ()
1034   "Hide the current child"
1035   (let ((parent (find-parent-frame *current-child*)))
1036     (when (frame-p parent)
1037       (with-slots (child hidden-children) parent
1038         (hide-all *current-child*)
1039         (setf child (remove *current-child* child :test #'child-equal-p))
1040         (pushnew *current-child* hidden-children)
1041         (setf *current-child* parent))
1042       (show-all-children)))
1043   (leave-second-mode))
1044
1045
1046 (defun frame-unhide-child (hidden frame-src frame-dest)
1047   "Unhide a hidden child from frame-src in frame-dest"
1048   (with-slots (hidden-children) frame-src
1049     (setf hidden-children (remove hidden hidden-children :test #'child-equal-p)))
1050   (with-slots (child) frame-dest
1051     (pushnew hidden child)))
1052
1053
1054
1055 (defun unhide-a-child ()
1056   "Unhide a child in the current frame"
1057   (when (frame-p *current-child*)
1058     (with-slots (child hidden-children) *current-child*
1059       (info-mode-menu (loop :for i :from 0
1060                          :for hidden :in hidden-children
1061                          :collect (list (code-char (+ (char-code #\a) i))
1062                                         (let ((lhd hidden))
1063                                           (lambda ()
1064                                             (frame-unhide-child lhd *current-child* *current-child*)))
1065                                         (format nil "Unhide ~A" (child-fullname hidden))))))
1066     (show-all-children))
1067   (leave-second-mode))
1068
1069
1070 (defun unhide-all-children ()
1071   "Unhide all current frame hidden children"
1072   (when (frame-p *current-child*)
1073     (with-slots (child hidden-children) *current-child*
1074       (dolist (c hidden-children)
1075         (pushnew c child))
1076       (setf hidden-children nil))
1077     (show-all-children))
1078   (leave-second-mode))
1079
1080
1081 (defun unhide-a-child-from-all-frames ()
1082   "Unhide a child from all frames in the current frame"
1083   (when (frame-p *current-child*)
1084     (let ((acc nil)
1085           (keynum -1))
1086       (with-all-frames (*root-frame* frame)
1087         (when (frame-hidden-children frame)
1088           (push (format nil "~A" (child-fullname frame)) acc)
1089           (dolist (hidden (frame-hidden-children frame))
1090             (push (list (code-char (+ (char-code #\a) (incf keynum)))
1091                         (let ((lhd hidden))
1092                           (lambda ()
1093                             (frame-unhide-child lhd frame *current-child*)))
1094                         (format nil "Unhide ~A" (child-fullname hidden)))
1095                   acc))))
1096       (info-mode-menu (nreverse acc)))
1097     (show-all-children))
1098   (leave-second-mode))
1099
1100
1101
1102
1103
1104 (let ((last-child nil))
1105   (defun init-last-child ()
1106     (setf last-child nil))
1107   (defun switch-to-last-child ()
1108     "Store the current child and switch to the previous one"
1109     (let ((current-child *current-child*))
1110       (when last-child
1111         (hide-all *current-root*)
1112         (setf *current-root* last-child
1113               *current-child* *current-root*)
1114         (focus-all-children *current-child* *current-child*)
1115         (show-all-children *current-root*))
1116       (setf last-child current-child))))
1117
1118
1119
1120
1121
1122
1123
1124 ;;; Focus policy functions
1125 (defun set-focus-policy-generic (focus-policy)
1126   (when (frame-p *current-child*)
1127     (setf (frame-focus-policy *current-child*) focus-policy))
1128   (leave-second-mode))
1129
1130
1131 (defun current-frame-set-click-focus-policy ()
1132   "Set a click focus policy for the current frame."
1133   (set-focus-policy-generic :click))
1134
1135 (defun current-frame-set-sloppy-focus-policy ()
1136   "Set a sloppy focus policy for the current frame."
1137   (set-focus-policy-generic :sloppy))
1138
1139 (defun current-frame-set-sloppy-strict-focus-policy ()
1140   "Set a (strict) sloppy focus policy only for windows in the current frame."
1141   (set-focus-policy-generic :sloppy-strict))
1142
1143 (defun current-frame-set-sloppy-select-policy ()
1144   "Set a sloppy select policy for the current frame."
1145     (set-focus-policy-generic :sloppy-select))
1146
1147
1148
1149 (defun set-focus-policy-generic-for-all (focus-policy)
1150   (with-all-frames (*root-frame* frame)
1151     (setf (frame-focus-policy frame) focus-policy))
1152   (leave-second-mode))
1153
1154
1155 (defun all-frames-set-click-focus-policy ()
1156   "Set a click focus policy for all frames."
1157   (set-focus-policy-generic-for-all :click))
1158
1159 (defun all-frames-set-sloppy-focus-policy ()
1160   "Set a sloppy focus policy for all frames."
1161   (set-focus-policy-generic-for-all :sloppy))
1162
1163 (defun all-frames-set-sloppy-strict-focus-policy ()
1164   "Set a (strict) sloppy focus policy for all frames."
1165   (set-focus-policy-generic-for-all :sloppy-strict))
1166
1167 (defun all-frames-set-sloppy-select-policy ()
1168   "Set a sloppy select policy for all frames."
1169     (set-focus-policy-generic-for-all :sloppy-select))
1170
1171
1172
1173 ;;; Ensure unique name/number functions
1174 (defun extract-number-from-name (name)
1175   (when (stringp name)
1176     (let* ((pos (1+ (or (position #\. name :from-end t) -1)))
1177            (number (parse-integer name :junk-allowed t :start pos)))
1178       (values number
1179               (if number (subseq name 0 (1- pos)) name)))))
1180
1181
1182
1183
1184 (defun ensure-unique-name ()
1185   "Ensure that all children names are unique"
1186   (with-all-children (*root-frame* child)
1187     (multiple-value-bind (num1 name1)
1188         (extract-number-from-name (child-name child))
1189       (declare (ignore num1))
1190       (when name1
1191         (let ((acc nil))
1192           (with-all-children (*root-frame* c)
1193             (unless (child-equal-p child c))
1194             (multiple-value-bind (num2 name2)
1195                 (extract-number-from-name (child-name c))
1196               (when (string-equal name1 name2)
1197                 (push num2 acc))))
1198           (dbg acc)
1199           (when (> (length acc) 1)
1200             (setf (child-name child)
1201                   (format nil "~A.~A" name1
1202                           (1+ (find-free-number (loop for i in acc when i collect (1- i)))))))))))
1203   (leave-second-mode))
1204
1205 (defun ensure-unique-number ()
1206   "Ensure that all children numbers are unique"
1207   (let ((num -1))
1208     (with-all-frames (*root-frame* frame)
1209       (setf (frame-number frame) (incf num))))
1210   (leave-second-mode))
1211
1212
1213
1214 ;;; Standard menu functions - Based on the 'update-menus' command
1215 (defun um-extract-value (name line)
1216   (let* ((fullname (format nil "~A=\"" name))
1217          (pos (search fullname line)))
1218     (when (numberp pos)
1219       (let* ((start (+ pos (length fullname)))
1220              (end (position #\" line :start start)))
1221         (when (numberp end)
1222           (subseq line start end))))))
1223
1224
1225 (defun um-create-section (menu section-list)
1226   (if section-list
1227       (let* ((sec (intern (string-upcase (first section-list)) :clfswm))
1228              (submenu (find-menu sec menu)))
1229         (if submenu
1230             (um-create-section submenu (rest section-list))
1231             (progn
1232               (add-sub-menu (menu-name menu) :next sec (format nil "~A" sec) menu)
1233               (um-create-section (find-menu sec menu) (rest section-list)))))
1234       menu))
1235
1236
1237 (defun update-menus (&optional (menu (make-menu :name 'main :doc "Main menu")))
1238   (let ((output (do-shell "update-menus --stdout")))
1239     (loop for line = (read-line output nil nil)
1240           while line
1241           do (let ((command (um-extract-value "command" line)))
1242                (when command
1243                  (let* ((sub-menu (um-create-section menu (split-string (um-extract-value "section" line) #\/)))
1244                         (title (um-extract-value " title" line))
1245                         (doc (um-extract-value "description" line))
1246                         (name (intern title :clfswm)))
1247                    (setf (symbol-function name) (lambda ()
1248                                                   (do-shell command)
1249                                                   (leave-second-mode))
1250                          (documentation name 'function) (format nil "~A~A" title (if doc (format nil " - ~A" doc) "")))
1251                    (add-menu-key (menu-name sub-menu) :next name sub-menu)))))
1252     menu))
1253
1254
1255 (defun show-standard-menu ()
1256   "< Standard menu >"
1257   (let ((menu (update-menus)))
1258     (if (menu-item menu)
1259        (open-menu menu)
1260        (info-mode '("Command 'update-menus' not found")))))
1261
1262
1263
1264 ;;; Close/Kill focused window
1265
1266 (defun ask-close/kill-current-window ()
1267   "Close or kill the current window (ask before doing anything)"
1268   (let ((window (xlib:input-focus *display*)))
1269     (info-mode-menu
1270      (if (and window (not (xlib:window-equal window *no-focus-window*)))
1271          `(,(format nil "Focus window: ~A" (xlib:wm-name window))
1272             (#\c delete-focus-window "Close the focus window")
1273             (#\k destroy-focus-window "Kill the focus window")
1274             (#\r remove-focus-window)
1275             (#\u unhide-all-windows-in-current-child))
1276          `(,(format nil "Focus window: None")
1277             (#\u unhide-all-windows-in-current-child))))))
1278
1279
1280
1281 ;;; Other window manager functions
1282 (defun get-proc-list ()
1283   (let ((proc (do-shell "ps x -o pid=" nil nil))
1284         (proc-list nil))
1285     (sleep 0.5)
1286     (loop for line = (read-line proc nil nil)
1287        while line
1288        do (push line proc-list))
1289     (dbg proc-list)
1290     proc-list))
1291
1292 (defun run-other-window-manager ()
1293   (let ((proc-start (get-proc-list)))
1294     (do-shell *other-window-manager* nil t)
1295     (let* ((proc-end (get-proc-list))
1296            (proc-diff (set-difference proc-end proc-start :test #'equal)))
1297       (dbg proc-diff)
1298       (dolist (proc proc-diff)
1299         (dbg 'killing-sigterm proc)
1300         (do-shell (format nil "kill ~A 2> /dev/null" proc) nil t))
1301       (sleep 0.5)
1302       (dolist (proc proc-diff)
1303         (dbg 'killing-sigkill proc)
1304         (do-shell (format nil "kill -9 ~A 2> /dev/null" proc) nil t)))
1305     (setf *other-window-manager* nil)))
1306
1307
1308 (defun do-run-other-window-manager (window-manager)
1309   (setf *other-window-manager* window-manager)
1310   (throw 'exit-main-loop nil))
1311
1312 (defmacro def-run-other-window-manager (name &optional definition)
1313   (let ((definition (or definition name)))
1314     `(defun ,(create-symbol "run-" name) ()
1315        ,(format nil "Run ~A" definition)
1316        (do-run-other-window-manager ,(format nil "~A" name)))))
1317
1318 (def-run-other-window-manager "xterm")
1319 (def-run-other-window-manager "icewm")
1320 (def-run-other-window-manager "twm")
1321 (def-run-other-window-manager "gnome-session" "Gnome")
1322 (def-run-other-window-manager "startkde" "KDE")
1323 (def-run-other-window-manager "xfce4-session" "XFCE")
1324
1325 (defun run-lxde ()
1326   "Run LXDE"
1327   (do-run-other-window-manager "lxsession; xterm -e \"echo '  /----------------------------------\\' ; echo '  |  CLFSWM Note:                    |' ; echo '  |    Close this window when done.  |' ; echo '  \\----------------------------------/'; echo; echo; $SHELL\""))
1328
1329
1330 (defun run-prompt-wm ()
1331   "Prompt for an other window manager"
1332   (let ((wm (query-string "Run an other window manager:" "icewm")))
1333     (do-run-other-window-manager wm)))
1334
1335