src/clfswm-util.lisp

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