forked from ch11ng/exwm
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathexwm-cm.el
1778 lines (1701 loc) · 74.5 KB
/
exwm-cm.el
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;;; exwm-cm.el --- Compositing Manager for EXWM -*- lexical-binding: t -*-
;; Copyright (C) 2016 Free Software Foundation, Inc.
;; Author: Chris Feng <chris.w.feng@gmail.com>
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This module provides a compositing manager (CM) for EXWM, mainly to
;; enable transparency support.
;; Usage:
;; Add following lines to .emacs and modify accordingly:
;;
;; (require 'exwm-cm)
;; ;; Make all Emacs frames opaque.
;; (setq window-system-default-frame-alist '((x . ((alpha . 100)))))
;; ;; Assign everything else a 80% opacity.
;; (setq exwm-cm-opacity 80)
;; (exwm-cm-enable)
;;
;; With the last line this CM would be started with EXWM. You can also
;; start and stop this CM with `exwm-cm-start' and `exwm-cm-stop' at any
;; time.
;; Theory:
;; Due to its unique way of managing X windows, EXWM can not work with
;; any existing CMs. And this CM, designed specifically for EXWM,
;; probably won't work well with other WMs, too. The theories behind
;; all CMs are basically the same, some peculiarities of this CM are
;; summarized as the following sections.
;; + Data structures:
;; This CM organizes all X windows concerned with compositing in a
;; tree hierarchy. Below is a stripped-down version of such tree with
;; each node representing an X window (except the root placeholder),
;;
;; (nil
;; (root-xwin
;; (unmanaged-xwin)
;; (workspace-container
;; (unmanaged-xwin)
;; (xwin-container
;; (xwin)
;; (floating-frame-container
;; (floating-frame)))
;; (xwin-container
;; (xwin))
;; (workspace-frame-container
;; (workspace-frame)))
;; (minibuffer-frame-container
;; (minibuffer-frame))))
;;
;; where
;; - nodes with non-nil CDRs are containers,
;; - siblings are arranged in stacking order (top to bottom),
;; - and "managed" and "unmanaged" are in WM's sense.
;;
;; During a painting process, the tree is traversed starting from the
;; root node, with each leaf visited and painted. The attributes of
;; each X window (position, size, etc) are recorded as an instance of
;; class `exwm-cm--attr'. Such instance is associated with the
;; corresponding X window ID through a hash table. The instance also
;; contains a slot pointing to a subtree of the aforementioned tree,
;; with the root node being the parent of the X window. This makes it
;; convenient to carry out operations such as insertion, deletion,
;; restacking and reparenting.
;; + Compositing strategies:
;; - Only leaves are painted, since branches (containers) are always
;; invisible.
;; - The root X window is painted separately.
;; - Siblings below a workspace frame container are not painted; they
;; are considered hidden.
;; - Only the top workspace in one (RandR) output is painted.
;; - Workspace frames and floating frames are always clipped by its
;; Emacs windows displaying `exwm-mode' buffers, therefore they
;; don't block X windows.
;; Reference:
;; + xcompmgr (http://cgit.freedesktop.org/xorg/app/xcompmgr/)
;;; Code:
(require 'xcb-composite)
(require 'xcb-damage)
(require 'xcb-ewmh)
(require 'xcb-icccm)
(require 'xcb-renderutil)
(require 'xcb-shape)
(require 'exwm-core)
(require 'exwm-workspace)
(require 'exwm-manage)
(defconst exwm-cm--OPAQUE (float #xFFFFFFFF)
"The opacity value of the _NET_WM_WINDOW_OPACITY property.")
(defvar exwm-cm--_NET_WM_WINDOW_OPACITY nil "The _NET_WM_WINDOW_OPACITY atom.")
(defvar exwm-cm-opacity nil
"The default value of opacity when it's not explicitly specified.
The value should be a floating number between 0 (transparent) and 100
(opaque). A value of nil also means opaque.")
(defvar exwm-cm--hash nil
"The hash table associating X window IDs to their attributes.")
(defvar exwm-cm--conn nil "The X connection used by the CM.")
(defvar exwm-cm--buffer nil "The rendering buffer.")
(defvar exwm-cm--depth nil "Default depth.")
(defvar exwm-cm--clip-changed t "Whether clip has changed.")
(defvar exwm-cm--damages nil "All damaged regions.")
(defvar exwm-cm--expose-rectangles nil
"Used by Expose event handler to collect exposed regions.")
(defvar exwm-cm--background nil "The background (render) picture.")
(defvar exwm-cm--background-atom-names '("_XROOTPMAP_ID" "_XSETROOT_ID")
"Property names for background pixmap.")
(defvar exwm-cm--background-atoms nil "Interned atoms of the property names.")
(defun exwm-cm--get-opacity (xwin)
"Get the opacity of X window XWIN.
The value is between 0 (fully transparent) to #xFFFFFFFF (opaque)."
(let ((reply (xcb:+request-unchecked+reply exwm-cm--conn
(make-instance 'xcb:icccm:-GetProperty-single
:window xwin
:property exwm-cm--_NET_WM_WINDOW_OPACITY
:type xcb:Atom:CARDINAL))))
;; The X window might have already been destroyed.
(when reply
(slot-value reply 'value))))
(defun exwm-cm-set-opacity (xwin opacity)
"Set the opacity of X window XWIN to OPACITY.
The value is between 0 (fully transparent) to 100 (opaque).
If called interactively, XWIN would be the selected X window."
(interactive
(list (exwm--buffer->id (window-buffer))
(read-number "Opacity (0 ~ 100): " 100)))
(when (and xwin
(<= 0 opacity 100))
(setq opacity (round (* exwm-cm--OPAQUE (/ opacity 100.0))))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:icccm:-ChangeProperty-single
:window xwin
:property exwm-cm--_NET_WM_WINDOW_OPACITY
:type xcb:Atom:CARDINAL
:data opacity))
(xcb:flush exwm-cm--conn)))
(defclass exwm-cm--attr ()
(
;; The entity associated with this X window; can be a frame, a buffer
;; or nil.
(entity :initform nil)
;; The subtree of which the root node is the parent of this X window.
(tree :initarg :tree)
;; Geometry.
(x :initarg :x)
(y :initarg :y)
(width :initarg :width)
(height :initarg :height)
;; X window attributes.
(visual :initarg :visual)
(class :initarg :class)
;; The opacity of this X window; can be 0 ~ #xFFFE or nil.
(opacity :initform nil)
;; Determine whether this X window should be treated as opaque or
;; transparent; can be nil (opaque), 'argb or 'transparent (both
;; should be treated as transparent).
(mode :initform nil)
;; The (render) picture of this X window.
(picture :initform nil)
;; The 1x1 (render) picture with only alpha channel.
(alpha-picture :initform nil)
;; Whether this X window is ever damaged.
(damaged :initform nil)
;; The damage object monitoring this X window.
(damage :initarg :damage)
;; The bounding region of this X window (can be irregular).
(border-size :initform nil)
;; The rectangular bounding region of this X window.
(extents :initform nil)
;; The region require repainting (used for transparent X windows).
(border-clip :initform nil)
;; Shape-related parameters.
(shaped :initform nil)
(shape-x :initarg :shape-x)
(shape-y :initarg :shape-y)
(shape-width :initarg :shape-width)
(shape-height :initarg :shape-height))
:documentation "Attributes of an X window.")
(defsubst exwm-cm--xwin->attr (xwin)
"Get the attributes of X window XWIN."
(gethash xwin exwm-cm--hash))
(defsubst exwm-cm--get-tree (xwin)
"Get the subtree of the parent of X window XWIN."
(slot-value (exwm-cm--xwin->attr xwin) 'tree))
(defsubst exwm-cm--set-tree (xwin tree)
"Reparent X window XWIN to another tree TREE."
(setf (slot-value (exwm-cm--xwin->attr xwin) 'tree) tree))
(defsubst exwm-cm--get-parent (xwin)
"Get the parent of X window XWIN."
(car (exwm-cm--get-tree xwin)))
(defsubst exwm-cm--get-siblings (xwin)
"Get a list of subtrees of the siblings of X window XWIN"
(cdr (exwm-cm--get-tree xwin)))
(defsubst exwm-cm--get-subtree (xwin)
"Get the subtree of which the X window XWIN is the root node."
(assq xwin (exwm-cm--get-siblings xwin)))
(defun exwm-cm--create-attr (xwin tree x y width height)
"Create attributes for X window XWIN.
TREE is the subtree and the parent of this X window is the tree's root.
X and Y specify the position with regard to the root X window. WIDTH
and HEIGHT specify the size of the X window."
(let (visual class map-state damage attr)
(cond
((= xwin exwm--root)
;; Redirect all subwindows to off-screen storage.
(xcb:+request exwm-cm--conn
(make-instance 'xcb:composite:RedirectSubwindows
:window exwm--root
:update xcb:composite:Redirect:Manual))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:ChangeWindowAttributes
:window xwin
:value-mask xcb:CW:EventMask
:event-mask (logior xcb:EventMask:StructureNotify
xcb:EventMask:PropertyChange
xcb:EventMask:SubstructureNotify
xcb:EventMask:Exposure)))
(setq visual (slot-value (car (slot-value (xcb:get-setup exwm-cm--conn)
'roots))
'root-visual)
class xcb:WindowClass:InputOutput))
((eq xwin exwm-manage--desktop)
;; Ignore any desktop; paint the background ourselves.
(setq visual 0
class xcb:WindowClass:InputOnly
map-state xcb:MapState:Unmapped))
(t
;; Redirect this window to off-screen storage, or the content
;; would be mirrored to its parent.
(xcb:+request exwm-cm--conn
(make-instance 'xcb:composite:RedirectWindow
:window xwin
:update xcb:composite:Redirect:Manual))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:ChangeWindowAttributes
:window xwin
:value-mask xcb:CW:EventMask
:event-mask (logior xcb:EventMask:StructureNotify
xcb:EventMask:PropertyChange)))
(let ((reply (xcb:+request-unchecked+reply exwm-cm--conn
(make-instance 'xcb:GetWindowAttributes
:window xwin))))
(if reply
(with-slots ((visual* visual)
(class* class)
(map-state* map-state))
reply
(setq visual visual*
class class*
map-state map-state*))
;; The X window has been destroyed actually. It'll get
;; removed by a DestroyNotify event.
(setq visual 0
class xcb:WindowClass:InputOnly
map-state xcb:MapState:Unmapped)))
(when (/= class xcb:WindowClass:InputOnly)
(setq damage (xcb:generate-id exwm-cm--conn))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:damage:Create
:damage damage
:drawable xwin
:level xcb:damage:ReportLevel:NonEmpty))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:shape:SelectInput
:destination-window xwin
:enable 1)))))
(setq attr (make-instance 'exwm-cm--attr
:tree tree
:x x
:y y
:width width
:height height
:visual visual
:class class
:damage damage
:shape-x x
:shape-y y
:shape-width width
:shape-height height))
(puthash xwin attr exwm-cm--hash)
(unless (or (= xwin exwm--root)
(= class xcb:WindowClass:InputOnly))
(exwm-cm--update-opacity xwin)
(when (= map-state xcb:MapState:Viewable)
(exwm-cm--map-xwin xwin t)))))
(defun exwm-cm--update-geometry (xwin x y width height &optional above-sibling)
"Update the geometry of X window XWIN.
X, Y, WIDTH and HEIGHT have the same meaning with the arguments used in
`exwm-cm--create-attr'. If ABOVE-SIBLING is non-nil, restack XWIN with
`exwm-cm--restack.'"
(with-slots ((x* x)
(y* y)
(width* width)
(height* height)
extents shaped shape-x shape-y shape-width shape-height)
(exwm-cm--xwin->attr xwin)
(let ((stack-changed (and above-sibling
(exwm-cm--restack xwin above-sibling)))
(position-changed (or (and x (/= x x*))
(and y (/= y y*))))
(size-changed (or (and width (/= width width*))
(and height (/= height height*))))
subtree dx dy damage new-extents)
(when position-changed
(setq subtree (exwm-cm--get-subtree xwin)
dx (- x x*)
dy (- y y*))
(dolist (node (cdr subtree))
(with-slots (x y) (exwm-cm--xwin->attr (car node))
(exwm--log "(CM) #x%X(*): @%+d%+d => @%+d%+d"
(car node) x y (+ x dx) (+ y dy))
(exwm-cm--update-geometry (car node) (+ x dx) (+ y dy) nil nil)))
(exwm--log "(CM) #x%X: @%+d%+d => @%+d%+d" xwin x* y* x y)
(setf x* x
y* y)
(cl-incf shape-x dx)
(cl-incf shape-y dy))
(when size-changed
(setf width* width
height* height)
(unless shaped
(setf shape-width width
shape-height height)))
(when (or stack-changed position-changed size-changed)
(setq damage (xcb:generate-id exwm-cm--conn)
new-extents (xcb:generate-id exwm-cm--conn))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:CreateRegion
:region damage
:rectangles nil))
(when extents
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:CopyRegion
:source extents
:destination damage)))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:CreateRegion
:region new-extents
:rectangles (list (make-instance 'xcb:RECTANGLE
:x x*
:y y*
:width width*
:height height*))))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:UnionRegion
:source1 damage
:source2 new-extents
:destination damage))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:DestroyRegion
:region new-extents))
(exwm-cm--add-damage damage)))))
(defun exwm-cm--update-opacity (xwin)
"Update the opacity of X window XWIN."
(with-slots (visual opacity mode alpha-picture extents)
(exwm-cm--xwin->attr xwin)
(let (format forminfo)
;; Get the opacity.
(setf opacity (exwm-cm--get-opacity xwin))
(if opacity
(setf opacity (round (* #xFFFF (/ opacity exwm-cm--OPAQUE))))
(when (numberp exwm-cm-opacity)
(setf opacity (round (* #xFFFF (/ exwm-cm-opacity 100.0))))))
(when (and opacity
(>= opacity #xFFFF))
(setf opacity nil))
;; Determine the mode of the X window.
(setq format (xcb:renderutil:find-visual-format
(xcb:renderutil:query-formats exwm-cm--conn) visual))
(when format
(catch 'break
(dolist (f (slot-value (xcb:renderutil:query-formats exwm-cm--conn)
'formats))
(when (eq format (slot-value f 'id))
(setq forminfo f)
(throw 'break nil)))))
(if (and forminfo
(eq xcb:render:PictType:Direct (slot-value forminfo 'type))
(/= 0 (slot-value (slot-value forminfo 'direct) 'alpha-mask)))
(setf mode 'argb)
(if opacity
(setf mode 'transparent)
(setf mode nil)))
;; Clear resources.
(when alpha-picture
(xcb:+request exwm-cm--conn
(make-instance 'xcb:render:FreePicture
:picture alpha-picture))
(setf alpha-picture nil))
(when extents
(let ((damage (xcb:generate-id exwm-cm--conn)))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:CreateRegion
:region damage
:rectangles nil))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:CopyRegion
:source extents
:destination damage))
(exwm-cm--add-damage damage))))))
(defsubst exwm-cm--push (newelt place)
"Similar to `push' but preserve the reference."
(let ((oldelt (car place)))
(setf (car place) newelt
(cdr place) (cons oldelt (cdr place)))))
(defsubst exwm-cm--delq (elt list)
"Similar to `delq' but preserve the reference."
(if (eq elt (car list))
(setf (car list) (cadr list)
(cdr list) (cddr list))
(delq elt list)))
(defsubst exwm-cm--assq-delete-all (key alist)
"Similar to `assq-delete-all' but preserve the reference."
(when (eq key (caar alist))
(setf (car alist) (cadr alist)
(cdr alist) (cddr alist)))
(assq-delete-all key alist))
(defun exwm-cm--create-tree (&optional xwin)
"Create a tree with XWIN being the root node."
(let (tree0 x0 y0 children containers)
;; Get the position of this branch.
(if xwin
(with-slots (tree x y) (exwm-cm--xwin->attr xwin)
(setq tree0 (assq xwin (cdr tree))
x0 x
y0 y))
(setq tree0 (list nil)
x0 0
y0 0))
;; Get children nodes.
(if (null xwin)
(setq children (list exwm--root))
(setq children
(reverse (slot-value (xcb:+request-unchecked+reply exwm-cm--conn
(make-instance 'xcb:QueryTree
:window xwin))
'children))))
;; Get container nodes.
;; Floating frame containers are determined dynamically.
(cond
((null xwin)
(setq containers `((,exwm--root))))
((= xwin exwm--root)
;; Workspace containers and the minibuffer frame container.
(setq containers (mapcar (lambda (f)
(cons (frame-parameter f 'exwm-workspace) f))
exwm-workspace--list))
(when (exwm-workspace--minibuffer-own-frame-p)
(push (cons
(frame-parameter exwm-workspace--minibuffer 'exwm-container)
exwm-workspace--minibuffer)
containers)))
;; No containers in the minibuffer container.
((and (exwm-workspace--minibuffer-own-frame-p)
(= xwin
(frame-parameter exwm-workspace--minibuffer 'exwm-container))))
((= exwm--root
(slot-value (xcb:+request-unchecked+reply exwm-cm--conn
(make-instance 'xcb:QueryTree
:window xwin))
'parent))
;; Managed X window containers and the workspace frame container.
(let (frame)
(catch 'break
(dolist (f exwm-workspace--list)
(when (= xwin (frame-parameter f 'exwm-workspace))
(setq frame f)
(throw 'break nil))))
(cl-assert frame)
(dolist (pair exwm--id-buffer-alist)
(with-current-buffer (cdr pair)
(when (eq frame exwm--frame)
(push (cons exwm--container (cdr pair)) containers))))
(push (cons (frame-parameter frame 'exwm-container) frame)
containers))))
;; Create subnodes.
(dolist (xwin children)
;; Create attributes.
(let ((reply (xcb:+request-unchecked+reply exwm-cm--conn
(make-instance 'xcb:GetGeometry
:drawable xwin))))
;; It's possible the X window has been destroyed.
(if (null reply)
(setq xwin nil)
(when reply
(with-slots (x y width height) reply
(exwm-cm--create-attr xwin tree0
(+ x x0) (+ y y0) width height))
;; Insert the node.
(setcdr (or (last (cdr tree0)) tree0) `((,xwin))))))
(cond
((null xwin))
((assq xwin containers)
;; A branch. Repeat the process.
(exwm-cm--create-tree xwin)
(let ((entity (cdr (assq xwin containers)))
entity-xwin)
(when entity
(setq entity-xwin (if (framep entity)
(frame-parameter entity 'exwm-outer-id)
(buffer-local-value 'exwm--id entity)))
(setf (slot-value (exwm-cm--xwin->attr entity-xwin) 'entity) entity
(slot-value (exwm-cm--xwin->attr xwin) 'entity) entity)
(let ((tmp (exwm-cm--get-parent entity-xwin)))
(when (/= xwin tmp)
;; Workspace frame container.
(setf (slot-value (exwm-cm--xwin->attr tmp) 'entity)
entity))))))
((and (null containers)
(exwm--id->buffer xwin))
;; A leaf but a floating frame container might follow.
(with-current-buffer (exwm--id->buffer xwin)
(when exwm--floating-frame
(push (cons (frame-parameter exwm--floating-frame 'exwm-container)
exwm--floating-frame)
containers))))))))
(defun exwm-cm--restack (xwin above-sibling)
"Restack X window XWIN so as to it's exactly on top of ABOVE-SIBLING."
(let ((siblings (exwm-cm--get-siblings xwin))
node tmp)
(unless (= 1 (length siblings))
(setq node (assq xwin siblings))
(if (= above-sibling xcb:Window:None)
;; Put at bottom.
(unless (eq node (cdr (last siblings)))
(exwm-cm--delq node siblings)
(setcdr (last siblings) (list node))
;; Set the return value.
t)
;; Insert before the sibling.
(setq tmp siblings)
(while (and tmp
(/= above-sibling (caar tmp)))
(setq tmp (cdr tmp)))
(cl-assert tmp)
;; Check if it's already at the requested position.
(unless (eq tmp (cdr siblings))
(exwm-cm--delq node siblings)
(exwm-cm--push node tmp)
;; Set the return value.
t)))))
(declare-function exwm-layout--iconic-state-p "exwm-layout.el" (&optional id))
(defun exwm-cm--paint-tree (tree region &optional force-opaque frame-clip)
"Paint the tree TREE, with REGION specifying the clipping region.
If FORCE-OPAQUE is non-nil, all X windows painted in this tree is
assumed opaque. FRAME-CLIP specifies the region should be clipped when
painting a frame."
(unless tree
(setq tree (exwm-cm--get-tree exwm--root)))
(let ((root (car tree))
xwin attr entity current output outputs queue rectangles)
;; Paint subtrees.
(catch 'break
(dolist (subtree (cdr tree))
(setq xwin (car subtree)
attr (exwm-cm--xwin->attr xwin))
(cond
;; Skip destroyed X windows.
((null attr))
;; Skip InputOnly X windows.
((= xcb:WindowClass:InputOnly
(slot-value attr 'class)))
((and (eq root exwm--root)
(frame-live-p (setq entity (slot-value attr 'entity)))
(if (eq entity exwm-workspace--minibuffer)
;; Skip the minibuffer if the current workspace is
;; already painted.
(unless (exwm-workspace--minibuffer-attached-p)
current)
;; Skip lower workspaces on visited RandR output.
;; If RandR is not enabled, it'll just paint the first.
(memq (setq output (frame-parameter entity
'exwm-randr-output))
outputs))))
((cdr subtree)
;; Paint the subtree.
(setq entity (slot-value attr 'entity))
(let (fullscreen clip)
(cond
((buffer-live-p entity)
(with-current-buffer entity
;; Collect frame clip but exclude fullscreen and
;; floating X windows.
(setq fullscreen (memq xcb:Atom:_NET_WM_STATE_FULLSCREEN
exwm--ewmh-state))
(when (and (null fullscreen)
;; In case it's hidden.
(null (exwm-layout--iconic-state-p))
;; The buffer of a floating X windows is not
;; displayed on a workspace frame.
(null exwm--floating-frame)
;; Opaque regions are always clipped.
(slot-value (exwm-cm--xwin->attr xwin) 'mode))
;; Prepare rectangles to clip the workspace frame.
(with-slots (x y width height) (exwm-cm--xwin->attr xwin)
(push (make-instance 'xcb:RECTANGLE
:x x
:y y
:width width
:height height)
rectangles)))))
((and rectangles
(frame-live-p entity))
;; Prepare region to clip the frame.
(setq clip (xcb:generate-id exwm-cm--conn))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:CreateRegion
:region clip
:rectangles rectangles))))
(setq queue
(nconc (exwm-cm--paint-tree subtree region fullscreen clip)
queue))
(when fullscreen
;; Fullscreen X windows are always opaque thus occludes
;; anything in this workspace.
(throw 'break 'fullscreen))
(when clip
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:DestroyRegion
:region clip))))
(if (not (eq root exwm--root))
;; Avoid painting any siblings below the workspace frame
;; container.
(when (exwm-workspace--workspace-p (slot-value attr 'entity))
(throw 'break nil))
;; Save some status.
(when (and (frame-live-p entity)
(not (eq entity exwm-workspace--minibuffer)))
(push output outputs)
(when (eq entity exwm-workspace--current)
(setq current t)))))
((and force-opaque
(slot-value attr 'damaged))
(exwm-cm--paint-opaque xwin region t))
((slot-value attr 'damaged)
;; Paint damaged leaf.
(setq entity (slot-value attr 'entity))
(when (slot-value attr 'mode)
(push xwin queue))
(cond
((buffer-live-p entity)
(with-current-buffer entity
(cl-assert (= xwin exwm--id))
(when (and exwm--floating-frame
;; Opaque regions are always clipped.
(slot-value (exwm-cm--xwin->attr xwin) 'mode))
;; Prepare rectangles to clip the floating frame.
(with-slots (x y width height) (exwm-cm--xwin->attr xwin)
(push (make-instance 'xcb:RECTANGLE
:x x
:y y
:width width
:height height)
rectangles)))))
((and frame-clip
(frame-live-p entity))
;; Apply frame clip.
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:IntersectRegion
:source1 region
:source2 frame-clip
:destination frame-clip))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:SubtractRegion
:source1 region
:source2 frame-clip
:destination region))))
(exwm-cm--paint-opaque xwin region)
(when (and frame-clip
(frame-live-p entity))
;; Restore frame clip.
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:UnionRegion
:source1 region
:source2 frame-clip
:destination region)))))))
;; Return the queue.
queue))
(defun exwm-cm--paint-opaque (xwin region &optional force-opaque)
"Paint an X window XWIN clipped by region REGION if XWIN is opaque.
Also update the attributes of XWIN and clip the region."
(with-slots (x y width height visual mode picture
border-size extents border-clip)
(exwm-cm--xwin->attr xwin)
;; Prepare the X window picture.
(unless picture
(setf picture (xcb:generate-id exwm-cm--conn))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:render:CreatePicture
:pid picture
:drawable xwin
:format (xcb:renderutil:find-visual-format
(xcb:renderutil:query-formats exwm-cm--conn)
visual)
:value-mask 0)))
;; Clear cached resources if clip changed.
(when exwm-cm--clip-changed
(when border-size
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:DestroyRegion
:region border-size))
(setf border-size nil))
(when extents
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:DestroyRegion
:region extents))
(setf extents nil))
(when border-clip
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:DestroyRegion
:region border-clip))
(setf border-clip nil)))
;; Retrieve the border.
(unless border-size
(setf border-size (xcb:generate-id exwm-cm--conn))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:CreateRegionFromWindow
:region border-size
:window xwin
:kind xcb:shape:SK:Bounding))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:TranslateRegion
:region border-size
:dx x
:dy y)))
;; Retrieve the extents.
(unless extents
(setf extents (xcb:generate-id exwm-cm--conn))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:CreateRegion
:region extents
:rectangles (list (make-instance 'xcb:RECTANGLE
:x x
:y y
:width width
:height height)))))
(cond
((and mode
(null force-opaque))
;; Calculate clipped border for the transparent X window.
(unless border-clip
(setf border-clip (xcb:generate-id exwm-cm--conn))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:CreateRegion
:region border-clip
:rectangles nil))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:CopyRegion
:source region
:destination border-clip))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:IntersectRegion
:source1 border-clip
:source2 border-size
:destination border-clip))))
(t
;; Clip & render for the opaque X window.
;; Set the clip region for the rendering buffer.
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:SetPictureClipRegion
:picture exwm-cm--buffer
:region region
:x-origin 0
:y-origin 0))
;; Clip the region with border.
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:SubtractRegion
:source1 region
:source2 border-size
:destination region))
;; Render the picture to the buffer.
(xcb:+request exwm-cm--conn
(make-instance 'xcb:render:Composite
:op xcb:render:PictOp:Src
:src picture
:mask xcb:render:Picture:None
:dst exwm-cm--buffer
:src-x 0
:src-y 0
:mask-x 0
:mask-y 0
:dst-x x
:dst-y y
:width width
:height height))))))
(defun exwm-cm--paint-transparent (xwin)
"Paint a transparent X window XWIN."
(with-slots (x y width height opacity picture alpha-picture border-clip)
(exwm-cm--xwin->attr xwin)
;; Prepare the alpha picture for transparent X windows.
(when (and opacity (null alpha-picture))
(setf alpha-picture (xcb:generate-id exwm-cm--conn))
(let ((pixmap (xcb:generate-id exwm-cm--conn)))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:CreatePixmap
:depth 8
:pid pixmap
:drawable exwm--root
:width 1
:height 1))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:render:CreatePicture
:pid alpha-picture
:drawable pixmap
:format (xcb:renderutil:find-standard
(xcb:renderutil:query-formats
exwm-cm--conn)
xcb:renderutil:PICT_STANDARD:A_8)
:value-mask xcb:render:CP:Repeat
:repeat 1))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:render:FillRectangles
:op xcb:render:PictOp:Src
:dst alpha-picture
:color (make-instance 'xcb:render:COLOR
:red 0
:green 0
:blue 0
:alpha opacity)
:rects (list (make-instance 'xcb:RECTANGLE
:x 0
:y 0
:width 1
:height 1))))))
;; Set the clip region for the rendering buffer.
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:SetPictureClipRegion
:picture exwm-cm--buffer
:region border-clip
:x-origin 0
:y-origin 0))
;; Render the picture to the buffer.
(xcb:+request exwm-cm--conn
(make-instance 'xcb:render:Composite
:op xcb:render:PictOp:Over
:src picture
:mask (or alpha-picture xcb:render:Picture:None)
:dst exwm-cm--buffer
:src-x 0
:src-y 0
:mask-x 0
:mask-y 0
:dst-x x
:dst-y y
:width width
:height height))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:DestroyRegion
:region border-clip))
(setf border-clip nil)))
(defun exwm-cm--paint (&optional region)
"Paint the whole tree within clipping region REGION.
If REGION is omitted, `exwm-cm--damages' is assumed. If it's t, paint
the whole screen."
;; Prepare the clipping region.
(cond
((null region)
(when exwm-cm--damages
(setq region exwm-cm--damages)))
((eq region t)
(with-slots (width height) (exwm-cm--xwin->attr exwm--root)
(let ((rect (make-instance 'xcb:RECTANGLE
:x 0
:y 0
:width width
:height height)))
(setq region (xcb:generate-id exwm-cm--conn))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:CreateRegion
:region region
:rectangles (list rect)))))))
(when region
;; Prepare the rendering buffer.
(unless exwm-cm--buffer
(let ((pixmap (xcb:generate-id exwm-cm--conn))
(picture (xcb:generate-id exwm-cm--conn)))
(setq exwm-cm--buffer picture)
(with-slots (width height visual) (exwm-cm--xwin->attr exwm--root)
(xcb:+request exwm-cm--conn
(make-instance 'xcb:CreatePixmap
:depth exwm-cm--depth
:pid pixmap
:drawable exwm--root
:width width
:height height))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:render:CreatePicture
:pid picture
:drawable pixmap
:format (xcb:renderutil:find-visual-format
(xcb:renderutil:query-formats
exwm-cm--conn)
visual)
:value-mask 0)))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:FreePixmap
:pixmap pixmap))))
(let (queue)
;; Paint opaque X windows and update clipping region.
(setq queue (exwm-cm--paint-tree nil region))
;; Paint the background.
(exwm-cm--paint-background region)
;; Paint transparent X windows.
(while queue
(exwm-cm--paint-transparent (pop queue))))
;; Submit changes.
(with-slots (width height picture) (exwm-cm--xwin->attr exwm--root)
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:SetPictureClipRegion
:picture exwm-cm--buffer
:region xcb:xfixes:Region:None
:x-origin 0
:y-origin 0))
(xcb:+request exwm-cm--conn
(make-instance 'xcb:render:Composite
:op xcb:render:PictOp:Src
:src exwm-cm--buffer
:mask xcb:render:Picture:None
:dst picture
:src-x 0
:src-y 0
:mask-x 0
:mask-y 0
:dst-x 0
:dst-y 0
:width width
:height height)))
;; Cleanup.
(xcb:+request exwm-cm--conn
(make-instance 'xcb:xfixes:DestroyRegion
:region region))
(when (eq region exwm-cm--damages)
(setq exwm-cm--damages nil))
(setq exwm-cm--clip-changed nil)
(xcb:flush exwm-cm--conn)))
(defun exwm-cm--paint-background (region)
"Paint the background."
(unless exwm-cm--background
(setq exwm-cm--background (xcb:generate-id exwm-cm--conn))
(let (pixmap exist)
(catch 'break
(dolist (atom exwm-cm--background-atoms)
(with-slots (~lsb format value-len value)