src/clfswm-internal.lisp

   1 ;; --------------------------------------------------------------------------
   2 ;;; CLFSWM - FullScreen Window Manager
   3 ;;;
   4 ;;; --------------------------------------------------------------------------
   5 ;;; Documentation: Main functions
   6 ;;; --------------------------------------------------------------------------
   7 ;;;
   8 ;;; (C) 2011 Philippe Brochard <hocwp@free.fr>
   9 ;;;
  10 ;;; This program is free software; you can redistribute it and/or modify
  11 ;;; it under the terms of the GNU General Public License as published by
  12 ;;; the Free Software Foundation; either version 3 of the License, or
  13 ;;; (at your option) any later version.
  14 ;;;
  15 ;;; This program is distributed in the hope that it will be useful,
  16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;;; GNU General Public License for more details.
  19 ;;;
  20 ;;; You should have received a copy of the GNU General Public License
  21 ;;; along with this program; if not, write to the Free Software
  22 ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  23 ;;;
  24 ;;; --------------------------------------------------------------------------
  25
  26 (in-package :clfswm)
  27
  28
  29
  30 ;;; Conversion functions
  31 ;;; Float -> Pixel conversion
  32 (defun x-fl->px (x parent)
  33   "Convert float X coordinate to pixel"
  34   (round (+ (* x (frame-rw parent)) (frame-rx parent))))
  35
  36 (defun y-fl->px (y parent)
  37   "Convert float Y coordinate to pixel"
  38   (round (+ (* y (frame-rh parent)) (frame-ry parent))))
  39
  40 (defun w-fl->px (w parent)
  41   "Convert float Width coordinate to pixel"
  42   (round (* w (frame-rw parent))))
  43
  44 (defun h-fl->px (h parent)
  45   "Convert float Height coordinate to pixel"
  46   (round (* h (frame-rh parent))))
  47
  48 ;;; Pixel -> Float conversion
  49 (defun x-px->fl (x parent)
  50   "Convert pixel X coordinate to float"
  51   (/ (- x (frame-rx parent) *border-size*) (frame-rw parent)))
  52
  53 (defun y-px->fl (y parent)
  54   "Convert pixel Y coordinate to float"
  55   (/ (- y (frame-ry parent) *border-size*) (frame-rh parent)))
  56
  57 (defun w-px->fl (w parent)
  58   "Convert pixel Width coordinate to float"
  59   (/ w (frame-rw parent)))
  60
  61 (defun h-px->fl (h parent)
  62   "Convert pixel Height coordinate to float"
  63   (/ h (frame-rh parent)))
  64
  65
  66
  67 (defun rect-hidden-p (rect1 rect2)
  68   "Return T if child-rect1 hide child-rect2"
  69   (and (<= (child-rect-x rect1) (child-rect-x rect2))
  70        (<= (child-rect-y rect1) (child-rect-y rect2))
  71        (>= (+ (child-rect-x rect1) (child-rect-w rect1)) (+ (child-rect-x rect2) (child-rect-w rect2)))
  72        (>= (+ (child-rect-y rect1) (child-rect-h rect1)) (+ (child-rect-y rect2) (child-rect-h rect2)))))
  73
  74
  75
  76 (defgeneric frame-p (frame))
  77 (defmethod frame-p ((frame frame))
  78   (declare (ignore frame))
  79   t)
  80 (defmethod frame-p (frame)
  81   (declare (ignore frame))
  82   nil)
  83
  84
  85
  86 ;;; in-*: Find if point (x,y) is in frame, window or child
  87 (defun in-rect (x y xr yr wr hr)
  88   (and (<= xr x (+ xr wr))
  89        (<= yr y (+ yr hr))))
  90
  91 (defun in-frame (frame x y)
  92   (and (frame-p frame)
  93        (in-rect x y (frame-rx frame) (frame-ry frame) (frame-rw frame) (frame-rh frame))))
  94
  95 (defun in-window (window x y)
  96   (and (xlib:window-p window)
  97        (in-rect x y
  98                 (x-drawable-x window) (x-drawable-y window)
  99                 (x-drawable-width window) (x-drawable-height window))))
 100
 101 (defgeneric in-child (child x y))
 102
 103 (defmethod in-child ((child frame) x y)
 104   (in-frame child x y))
 105 (defmethod in-child ((child xlib:window) x y)
 106   (in-window child x y))
 107 (defmethod in-child (child x y)
 108   (declare (ignore child x y))
 109   nil)
 110
 111
 112
 113
 114 (defun frame-selected-child (frame)
 115   (when (frame-p frame)
 116     (with-slots (child selected-pos) frame
 117       (let ((len (length child)))
 118         (cond ((minusp selected-pos) (setf selected-pos 0))
 119               ((>= selected-pos len) (setf selected-pos (max (1- len) 0)))))
 120       (nth selected-pos child))))
 121
 122
 123
 124
 125
 126 (defgeneric child-equal-p (child-1 child-2))
 127
 128 (defmethod child-equal-p ((child-1 xlib:window) (child-2 xlib:window))
 129   (xlib:window-equal child-1 child-2))
 130
 131 (defmethod child-equal-p ((child-1 frame) (child-2 frame))
 132   (equal child-1 child-2))
 133
 134 (defmethod child-equal-p (child-1 child-2)
 135   (declare (ignore child-1 child-2))
 136   nil)
 137
 138
 139
 140
 141 (declaim (inline child-member child-remove child-position))
 142
 143 (defun child-member (child list)
 144   (member child list :test #'child-equal-p))
 145
 146 (defun child-remove (child list)
 147   (remove child list :test #'child-equal-p))
 148
 149 (defun child-position (child list)
 150   (position child list :test #'child-equal-p))
 151
 152
 153
 154 ;;; Frame data manipulation functions
 155 (defun frame-data-slot (frame slot)
 156   "Return the value associated to data slot"
 157   (when (frame-p frame)
 158     (second (assoc slot (frame-data frame)))))
 159
 160 (defun set-frame-data-slot (frame slot value)
 161   "Set the value associated to data slot"
 162   (when (frame-p frame)
 163     (with-slots (data) frame
 164       (setf data (remove (assoc slot data) data))
 165       (push (list slot value) data))
 166     value))
 167
 168 (defsetf frame-data-slot set-frame-data-slot)
 169
 170
 171 (defun remove-frame-data-slot (frame slot)
 172   "Remove a slot in frame data slots"
 173   (when (frame-p frame)
 174     (with-slots (data) frame
 175       (setf data (remove (assoc slot data) data)))))
 176
 177
 178
 179 (defun managed-window-p (window frame)
 180   "Return t only if window is managed by frame"
 181   (if (frame-p frame)
 182       (with-slots ((managed forced-managed-window)
 183                    (unmanaged forced-unmanaged-window)) frame
 184         (and (xlib:window-p window)
 185              (not (child-member window unmanaged))
 186              (not (member (xlib:wm-name window) unmanaged :test #'string-equal-p))
 187              (or (member :all (frame-managed-type frame))
 188                  (member (window-type window) (frame-managed-type frame))
 189                  (child-member window managed)
 190                  (member (xlib:wm-name window) managed :test #'string-equal-p))))
 191       t))
 192
 193
 194 (defun never-managed-window-p (window)
 195   (when (xlib:window-p window)
 196     (dolist (type *never-managed-window-list*)
 197       (when (funcall (first type) window)
 198         (return (values t (second type)))))))
 199
 200
 201
 202 (defgeneric child-name (child))
 203
 204 (defmethod child-name ((child xlib:window))
 205   (xlib:wm-name child))
 206
 207 (defmethod child-name ((child frame))
 208   (frame-name child))
 209
 210 (defmethod child-name (child)
 211   (declare (ignore child))
 212   "???")
 213
 214
 215 (defgeneric set-child-name (child name))
 216
 217 (defmethod set-child-name ((child xlib:window) name)
 218   (setf (xlib:wm-name child) name))
 219
 220 (defmethod set-child-name ((child frame) name)
 221   (setf (frame-name child) name))
 222
 223 (defmethod set-child-name (child name)
 224   (declare (ignore child name)))
 225
 226 (defsetf child-name set-child-name)
 227
 228
 229
 230
 231 (defgeneric child-fullname (child))
 232
 233 (defmethod child-fullname ((child xlib:window))
 234   (format nil "~A (~A)" (or (xlib:wm-name child) "?") (or (xlib:get-wm-class child) "?")))
 235
 236 (defmethod child-fullname ((child frame))
 237   (aif (frame-name child)
 238        (format nil "~A (Frame ~A)" it (frame-number child))
 239        (format nil "Frame ~A" (frame-number child))))
 240
 241 (defmethod child-fullname (child)
 242   (declare (ignore child))
 243   "???")
 244
 245
 246 (defgeneric child-transparency (child))
 247
 248 (defmethod child-transparency ((child xlib:window))
 249   (window-transparency child))
 250
 251 (defmethod child-transparency ((child frame))
 252   (window-transparency (frame-window child)))
 253
 254 (defmethod child-transparency (child)
 255   (declare (ignore child))
 256   1)
 257
 258 (defgeneric set-child-transparency (child value))
 259
 260 (defmethod set-child-transparency ((child xlib:window) value)
 261   (setf (window-transparency child) value))
 262
 263 (defmethod set-child-transparency ((child frame) value)
 264   (setf (window-transparency (frame-window child)) value))
 265
 266 (defmethod set-child-transparency (child value)
 267   (declare (ignore child value)))
 268
 269 (defsetf child-transparency set-child-transparency)
 270
 271
 272
 273
 274 (defgeneric child-x (child))
 275 (defmethod child-x ((child xlib:window))
 276   (x-drawable-x child))
 277 (defmethod child-x ((child frame))
 278   (frame-rx child))
 279
 280 (defgeneric child-y (child))
 281 (defmethod child-y ((child xlib:window))
 282   (x-drawable-y child))
 283 (defmethod child-y ((child frame))
 284   (frame-ry child))
 285
 286 (defgeneric child-width (child))
 287 (defmethod child-width ((child xlib:window))
 288   (x-drawable-width child))
 289 (defmethod child-width ((child frame))
 290   (frame-rw child))
 291
 292 (defgeneric child-height (child))
 293 (defmethod child-height ((child xlib:window))
 294   (x-drawable-height child))
 295 (defmethod child-height ((child frame))
 296   (frame-rh child))
 297
 298 (defgeneric child-x2 (child))
 299 (defmethod child-x2 ((child xlib:window))
 300   (+ (x-drawable-x child) (x-drawable-width child)))
 301 (defmethod child-x2 ((child frame))
 302   (+ (frame-rx child) (frame-rw child)))
 303
 304 (defgeneric child-y2 (child))
 305 (defmethod child-y2 ((child xlib:window))
 306   (+ (x-drawable-y child) (x-drawable-height child)))
 307 (defmethod child-y2 ((child frame))
 308   (+ (frame-ry child) (frame-rh child)))
 309
 310
 311
 312 (defgeneric child-center (child))
 313
 314 (defmethod child-center ((child xlib:window))
 315   (values (+ (x-drawable-x child) (/ (x-drawable-width child) 2))
 316           (+ (x-drawable-y child) (/ (x-drawable-height child) 2))))
 317
 318 (defmethod child-center ((child frame))
 319   (values (+ (frame-rx child) (/ (frame-rw child) 2))
 320           (+ (frame-ry child) (/ (frame-rh child) 2))))
 321
 322 (defun child-distance (child1 child2)
 323   (multiple-value-bind (x1 y1) (child-center child1)
 324     (multiple-value-bind (x2 y2) (child-center child2)
 325       (values (+ (abs (- x2 x1)) (abs (- y2 y1)))
 326               (- x2 x1)
 327               (- y2 y1)))))
 328
 329 (defun middle-child-x (child)
 330   (+ (child-x child) (/ (child-width child) 2)))
 331
 332 (defun middle-child-y (child)
 333   (+ (child-y child) (/ (child-height child) 2)))
 334
 335 (declaim (inline adj-border-xy adj-border-wh))
 336 (defgeneric adj-border-xy (value child))
 337 (defgeneric adj-border-wh (value child))
 338
 339 (defmethod adj-border-xy (v (child xlib:window))
 340   (+ v (x-drawable-border-width child)))
 341
 342 (defmethod adj-border-xy (v (child frame))
 343   (+ v (x-drawable-border-width (frame-window child))))
 344
 345 (defmethod adj-border-wh (v (child xlib:window))
 346   (- v (* (x-drawable-border-width child) 2)))
 347
 348 (defmethod adj-border-wh (v (child frame))
 349   (- v (* (x-drawable-border-width (frame-window child)) 2)))
 350
 351
 352 (declaim (inline anti-adj-border-xy anti-adj-border-wh))
 353 (defgeneric anti-adj-border-xy (value child))
 354 (defgeneric anti-adj-border-wh (value child))
 355
 356 (defmethod anti-adj-border-xy (v (child xlib:window))
 357   (- v (x-drawable-border-width child)))
 358
 359 (defmethod anti-adj-border-xy (v (child frame))
 360   (- v (x-drawable-border-width (frame-window child))))
 361
 362 (defmethod anti-adj-border-wh (v (child xlib:window))
 363   (+ v (* (x-drawable-border-width child) 2)))
 364
 365 (defmethod anti-adj-border-wh (v (child frame))
 366   (+ v (* (x-drawable-border-width (frame-window child)) 2)))
 367
 368
 369
 370
 371 (defmacro with-focus-window ((window) &body body)
 372   `(let ((,window (xlib:input-focus *display*)))
 373      (when (and ,window (not (xlib:window-equal ,window *no-focus-window*)))
 374        ,@body)))
 375
 376
 377 (defun is-in-current-child-p (child)
 378   (and (frame-p (current-child))
 379        (child-member child (frame-child (current-child)))))
 380
 381
 382
 383 ;; (with-all-children (*root-frame* child) (typecase child (xlib:window (print child)) (frame (print (frame-number child)))))
 384 (defmacro with-all-children ((root child) &body body)
 385   (let ((rec (gensym))
 386         (sub-child (gensym)))
 387     `(block nil
 388        (labels ((,rec (,child)
 389                   ,@body
 390                   (when (frame-p ,child)
 391                     (dolist (,sub-child (reverse (frame-child ,child)))
 392                       (,rec ,sub-child)))))
 393          (,rec ,root)))))
 394
 395
 396 ;; (with-all-children (*root-frame* child) (typecase child (xlib:window (print child)) (frame (print (frame-number child)))))
 397 (defmacro with-all-children-reversed ((root child) &body body)
 398   (let ((rec (gensym))
 399         (sub-child (gensym)))
 400     `(block nil
 401        (labels ((,rec (,child)
 402                   ,@body
 403                   (when (frame-p ,child)
 404                     (dolist (,sub-child (frame-child ,child))
 405                       (,rec ,sub-child)))))
 406          (,rec ,root)))))
 407
 408
 409
 410
 411
 412 ;; (with-all-frames (*root-frame* frame) (print (frame-number frame)))
 413 (defmacro with-all-frames ((root frame) &body body)
 414   (let ((rec (gensym))
 415         (child (gensym)))
 416     `(block nil
 417        (labels ((,rec (,frame)
 418                   (when (frame-p ,frame)
 419                     ,@body
 420                     (dolist (,child (reverse (frame-child ,frame)))
 421                       (,rec ,child)))))
 422          (,rec ,root)))))
 423
 424
 425 ;; (with-all-windows (*root-frame* window) (print window))
 426 (defmacro with-all-windows ((root window) &body body)
 427   (let ((rec (gensym))
 428         (child (gensym)))
 429     `(block nil
 430        (labels ((,rec (,window)
 431                   (when (xlib:window-p ,window)
 432                     ,@body)
 433                   (when (frame-p ,window)
 434                     (dolist (,child (reverse (frame-child ,window)))
 435                       (,rec ,child)))))
 436          (,rec ,root)))))
 437
 438
 439
 440 ;; (with-all-frames-windows (*root-frame* child) (print child) (print (frame-number child)))
 441 (defmacro with-all-windows-frames ((root child) body-window body-frame)
 442   (let ((rec (gensym))
 443         (sub-child (gensym)))
 444     `(block nil
 445        (labels ((,rec (,child)
 446                   (typecase ,child
 447                     (xlib:window ,body-window)
 448                     (frame ,body-frame
 449                            (dolist (,sub-child (reverse (frame-child ,child)))
 450                              (,rec ,sub-child))))))
 451          (,rec ,root)))))
 452
 453 (defmacro with-all-windows-frames-and-parent ((root child parent) body-window body-frame)
 454   (let ((rec (gensym))
 455         (sub-child (gensym)))
 456     `(block nil
 457        (labels ((,rec (,child ,parent)
 458                   (typecase ,child
 459                     (xlib:window ,body-window)
 460                     (frame ,body-frame
 461                            (dolist (,sub-child (reverse (frame-child ,child)))
 462                              (,rec ,sub-child ,child))))))
 463          (,rec ,root nil)))))
 464
 465
 466
 467 (defun create-frame-window ()
 468   (let ((win (xlib:create-window :parent *root*
 469                                  :x 0
 470                                  :y 0
 471                                  :width 200
 472                                  :height 200
 473                                  :background (get-color *frame-background*)
 474                                  :colormap (xlib:screen-default-colormap *screen*)
 475                                  :border-width *border-size*
 476                                  :border (get-color *color-selected*)
 477                                  :event-mask '(:exposure :button-press :button-release :pointer-motion :enter-window))))
 478     (setf (window-transparency win) *frame-transparency*)
 479     win))
 480
 481 (defun create-frame-gc (window)
 482   (xlib:create-gcontext :drawable window
 483                         :foreground (get-color *frame-foreground*)
 484                         :background (get-color *frame-background*)
 485                         :font *default-font*
 486                         :line-style :solid))
 487
 488
 489 (defun destroy-all-frames-window ()
 490   (with-all-frames (*root-frame* frame)
 491     (when (frame-gc frame)
 492       (xlib:free-gcontext (frame-gc frame))
 493       (setf (frame-gc frame) nil))
 494     (when (frame-window frame)
 495       (xlib:destroy-window (frame-window frame))
 496       (setf (frame-window frame) nil))))
 497
 498 (defun create-all-frames-window ()
 499   (with-all-frames (*root-frame* frame)
 500     (unless (frame-window frame)
 501       (setf (frame-window frame) (create-frame-window)))
 502     (unless (frame-gc frame)
 503       (setf (frame-gc frame) (create-frame-gc (frame-window frame)))))
 504   (with-all-frames (*root-frame* frame)
 505     (dolist (child (frame-child frame))
 506       (handler-case
 507           (dbg (child-fullname child))
 508         (error (c)
 509           (setf (frame-child frame) (remove child (frame-child frame) :test #'child-equal-p))
 510           (dbg c child))))))
 511
 512
 513
 514
 515 (defun frame-find-free-number ()
 516   (let ((all-numbers nil))
 517     (with-all-frames (*root-frame* frame)
 518       (pushnew (frame-number frame) all-numbers))
 519     (find-free-number all-numbers)))
 520
 521
 522 (defun create-frame (&rest args &key (number (frame-find-free-number)) &allow-other-keys)
 523   (let* ((window (create-frame-window))
 524          (gc (create-frame-gc window)))
 525     (apply #'make-instance 'frame :number number :window window :gc gc args)))
 526
 527
 528
 529
 530
 531 (defun add-frame (frame parent)
 532   (push frame (frame-child parent))
 533   frame)
 534
 535
 536 (defun place-frame (frame parent prx pry prw prh)
 537   "Place a frame from real (pixel) coordinates"
 538   (when (and (frame-p frame) (frame-p parent))
 539     (with-slots (window x y w h) frame
 540       (setf (x-drawable-x window) prx
 541             (x-drawable-y window) pry
 542             (x-drawable-width window) prw
 543             (x-drawable-height window) prh
 544             x (x-px->fl prx parent)
 545             y (y-px->fl pry parent)
 546             w (w-px->fl prw parent)
 547             h (h-px->fl prh parent))
 548       (xlib:display-finish-output *display*))))
 549
 550 (defun fixe-real-size (frame parent)
 551   "Fixe real (pixel) coordinates in float coordinates"
 552   (when (frame-p frame)
 553     (with-slots (x y w h rx ry rw rh) frame
 554       (setf x (x-px->fl rx parent)
 555             y (y-px->fl ry parent)
 556             w (w-px->fl (anti-adj-border-wh rw parent) parent)
 557             h (h-px->fl (anti-adj-border-wh rh parent) parent)))))
 558
 559 (defun fixe-real-size-current-child ()
 560   "Fixe real (pixel) coordinates in float coordinates for children in the current child"
 561   (when (frame-p (current-child))
 562     (dolist (child (frame-child (current-child)))
 563       (fixe-real-size child (current-child)))))
 564
 565
 566
 567
 568 (defun find-child (to-find root)
 569   "Find to-find in root or in its children"
 570   (with-all-children (root child)
 571     (when (child-equal-p child to-find)
 572       (return-from find-child t))))
 573
 574
 575
 576 (defmacro with-find-in-all-frames (test &optional return-value)
 577   `(let (ret)
 578      (block return-block
 579        (with-all-frames (root frame)
 580          (when ,test
 581            (if first-foundp
 582                (return-from return-block (or ,return-value frame))
 583                (setf ret frame))))
 584        (or ,return-value ret))))
 585
 586 (defun find-parent-frame  (to-find &optional (root *root-frame*) first-foundp)
 587   "Return the parent frame of to-find"
 588   (with-find-in-all-frames
 589       (child-member to-find (frame-child frame))))
 590
 591 (defun find-frame-window (window &optional (root *root-frame*) first-foundp)
 592   "Return the frame with the window window"
 593   (with-find-in-all-frames
 594       (xlib:window-equal window (frame-window frame))))
 595
 596 (defun find-frame-by-name (name &optional (root *root-frame*) first-foundp)
 597   "Find a frame from its name"
 598   (when name
 599     (with-find-in-all-frames
 600         (string-equal name (frame-name frame)))))
 601
 602 (defun find-frame-by-number (number &optional (root *root-frame*) first-foundp)
 603   "Find a frame from its number"
 604   (when (numberp number)
 605     (with-find-in-all-frames
 606         (= number (frame-number frame)))))
 607
 608
 609 (defun find-child-in-parent (child base)
 610   "Return t if child is in base or in its parents"
 611   (labels ((rec (base)
 612              (when (child-equal-p child base)
 613                (return-from find-child-in-parent t))
 614              (let ((parent (find-parent-frame base)))
 615                (when parent
 616                  (rec parent)))))
 617     (rec base)))
 618
 619 ;;; Multiple roots support (replace the old *current-root* variable)
 620 ;; TODO: Add find-root-by-coordinates, change-root-geometry
 621 (let ((root-list nil)
 622       (current-child nil))
 623   (defun define-as-root (child x y width height)
 624     (push (make-root :child child :original child :current-child nil :x x :y y :w width :h height) root-list))
 625
 626   (defun unsure-at-least-one-root ()
 627     (unless root-list
 628       (define-as-root *root-frame* (- *border-size*) (- *border-size*)
 629                       (xlib:screen-width *screen*) (xlib:screen-height *screen*))))
 630
 631   (defun find-root-by-coordinates (x y)
 632     (dolist (root root-list)
 633       (when (in-rect x y (root-x root) (root-y root) (root-w root) (root-h root))
 634         (return root))))
 635
 636   (defun all-root-child ()
 637     (loop for root in root-list
 638        collect (root-child root)))
 639
 640   (labels ((generic-child-root-p (child function)
 641              (dolist (root root-list)
 642                (when (child-equal-p child (funcall function root))
 643                  (return root)))))
 644     (defun child-root-p (child)
 645       (generic-child-root-p child #'root-child))
 646
 647     (defun child-original-root-p (child)
 648       (generic-child-root-p child #'root-original)))
 649
 650   (defun change-root (old-root new-child)
 651     (when (and old-root new-child)
 652       (setf (root-child old-root) new-child)))
 653
 654   (defun find-root (child)
 655     (aif (child-original-root-p child)
 656          it
 657          (awhen (find-parent-frame child)
 658            (find-root it))))
 659
 660   (defun find-child-in-all-root (child)
 661     (dolist (root root-list)
 662       (when (find-child child (root-child root))
 663         (return-from find-child-in-all-root root))))
 664
 665   (defun find-current-root ()
 666     (root-child (find-root (current-child))))
 667
 668   (defun current-child ()
 669     current-child)
 670
 671   (defun current-child-setter (value)
 672     (let ((current-root (find-root current-child)))
 673       (dolist (root root-list)
 674         (when (equal root current-root)
 675           (setf (root-current-child root) current-child))))
 676     (setf current-child value))
 677
 678   (defmacro with-current-child ((new-child) &body body)
 679     "Temporarly change the current child"
 680     (let ((old-child (gensym))
 681           (ret (gensym)))
 682       `(let ((,old-child (current-child)))
 683          (setf (current-child) ,new-child)
 684          (let ((,ret (multiple-value-list (progn ,@body))))
 685            (setf (current-child) ,old-child)
 686            (values-list ,ret)))))
 687 )
 688
 689 (defsetf current-child current-child-setter)
 690
 691
 692
 693 ;;; Multiple physical screen helper
 694 (defun add-placed-frame-tmp (frame n)   ;; For test
 695   (add-frame (create-frame :x 0.01 :y 0.01 :w 0.4 :h 0.4) frame)
 696   (add-frame (create-frame :x 0.55 :y 0.01 :w 0.4 :h 0.4) frame)
 697   (add-frame (create-frame :x 0.03 :y 0.5 :w 0.64 :h 0.44) frame)
 698   (when (plusp n)
 699     (add-placed-frame-tmp (first (frame-child frame)) (1- n))))
 700
 701 (defun parse-xinerama-info (line)
 702   (remove nil
 703           (mapcar (lambda (string)
 704                     (parse-integer string :junk-allowed t))
 705                   (split-string (substitute #\space #\x (substitute #\space #\, line))))))
 706
 707 (defun get-connected-heads-size (&optional (fake nil))
 708   (labels ((heads-info ()
 709              (if (not fake)
 710                  (do-shell "xdpyinfo -ext XINERAMA")
 711                  (progn
 712                    (setf *show-root-frame-p* t)
 713                    (do-shell "echo '    available colormap entries:    256 per subfield
 714     red, green, blue masks:    0xff0000, 0xff00, 0xff
 715     significant bits in color specification:    8 bits
 716
 717 XINERAMA version 1.1 opcode: 150
 718   head #0: 500x300 @ 10,10
 719   head #1: 480x300 @ 520,20
 720   head #2: 600x250 @ 310,330'")))))
 721     (when (xlib:query-extension *display* "XINERAMA")
 722       (let ((output (heads-info))
 723             (sizes nil))
 724         (loop for line = (read-line output nil nil)
 725            while line
 726            do (when (search " head " line)
 727                 (destructuring-bind (w h x y)
 728                     (parse-xinerama-info line)
 729                   (push (list (- x *border-size*) (- y *border-size*) w h) sizes))))
 730         (dbg sizes)
 731         (remove-duplicates sizes :test #'equal)))))
 732
 733
 734 (defun place-frames-from-xinerama-infos ()
 735   "Place frames according to xdpyinfo/xinerama informations"
 736   (let ((sizes (get-connected-heads-size))
 737         (width (xlib:screen-width *screen*))
 738         (height (xlib:screen-height *screen*)))
 739     ;;(add-placed-frame-tmp (first (frame-child *root-frame*)) 2)
 740     (if (<= (length sizes) 1)
 741         (define-as-root *root-frame* (- *border-size*) (- *border-size*) width height)
 742         (progn
 743           (loop while (< (length (frame-child *root-frame*)) (length sizes))
 744              do (let ((frame (create-frame)))
 745                   ;;(add-placed-frame-tmp frame 2)))
 746                   (add-frame frame *root-frame*)))
 747           (loop for size in sizes
 748              for frame in (frame-child *root-frame*)
 749              do (destructuring-bind (x y w h) size
 750                   (setf (frame-x frame) (float (/ x width))
 751                         (frame-y frame) (float (/ y height))
 752                         (frame-w frame) (float (/ w width))
 753                         (frame-h frame) (float (/ h height)))
 754                   (add-frame (create-frame) frame)
 755                   (define-as-root frame x y w h)))
 756           (setf (current-child) (first (frame-child (first (frame-child *root-frame*)))))))))
 757
 758
 759
 760
 761 (defun get-all-windows (&optional (root *root-frame*))
 762   "Return all windows in root and in its children"
 763   (let ((acc nil))
 764     (with-all-windows (root window)
 765       (push window acc))
 766     acc))
 767
 768
 769 (defun get-hidden-windows ()
 770   "Return all hiddens windows"
 771   (let ((all-windows (get-all-windows))
 772         (hidden-windows (remove-if-not #'window-hidden-p
 773                                        (copy-list (xlib:query-tree *root*)))))
 774     (set-difference hidden-windows all-windows)))
 775
 776
 777
 778 ;;; Current window utilities
 779 (defun get-current-window ()
 780   (typecase (current-child)
 781     (xlib:window  (current-child))
 782     (frame (frame-selected-child (current-child)))))
 783
 784 (defmacro with-current-window (&body body)
 785   "Bind 'window' to the current window"
 786   `(let ((window (get-current-window)))
 787       (when (xlib:window-p window)
 788         ,@body)))
 789
 790 (defun get-first-window ()
 791   (typecase (current-child)
 792     (xlib:window  (current-child))
 793     (frame (or (first (frame-child (current-child)))
 794                (current-child)))))
 795
 796
 797
 798
 799
 800 (defun display-frame-info (frame)
 801   (when (frame-p frame)
 802     (let ((dy (+ (xlib:max-char-ascent *default-font*) (xlib:max-char-descent *default-font*))))
 803       (with-slots (name number gc window child hidden-children) frame
 804         (setf (xlib:gcontext-background gc) (get-color *frame-background*)
 805               (xlib:window-background window) (get-color *frame-background*))
 806         (clear-pixmap-buffer window gc)
 807         (setf (xlib:gcontext-foreground gc) (get-color (if (and (child-root-p frame)
 808                                                                 (child-equal-p frame (current-child)))
 809                                                            *frame-foreground-root* *frame-foreground*)))
 810         (xlib:draw-glyphs *pixmap-buffer* gc 5 dy
 811                           (format nil "Frame: ~A~A"
 812                                   number
 813                                   (if name  (format nil " - ~A" name) "")))
 814         (let ((pos dy))
 815           (when (child-root-p frame)
 816             (when *child-selection*
 817               (xlib:draw-glyphs *pixmap-buffer* gc 5 (incf pos dy)
 818                                 (with-output-to-string (str)
 819                                   (format str "  Selection: ")
 820                                   (dolist (child *child-selection*)
 821                                     (typecase child
 822                                       (xlib:window (format str "  ~A " (xlib:wm-name child)))
 823                                       (frame (format str "  frame:~A[~A] " (frame-number child)
 824                                                      (aif (frame-name child) it "")))))))))
 825           (dolist (ch child)
 826             (xlib:draw-glyphs *pixmap-buffer* gc 5 (incf pos dy)
 827                               (format nil "  ~A" (ensure-printable (child-fullname ch))))))
 828         (copy-pixmap-buffer window gc)
 829         (values t t)))))
 830
 831
 832 (defun display-all-frame-info ()
 833   (with-all-frames (*root-frame* frame)
 834     (display-frame-info frame)))
 835
 836 (defun display-all-root-frame-info ()
 837   (dolist (root (all-root-child))
 838     (display-frame-info root)))
 839
 840
 841 (defgeneric rename-child (child name))
 842
 843 (defmethod rename-child ((child frame) name)
 844   (setf (frame-name child) name)
 845   (display-frame-info child))
 846
 847 (defmethod rename-child ((child xlib:window) name)
 848   (setf (xlib:wm-name child) name))
 849
 850 (defmethod rename-child (child name)
 851   (declare (ignore child name)))
 852
 853
 854
 855
 856 (defun get-parent-layout (child parent)
 857   (aif (child-root-p child)
 858        (values (root-x it) (root-y it) (root-w it) (root-h it))
 859        (if (or (frame-p child) (managed-window-p child parent))
 860            (if (frame-p parent)
 861                (aif (frame-layout parent)
 862                     (funcall it child parent)
 863                     (no-layout child parent))
 864                (values (- *border-size*) (- *border-size*)
 865                        (xlib:screen-width *screen*)
 866                        (xlib:screen-height *screen*)))
 867            (values (x-drawable-x child) (x-drawable-y child)
 868                    (x-drawable-width child) (x-drawable-height child)))))
 869
 870
 871
 872
 873
 874 (defgeneric adapt-child-to-parent (child parent))
 875
 876 (defmethod adapt-child-to-parent ((window xlib:window) parent)
 877   (when (managed-window-p window parent)
 878     (multiple-value-bind (nx ny nw nh)
 879         (get-parent-layout window parent)
 880       (setf nw (max nw 1)  nh (max nh 1))
 881       (let ((change (or (/= (x-drawable-x window) nx)
 882                         (/= (x-drawable-y window) ny)
 883                         (/= (x-drawable-width window) nw)
 884                         (/= (x-drawable-height window) nh))))
 885         (when change
 886           (setf (x-drawable-x window) nx
 887                 (x-drawable-y window) ny
 888                 (x-drawable-width window) nw
 889                 (x-drawable-height window) nh))
 890         change))))
 891
 892
 893 (defmethod adapt-child-to-parent ((frame frame) parent)
 894   (declare (ignore parent))
 895     (with-slots (rx ry rw rh window) frame
 896       (let ((change (or (/= (x-drawable-x window) rx)
 897                         (/= (x-drawable-y window) ry)
 898                         (/= (x-drawable-width window) rw)
 899                         (/= (x-drawable-height window) rh))))
 900         (when change
 901           (setf (x-drawable-x window) rx
 902                 (x-drawable-y window) ry
 903                 (x-drawable-width window) rw
 904                 (x-drawable-height window) rh))
 905         change)))
 906
 907 (defmethod adapt-child-to-parent (child parent)
 908   (declare (ignore child parent))
 909   nil)
 910
 911
 912 (defgeneric set-child-stack-order (window child)
 913   (:documentation "Raise window if child is NIL else put window just below child"))
 914
 915 (defmethod set-child-stack-order (window (child xlib:window))
 916   (lower-window window child))
 917
 918 (defmethod set-child-stack-order (window (child frame))
 919   (lower-window window (frame-window child)))
 920
 921 (defmethod set-child-stack-order (window child)
 922   (declare (ignore child))
 923   (raise-window window))
 924
 925
 926
 927 (defgeneric show-child (child parent previous))
 928
 929 (defmethod show-child ((frame frame) parent previous)
 930   (declare (ignore parent))
 931   (with-slots (window show-window-p) frame
 932     (if (and show-window-p
 933              (or *show-root-frame-p* (not (child-root-p frame))))
 934         (progn
 935           (map-window window)
 936           (set-child-stack-order window previous)
 937           (display-frame-info frame))
 938         (hide-window window))))
 939
 940
 941
 942 (defun hide-unmanaged-window-p (parent)
 943   (let ((action (frame-data-slot parent :unmanaged-window-action)))
 944     (case action
 945       (:hide t)
 946       (:show nil)
 947       (t *hide-unmanaged-window*))))
 948
 949
 950 (defmethod show-child ((window xlib:window) parent previous)
 951   (if (or (managed-window-p window parent)
 952           (child-equal-p window (current-child))
 953           (not (hide-unmanaged-window-p parent))
 954           (child-equal-p parent (current-child)))
 955       (progn
 956         (map-window window)
 957         (set-child-stack-order window previous))
 958       (hide-window window)))
 959
 960 (defmethod show-child (child parent raise-p)
 961   (declare (ignore child parent raise-p))
 962   ())
 963
 964
 965 (defgeneric hide-child (child))
 966
 967 (defmethod hide-child ((frame frame))
 968   (with-slots (window) frame
 969     (xlib:unmap-window window)))
 970
 971 (defmethod hide-child ((window xlib:window))
 972   (hide-window window))
 973
 974 (defmethod hide-child (child)
 975   (declare (ignore child))
 976   ())
 977
 978
 979 (defgeneric select-child (child selected))
 980
 981 (labels ((get-selected-color (child selected-p)
 982            (get-color (cond ((child-equal-p child (current-child)) *color-selected*)
 983                             (selected-p *color-maybe-selected*)
 984                             (t *color-unselected*)))))
 985   (defmethod select-child ((frame frame) selected-p)
 986     (when (and (frame-p frame) (frame-window frame))
 987       (setf (xlib:window-border (frame-window frame))
 988             (get-selected-color frame selected-p))))
 989
 990   (defmethod select-child ((window xlib:window) selected-p)
 991     (setf (xlib:window-border window)
 992           (get-selected-color window selected-p)))
 993
 994   (defmethod select-child (child selected)
 995     (declare (ignore child selected))
 996     ()))
 997
 998 (defun select-current-frame (selected)
 999   (select-child (current-child) selected))
1000
1001 (defun unselect-all-frames ()
1002   (with-all-children (*root-frame* child)
1003     (select-child child nil)))
1004
1005
1006
1007 (defun set-focus-to-current-child ()
1008   (labels ((rec (child)
1009              (typecase child
1010                (xlib:window (focus-window child))
1011                (frame (rec (frame-selected-child child))))))
1012     (no-focus)
1013     (rec (current-child))))
1014
1015
1016
1017
1018 (defun adapt-frame-to-parent (frame parent)
1019   (multiple-value-bind (nx ny nw nh)
1020       (get-parent-layout frame parent)
1021     (with-slots (rx ry rw rh window) frame
1022       (setf rx nx  ry ny
1023             rw (max nw 1)
1024             rh (max nh 1)))))
1025
1026
1027 (defun adapt-child-to-rect (rect)
1028   (let ((window (typecase (child-rect-child rect)
1029                   (xlib:window (when (managed-window-p (child-rect-child rect) (child-rect-parent rect))
1030                                  (child-rect-child rect)))
1031                   (frame (frame-window (child-rect-child rect))))))
1032     (when window
1033       (let ((change (or (/= (x-drawable-x window) (child-rect-x rect))
1034                         (/= (x-drawable-y window) (child-rect-y rect))
1035                         (/= (x-drawable-width window) (child-rect-w rect))
1036                         (/= (x-drawable-height window) (child-rect-h rect)))))
1037         (when change
1038           (setf (x-drawable-x window) (child-rect-x rect)
1039                 (x-drawable-y window) (child-rect-y rect)
1040                 (x-drawable-width window) (child-rect-w rect)
1041                 (x-drawable-height window) (child-rect-h rect)))
1042         change))))
1043
1044
1045
1046
1047 (defun show-all-children (&optional (from-root-frame nil))
1048   "Show all children and hide those not in a root frame"
1049   (let ((geometry-change nil)
1050         (displayed-child nil)
1051         (hidden-child nil))
1052     (labels ((in-displayed-list (child)
1053                (member child displayed-child :test (lambda (c rect)
1054                                                      (child-equal-p c (child-rect-child rect)))))
1055
1056              (add-in-hidden-list (child)
1057                (pushnew child hidden-child :test #'child-equal-p))
1058
1059              (set-geometry (child parent in-current-root child-current-root-p)
1060                (if (or in-current-root child-current-root-p)
1061                    (when (frame-p child)
1062                      (adapt-frame-to-parent child (if child-current-root-p nil parent)))
1063                    (add-in-hidden-list child)))
1064
1065              (recurse-on-frame-child (child in-current-root child-current-root-p selected-p)
1066                (let ((selected-child (frame-selected-child child)))
1067                  (dolist (sub-child (frame-child child))
1068                    (rec sub-child child
1069                         (and selected-p (child-equal-p sub-child selected-child))
1070                         (or in-current-root child-current-root-p)))))
1071
1072              (hidden-child-p (rect)
1073                (dolist (r displayed-child)
1074                  (when (rect-hidden-p r rect)
1075                    (return t))))
1076
1077              (select-and-display (child parent selected-p)
1078                (multiple-value-bind (nx ny nw nh)
1079                    (get-parent-layout child parent)
1080                  (let ((rect (make-child-rect :child child :parent parent
1081                                               :selected-p selected-p
1082                                               :x nx :y ny :w nw :h nh)))
1083                    (if (hidden-child-p rect)
1084                        (add-in-hidden-list child)
1085                        (push rect displayed-child)))))
1086
1087              (display-displayed-child ()
1088                (let ((previous nil))
1089                  (dolist (rect (nreverse displayed-child))
1090                    (when (adapt-child-to-rect rect)
1091                      (setf geometry-change t))
1092                    (select-child (child-rect-child rect) (child-rect-selected-p rect))
1093                    (show-child (child-rect-child rect)
1094                                (child-rect-parent rect)
1095                                previous)
1096                    (setf previous (child-rect-child rect)))))
1097
1098              (rec (child parent selected-p in-current-root)
1099                (let ((child-current-root-p (child-root-p child)))
1100                  (unless (in-displayed-list child)
1101                    (set-geometry child parent in-current-root child-current-root-p))
1102                  (when (frame-p child)
1103                    (recurse-on-frame-child child in-current-root child-current-root-p selected-p))
1104                  (when (and (or in-current-root child-current-root-p)
1105                             (not (in-displayed-list child)))
1106                    (select-and-display child parent selected-p)))))
1107
1108       (rec *root-frame* nil t (child-root-p *root-frame*))
1109       (display-displayed-child)
1110       (dolist (child hidden-child)
1111         (hide-child child))
1112       (set-focus-to-current-child)
1113       (xlib:display-finish-output *display*)
1114       geometry-change)))
1115
1116
1117
1118
1119 (defun hide-all-children (root &optional except)
1120   "Hide all root children"
1121   (when (and (frame-p root) (not (child-equal-p root except)))
1122     (dolist (child (frame-child root))
1123       (hide-all child except))))
1124
1125 (defun hide-all (root &optional except)
1126   "Hide root and all its children"
1127   (unless (child-equal-p root except)
1128     (hide-child root))
1129   (hide-all-children root except))
1130
1131
1132
1133
1134
1135 (defun focus-child (child parent)
1136   "Focus child - Return true if something has change"
1137   (when (and (frame-p parent)
1138              (child-member child (frame-child parent)))
1139     (when (not (child-equal-p child (frame-selected-child parent)))
1140       (with-slots ((parent-child child) selected-pos) parent
1141         (setf parent-child (nth-insert selected-pos child (child-remove child parent-child))))
1142       t)))
1143
1144 (defun focus-child-rec (child parent)
1145   "Focus child and its parents - Return true if something has change"
1146   (let ((change nil))
1147     (labels ((rec (child parent)
1148                (when (focus-child child parent)
1149                  (setf change t))
1150                (when parent
1151                  (rec parent (find-parent-frame parent)))))
1152       (rec child parent))
1153     change))
1154
1155
1156 (defun set-current-child-generic (child)
1157   (unless (child-equal-p (current-child) child)
1158     (setf (current-child) child)
1159     t))
1160
1161 (defgeneric set-current-child (child parent window-parent))
1162
1163 (defmethod set-current-child ((child xlib:window) parent window-parent)
1164   (set-current-child-generic (if window-parent parent child)))
1165
1166 (defmethod set-current-child ((child frame) parent window-parent)
1167   (declare (ignore parent window-parent))
1168   (set-current-child-generic child))
1169
1170 (defmethod set-current-child (child parent window-parent)
1171   (declare (ignore child parent window-parent))
1172   ())
1173
1174
1175 (defun set-current-root (child parent window-parent)
1176   "Set current root if parent is not in current root"
1177   (let ((root (find-root child)))
1178     (when (and window-parent
1179                (not (child-root-p child))
1180                (not (find-child parent (root-child root))))
1181       (change-root root parent)
1182       t)))
1183
1184
1185 (defun focus-all-children (child parent &optional (window-parent t))
1186   "Focus child and its parents -
1187 For window: set current child to window or its parent according to window-parent"
1188   (let ((new-focus (focus-child-rec child parent))
1189         (new-current-child (set-current-child child parent window-parent))
1190         (new-root (set-current-root child parent window-parent)))
1191     (or new-focus new-current-child new-root)))
1192
1193
1194
1195
1196 (defun select-next-level ()
1197   "Select the next level in frame"
1198   (select-current-frame :maybe)
1199   (when (frame-p (current-child))
1200     (awhen (frame-selected-child (current-child))
1201       (setf (current-child) it)))
1202   (show-all-children))
1203
1204 (defun select-previous-level ()
1205   "Select the previous level in frame"
1206   (unless (child-root-p (current-child))
1207     (select-current-frame :maybe)
1208     (awhen (find-parent-frame (current-child))
1209       (setf (current-child) it))
1210     (show-all-children)))
1211
1212
1213 (defun enter-frame ()
1214   "Enter in the selected frame - ie make it the root frame"
1215   (let ((root (find-root (current-child))))
1216     (unless (child-equal-p (root-child root) (current-child))
1217       (change-root root (current-child)))
1218     (show-all-children t)))
1219
1220 (defun leave-frame ()
1221   "Leave the selected frame - ie make its parent the root frame"
1222   (let ((root (find-root (current-child))))
1223     (unless (or (child-equal-p (root-child root) *root-frame*)
1224                 (child-original-root-p (root-child root)))
1225       (awhen (and root (find-parent-frame (root-child root)))
1226         (when (frame-p it)
1227           (change-root root it)))
1228       (show-all-children))))
1229
1230
1231 ;;; Other actions (select-next-child, select-next-brother...) are in
1232 ;;; clfswm-circulate-mode.lisp
1233
1234
1235
1236 (defun frame-lower-child ()
1237   "Lower the child in the current frame"
1238   (when (frame-p (current-child))
1239     (with-slots (child selected-pos) (current-child)
1240       (unless (>= selected-pos (length child))
1241         (when (nth (1+ selected-pos) child)
1242           (rotatef (nth selected-pos child)
1243                    (nth (1+ selected-pos) child)))
1244         (incf selected-pos)))
1245     (show-all-children)))
1246
1247
1248 (defun frame-raise-child ()
1249   "Raise the child in the current frame"
1250   (when (frame-p (current-child))
1251     (with-slots (child selected-pos) (current-child)
1252       (unless (< selected-pos 1)
1253         (when (nth (1- selected-pos) child)
1254           (rotatef (nth selected-pos child)
1255                    (nth (1- selected-pos) child)))
1256         (decf selected-pos)))
1257     (show-all-children)))
1258
1259
1260 (defun frame-select-next-child ()
1261   "Select the next child in the current frame"
1262   (when (frame-p (current-child))
1263     (with-slots (child selected-pos) (current-child)
1264       (unless (>= selected-pos (length child))
1265         (incf selected-pos)))
1266     (show-all-children)))
1267
1268
1269 (defun frame-select-previous-child ()
1270   "Select the previous child in the current frame"
1271   (when (frame-p (current-child))
1272     (with-slots (child selected-pos) (current-child)
1273       (unless (< selected-pos 1)
1274         (decf selected-pos)))
1275     (show-all-children)))
1276
1277
1278
1279 (defun switch-to-root-frame (&key (show-later nil))
1280   "Switch to the root frame"
1281   (let ((root (find-root (current-child))))
1282     (change-root root (root-original root)))
1283   (unless show-later
1284     (show-all-children t)))
1285
1286 (defun switch-and-select-root-frame (&key (show-later nil))
1287   "Switch and select the root frame"
1288   (let ((root (find-root (current-child))))
1289     (change-root root (root-original root))
1290     (setf (current-child) (root-original root)))
1291   (unless show-later
1292     (show-all-children t)))
1293
1294
1295 (defun toggle-show-root-frame ()
1296   "Show/Hide the root frame"
1297   (setf *show-root-frame-p* (not *show-root-frame-p*))
1298   (show-all-children))
1299
1300
1301
1302 (defun prevent-current-*-equal-child (child)
1303   " Prevent current-root and current-child equal to child"
1304   (if (child-original-root-p child)
1305       nil
1306       (progn
1307         (awhen (child-root-p child)
1308           (change-root it (find-parent-frame child)))
1309         (when (child-equal-p child (current-child))
1310           (setf (current-child) (root-child (find-root child))))
1311         t)))
1312
1313
1314
1315 (defun remove-child-in-frame (child frame)
1316   "Remove the child in frame"
1317   (when (frame-p frame)
1318     (setf (frame-child frame) (child-remove child (frame-child frame)))))
1319
1320 (defun remove-child-in-frames (child root)
1321   "Remove child in the frame root and in all its children"
1322   (with-all-frames (root frame)
1323     (remove-child-in-frame child frame)))
1324
1325
1326 (defun remove-child-in-all-frames (child)
1327   "Remove child in all frames from *root-frame*"
1328   (when (prevent-current-*-equal-child child)
1329     (remove-child-in-frames child *root-frame*)))
1330
1331
1332 (defun delete-child-in-frames (child root)
1333   "Delete child in the frame root and in all its children
1334 Warning:frame window and gc are freeed."
1335   (with-all-frames (root frame)
1336     (remove-child-in-frame child frame)
1337     (unless (find-frame-window (frame-window frame))
1338       (awhen (frame-gc frame) (xlib:free-gcontext it) (setf it nil))
1339       (awhen (frame-window frame) (xlib:destroy-window it) (setf it nil))))
1340   (when (xlib:window-p child)
1341     (netwm-remove-in-client-list child)))
1342
1343
1344 (defun delete-child-in-all-frames (child)
1345   "Delete child in all frames from *root-frame*"
1346   (when (prevent-current-*-equal-child child)
1347     (delete-child-in-frames child *root-frame*)))
1348
1349 (defun delete-child-and-children-in-frames (child root)
1350   "Delete child and its children in the frame root and in all its children
1351 Warning:frame window and gc are freeed."
1352   (when (and (frame-p child) (frame-child child))
1353     (dolist (ch (frame-child child))
1354       (delete-child-and-children-in-frames ch root)))
1355   (delete-child-in-frames child root))
1356
1357 (defun delete-child-and-children-in-all-frames (child &optional (close-methode 'delete-window))
1358   "Delete child and its children in all frames from *root-frame*"
1359   (when (prevent-current-*-equal-child child)
1360     (delete-child-and-children-in-frames child *root-frame*)
1361     (when (xlib:window-p child)
1362       (funcall close-methode child))
1363     (show-all-children)))
1364
1365
1366 (defun clean-windows-in-all-frames ()
1367   "Remove all xlib:windows present in *root-frame* and not in the xlib tree"
1368   (let ((x-tree (xlib:query-tree *root*)))
1369     (with-all-frames (*root-frame* frame)
1370       (dolist (child (frame-child frame))
1371         (when (xlib:window-p child)
1372           (unless (member child x-tree :test #'xlib:window-equal)
1373             (when (prevent-current-*-equal-child child)
1374               (setf (frame-child frame)
1375                     (child-remove child (frame-child frame))))))))))
1376
1377
1378
1379 (defun do-all-frames-nw-hook (window)
1380   "Call nw-hook of each frame."
1381   (catch 'nw-hook-loop
1382     (let ((found nil))
1383       (with-all-frames (*root-frame* frame)
1384         (awhen (frame-nw-hook frame)
1385           (setf found (call-hook it (list frame window)))))
1386       found)))
1387
1388
1389
1390 (defun process-new-window (window)
1391   "When a new window is created (or when we are scanning initial
1392 windows), this function dresses the window up and gets it ready to be
1393 managed."
1394   (setf (xlib:window-event-mask window) *window-events*)
1395   (set-window-state window +normal-state+)
1396   (setf (x-drawable-border-width window) (case (window-type window)
1397                                               (:normal *border-size*)
1398                                               (:maxsize *border-size*)
1399                                               (:transient *border-size*)
1400                                               (t *border-size*)))
1401   (grab-all-buttons window)
1402   (unless (never-managed-window-p window)
1403     (unless (do-all-frames-nw-hook window)
1404       (call-hook *default-nw-hook* (list *root-frame* window))))
1405   (netwm-add-in-client-list window))
1406
1407
1408
1409
1410 (defun with-all-mapped-windows (screen fun)
1411   (let ((all-windows (get-all-windows)))
1412     (dolist (win (xlib:query-tree (xlib:screen-root screen)))
1413       (unless (child-member win all-windows)
1414         (let ((map-state (xlib:window-map-state win))
1415               (wm-state (window-state win)))
1416           (unless (or (eql (xlib:window-override-redirect win) :on)
1417                       (eql win *no-focus-window*)
1418                       (is-notify-window-p win))
1419             (when (or (eql map-state :viewable)
1420                       (eql wm-state +iconic-state+))
1421               (funcall fun win))))))))
1422
1423 (defun store-root-background ()
1424   (with-all-mapped-windows *screen* #'hide-window)
1425   (setf *background-image* (xlib:create-pixmap :width (xlib:screen-width *screen*)
1426                                                :height (xlib:screen-height *screen*)
1427                                                :depth (xlib:screen-root-depth *screen*)
1428                                                :drawable *root*)
1429         *background-gc* (xlib:create-gcontext :drawable *background-image*
1430                                               :foreground (get-color *frame-foreground*)
1431                                               :background (get-color *frame-background*)
1432                                               :font *default-font*
1433                                               :line-style :solid))
1434   (xlib:copy-area *root* *background-gc*
1435                   0 0 (xlib:screen-width *screen*) (xlib:screen-height *screen*)
1436                   *background-image* 0 0)
1437   (with-all-mapped-windows *screen* #'unhide-window))
1438
1439
1440
1441
1442 (defun hide-existing-windows (screen)
1443   "Hide all existing windows in screen"
1444   (dolist (win (xlib:query-tree (xlib:screen-root screen)))
1445     (hide-window win)))
1446
1447
1448
1449 (defun process-existing-windows (screen)
1450   "Windows present when clfswm starts up must be absorbed by clfswm."
1451   (setf *in-process-existing-windows* t)
1452   (let ((id-list nil)
1453         (all-windows (get-all-windows)))
1454     (dolist (win (xlib:query-tree (xlib:screen-root screen)))
1455       (unless (child-member win all-windows)
1456         (let ((map-state (xlib:window-map-state win))
1457               (wm-state (window-state win)))
1458           (unless (or (eql (xlib:window-override-redirect win) :on)
1459                       (eql win *no-focus-window*)
1460                       (is-notify-window-p win))
1461             (when (or (eql map-state :viewable)
1462                       (eql wm-state +iconic-state+))
1463               (format t "Processing ~S: type=~A ~S~%" (xlib:wm-name win) (window-type win) win)
1464               (unhide-window win)
1465               (process-new-window win)
1466               (map-window win)
1467               (raise-window win)
1468               (pushnew (xlib:window-id win) id-list))))))
1469     (netwm-set-client-list id-list))
1470   (setf *in-process-existing-windows* nil))
1471
1472
1473 ;;; Child order manipulation functions
1474 (defun put-child-on-top (child parent)
1475   "Put the child on top of its parent children"
1476   (when (frame-p parent)
1477     (setf (frame-child parent) (cons child (child-remove child (frame-child parent)))
1478           (frame-selected-pos parent) 0)))
1479
1480 (defun put-child-on-bottom (child parent)
1481   "Put the child at the bottom of its parent children"
1482   (when (frame-p parent)
1483     (setf (frame-child parent) (append (child-remove child (frame-child parent)) (list child))
1484           (frame-selected-pos parent) 0)))
1485
1486