-
Notifications
You must be signed in to change notification settings - Fork 0
/
widgets.lisp
993 lines (863 loc) · 40.2 KB
/
widgets.lisp
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
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: widgets.lisp,v 1.60 2010-04-02 09:57:53 ihatchondo Exp $
;;;
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
;;; Copyright (C) 2000 Julien BONINFANTE, Aymeric LACORTE, Jocelyn FRECHOT
;;; contact : [email protected]
;;;
;;; This program 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.
;;;
;;; This program 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 this program; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
(in-package :ECLIPSE-INTERNALS)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; General comment
;;;; We use the term "master" to designate the container of the decoration
;;;; Every were you'll find master it will represent the decoration object
;;;; and each time you'll see master-win, it represent the window of the
;;;; master object. (defined in the file wm.lisp)
;;;; To represent the virtual-screens we use the term VSCREEN...
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Base Widget
(defclass base-widget ()
((window :initarg :window :reader widget-window)
(gcontext :initarg :gcontext :reader widget-gcontext :allocation :class)))
(defgeneric remove-widget (widget)
(:method (widget) nil)
(:documentation "Remove widget from internal cache."))
(defgeneric close-widget (widget)
(:method (widget) nil)
(:documentation "Close an application according to the ICCCM protocol."))
(defgeneric focus-widget (widget timestamp)
(:method (widget timestamp) nil))
(defgeneric focused-p (widget)
(:documentation "Return T if the given widget has the focus."))
(defgeneric put-on-top (widget)
(:documentation "sets the widget stacking order on top of the others."))
(defgeneric put-on-bottom (widget)
(:documentation
"Sets the widget stacking order on bottom of the others \(except if any
widget with :_net_wm_type_desktop is present and widget is or an
application or a decoration\)."))
(defgeneric maximize (widget code &key fill-p)
(:method (widget code &key fill-p)
(declare (ignorable widget code fill-p)))
(:documentation "Maximize/Unmaximize a widget. If already maximized then
restores the sizes of the widget before its maximization. During
maximization the widget will be enlarged to cover the whole screen except
any existing panels (e.g applications with the :_net_wm_window_type_dock
atom present in there _net_wm_window_type property.
- widget (base-widget): the widget to (un)maximize.
- code (integer 1 3):
-- 1 operates on width and height.
-- 2 operates on height.
-- 3 operates on width.
- :fill-p (boolean): If NIL, cover the whole screen (except dock type
applications). If T, finds the first region of the screen that does
not overlap applications not already overlapped by the widget."))
(defgeneric shade (widget)
(:documentation "shade/un-shade an application that is decorated."))
(defgeneric shaded-p (widget)
(:method (widget) nil)
(:documentation
"Returns true if the widget is shaded in the sens of the extended window
manager specification."))
(defgeneric widget-position-fix-p (widget)
(:method (widget) nil)
(:documentation "Returns T if one of the state :win_state_fixed_position
:_net_wm_state_sticky is set for the widget."))
(defgeneric repaint (widget theme focus)
(:method (widget theme focus) nil)
(:documentation
"This method is dedicated to widget repaint such as every buttons, icons,
edges ...
It is specialized on widget type, frame-style theme and a boolean that
indicate if the corresponding toplevel (type decoration) is or not focused.
Except for standard expose events, the repaint dispatching on focus change
will be perform according to parts-to-redraw-on-focus list given in
define-theme."))
(defmethod initialize-instance :after ((widget base-widget) &rest rest)
(declare (ignore rest))
(save-widget (widget-window widget) widget))
(defmethod remove-widget ((widget base-widget))
(clear-widget (widget-window widget)))
(defmethod put-on-top ((widget base-widget))
(setf (xlib:window-priority (widget-window widget)) :above))
(defmethod put-on-bottom ((widget base-widget))
(setf (xlib:window-priority (widget-window widget)) :below))
(defun base-widget-p (widget)
(typep widget 'base-widget))
(defun lookup-widget (window)
"Returns the associated widget if any."
(declare (optimize (speed 3) (safety 0)))
(declare (inline getwinhash))
(getwinhash window *widget-table*))
(defun save-widget (window widget)
(declare (optimize (speed 3) (safety 0)))
(setf (getwinhash window *widget-table*) widget))
(defun clear-widget (window)
(declare (optimize (speed 3) (safety 0)))
(declare (inline remwinhash))
(remwinhash window *widget-table*))
(declaim (inline lookup-widget save-widget clear-widget))
(defclass standard-property-holder (base-widget) ())
;;;; The ROOT
(defclass root (base-widget)
((property-holder :initarg :manager :accessor root-property-holder)
(resize-status :initform nil :accessor root-resize-status)
(move-status :initform nil :accessor root-move-status)
(default-cursor :initform nil :accessor root-default-cursor)
(current-active-widget :initform nil)
(decoration-theme :initform nil :accessor root-decoration-theme)
(menu1 :initform nil)
(menu2 :initform nil)
(menu3 :initform nil)
(window-menu :initform nil)
(client-list :initform (make-hash-table))
(desktop :initform nil :writer (setf root-desktop))
(sm-conn :initform nil :accessor root-sm-conn)))
(defmethod root-desktop ((root root) &optional window-p)
(with-slots (desktop) root
(when (first desktop)
(if window-p (widget-window (first desktop)) (first desktop)))))
(defmethod add-desktop-application ((root root) (desktop base-widget))
(push desktop (slot-value root 'desktop)))
(defmethod remove-desktop-application ((root root) (desktop base-widget))
(setf (root-desktop root) (delete desktop (slot-value root 'desktop))))
(defmethod focus-widget ((root root) timestamp)
(declare (ignorable timestamp))
(xlib:set-input-focus *display* :pointer-root :pointer-root)
(setf (netwm:net-active-window (widget-window root)) :none))
(defun dismiss-move-resize (root)
(with-slots (resize-status move-status current-active-widget) root
(when (or *verbose-move* *verbose-resize*) (undraw-geometry-info-box))
(when (or move-status resize-status)
(setf (values move-status resize-status current-active-widget) nil)
(xlib:ungrab-server *display*)
(xlib:ungrab-pointer *display*))))
(defun close-sm-connection (root &key (exit-p t))
(with-slots (sm-conn) root
(sm-lib:close-sm-connection sm-conn)
(setf sm-conn nil)
(when exit-p (error 'exit-eclipse :close-application-p t))))
;;;; Application
(define-constant +application-mask+
'(:property-change :enter-window :visibility-change :focus-change)
:test #'equalp)
(define-constant +properties-to-delete-on-withdrawn+
'(:_net_wm_state :_net_wm_desktop :_win_workspace)
:test #'equalp)
(defclass application (base-widget)
((master :initarg :master :reader application-master)
(active-p :initform nil :accessor application-active-p)
(input-model :initform nil :initarg :input :reader application-input-model)
(icon :initform nil :initarg :icon :reader application-icon)
(iconic-p :initform nil :accessor application-iconic-p)
(wants-iconic-p :initform nil :accessor application-wants-iconic-p)
(wants-focus-p :initform nil :accessor application-wants-focus-p)
(initial-geometry :initform (make-geometry) :initarg :initial-geometry)
(full-geometry :initform (make-geometry) :initarg :full-geometry)
(type :initarg :type :accessor application-type)
(dialogs :initform nil :writer (setf application-dialogs))
(transient-for :initform nil :initarg :transient-for
:accessor application-transient-for)))
(defmethod application-dialogs ((application application))
"Returns all dialog applications of an application (including dialog of a
dialog). If this application is a transient-for (ICCCM 4.1.2.6) then the
returned list is the dialogs of its leader."
(labels ((find-all-dialogs (leader)
(loop for dialog in (reverse (slot-value leader 'dialogs))
append (cons dialog (find-all-dialogs dialog)))))
(let* ((leader (application-leader application))
(dialogs (find-all-dialogs leader)))
(if (eq leader application) dialogs (cons leader dialogs)))))
(defmethod (setf application-wants-iconic-p) :after (value (app application))
(loop for dialog in (application-dialogs app)
do (setf (slot-value dialog 'wants-iconic-p) value)))
(defmethod remove-widget :after ((application application))
(with-slots (type transient-for icon) application
(cond ((member :_net_wm_window_type_desktop type)
(remove-desktop-application *root* application))
((member :_net_wm_window_type_dock type)
(update-workarea-property *root*)))
(when transient-for
(with-slots (dialogs) transient-for
(setf dialogs (delete application dialogs))))
(remove-widget icon)
(ignore-errors (update-lists application 0 *root*))
(ignore-errors (xlib:destroy-window (widget-window icon)))))
(defmethod close-widget ((application application))
(with-slots (window) application
(if (member :wm_delete_window (xlib:wm-protocols window))
(send-wm-protocols-client-message window :wm_delete_window)
(kill-client-window window))))
(defmethod focus-widget ((application application) timestamp)
(with-slots (window input-model) application
(set-focus input-model window timestamp)))
(defmethod focused-p ((application application))
(loop with window = (widget-window application)
with foc = (xlib:input-focus *display*)
until (or (not (xlib:window-p foc)) (xlib:window-equal window foc))
do (multiple-value-bind (children parent) (xlib:query-tree foc)
(declare (ignore children))
(setq foc parent))
finally
(return (and (xlib:window-p foc) (xlib:window-equal window foc)))))
(defmethod shaded-p ((widget application))
(member :_net_wm_state_shaded (netwm:net-wm-state (widget-window widget))))
(defmethod widget-position-fix-p ((application application))
(with-slots (window) application
(or (member :win_state_fixed_position (gnome:win-state window))
(member :_net_wm_state_sticky (netwm:net-wm-state window)))))
(defmethod shade ((application application))
(with-slots (master) application
(and master (shade master))))
(defmethod put-on-top ((widget application))
(with-slots (master window input-model) widget
(unless (or (eq *focus-type* :none) (focused-p widget))
(set-focus input-model window nil))
(setf (window-priority (if master (widget-window master) window)) :above)))
(defmethod put-on-bottom ((widget application))
(with-slots (master window) widget
(let ((desk-w (root-desktop *root* t)))
(setf (window-priority (if master (widget-window master) window) desk-w)
(if desk-w :above :below)))))
(defun application-netwm-type-p (application type)
"Returns t if application is of the given type."
(member type (application-type application)))
(defun application-panel-p (application)
"Returns t if application is a panel (e.g: _net_wm_window_type_dock)."
(member :_net_wm_window_type_dock (application-type application)))
(defun fullscreenable-p (application)
(with-slots (window) application
(let ((hint (ignore-errors (wm-normal-hints window))))
(symbol-macrolet ((max-h (and hint (xlib:wm-size-hints-max-height hint)))
(max-w (and hint (xlib:wm-size-hints-max-width hint))))
(and (if max-w (= max-w (screen-width)) t)
(if max-h (= max-h (screen-height)) t))))))
(defun fullscreen-sizes (display)
"Returns the fullscreen x, y, width and height as a multiple value."
(if (xlib:query-extension display "XFree86-VidModeExtension")
(let* ((screen (xlib:display-default-screen display))
(ml (xlib:xfree86-vidmode-get-mode-line display screen)))
(multiple-value-bind (x y)
(xlib:xfree86-vidmode-get-viewport display screen)
(values x y (xlib:mode-info-hdisplay ml) (xlib:mode-info-vdisplay ml)))
(values 0 0 (screen-width) (screen-height)))))
;; Maximization helpers.
(defun find-max-geometry (application direction fill-p &key x y w h)
(multiple-value-bind (rx ry rw rh)
(rectangle-geometry
(find-largest-empty-area
application
:area-include-me-p (or (/= 1 direction) fill-p)
:panels-only-p (not fill-p)
:direction (case direction (2 :vertical) (3 :horizontal) (t :both))))
(with-slots (window master) application
(with-slots ((hm hmargin) (vm vmargin))
(if master (decoration-frame-style master)
(theme-default-style (lookup-theme "no-decoration")))
(symbol-macrolet ((minw (aref wmsh 0)) (minh (aref wmsh 1))
(maxw (aref wmsh 2)) (maxh (aref wmsh 3))
(incw (aref wmsh 4)) (inch (aref wmsh 5))
(basew (aref wmsh 6)) (baseh (aref wmsh 7)))
(let* ((wmsh (recompute-wm-normal-hints window hm vm))
(ww (or w (check-size (- rw hm) basew incw minw maxw)))
(hh (or h (check-size (- rh vm) baseh inch minh maxh))))
(when (> (+ ww hm) rw) (decf ww incw))
(when (> (+ hh vm) rh) (decf hh inch))
(make-geometry :w ww :h hh :x (or x rx) :y (or y ry))))))))
(defun compute-max-geometry
(application x y w h direction fill-p vert-p horz-p)
(symbol-macrolet
((ix (geometry-x initial-geometry)) (iy (geometry-y initial-geometry))
(iw (geometry-w initial-geometry)) (ih (geometry-h initial-geometry)))
(with-slots (initial-geometry) application
(case direction
;; Unmaximize or Maximize in both directions
(1 (if (or horz-p vert-p)
(copy-geometry initial-geometry)
(find-max-geometry application direction fill-p)))
;; Unmaximize or Maximize Vertically
(2 (if vert-p
(make-geometry :x x :y iy :w w :h ih)
(find-max-geometry application direction fill-p :x x :w w)))
;; Unmaximize or Maximize Horizontally
(3 (if horz-p
(make-geometry :x ix :y y :w iw :h h)
(find-max-geometry application direction fill-p :y y :h h)))))))
(defmethod maximize (application code &key (fill-p *maximize-fill*))
(with-slots ((app-window window) initial-geometry full-geometry master)
application
(when (shaded-p master) (shade master))
(let* ((new-g)
(m-window (if master (widget-window master) app-window))
(prop (netwm:net-wm-state app-window))
(fullscreen-p (member :_net_wm_state_fullscreen prop))
(vert-p (car (member :_net_wm_state_maximized_vert prop)))
(horz-p (car (member :_net_wm_state_maximized_horz prop))))
(multiple-value-bind (x y) (window-position m-window)
(multiple-value-bind (w h) (drawable-sizes app-window)
(unless (or horz-p vert-p)
(if fullscreen-p
(setf initial-geometry (copy-geometry full-geometry))
(setf (geometry initial-geometry) (values x y w h))))
(setf new-g (compute-max-geometry
application x y w h code fill-p vert-p horz-p))))
;; Updates net-wm-state property content.
(when (and (= 1 code) (or horz-p vert-p))
(setf (values horz-p vert-p) (values t t)))
(unless (= 3 code)
(if vert-p
(setf prop (delete :_net_wm_state_maximized_vert prop))
(pushnew :_net_wm_state_maximized_vert prop)))
(unless (= 2 code)
(if horz-p
(setf prop (delete :_net_wm_state_maximized_horz prop))
(pushnew :_net_wm_state_maximized_horz prop)))
;; Resize.
(if fullscreen-p
(setf full-geometry new-g)
(setf (window-position m-window) (geometry-coordinates new-g)
(drawable-sizes app-window) (geometry-sizes new-g)))
;; Update property.
(setf (netwm:net-wm-state app-window) prop))))
(defsetf application-frame-style (application) (frame-style)
`(with-slots (left-margin right-margin top-margin bottom-margin) ,frame-style
(setf (netwm:net-frame-extents (widget-window ,application))
(values left-margin right-margin top-margin bottom-margin))))
(defsetf fullscreen-mode (application) (mode)
"Mode may be (or :on :off). Put or remove application in or from fullscreen."
`(set-fullscreen-mode ,application ,mode))
(defun set-fullscreen-mode (application mode)
(with-slots (window (fgeometry full-geometry) master icon) application
;; reset appropriately _net_wm_state property.
(let ((prop (netwm:net-wm-state window)))
(if (eq mode :on)
(pushnew :_net_wm_state_fullscreen prop)
(setf prop (delete :_net_wm_state_fullscreen prop)))
(setf (netwm:net-wm-state window) prop))
(if (eq mode :on)
;; put in fullscreen mode.
(with-event-mask ((xlib:drawable-root window))
(multiple-value-bind (x y w h) (window-geometry window)
(when master
(with-slots (children (master-win window) frame-style) master
(multiple-value-setq (x y) (window-position master-win))
(setf (slot-value master 'old-frame-style) frame-style)
(setf (decoration-frame-style master)
(theme-default-style (lookup-theme "no-decoration")))))
(setf (geometry fgeometry) (values x y w h))
(multiple-value-setq (x y w h)
(fullscreen-sizes (xlib:window-display window)))
(configure-window window :x x :y y :width w :height h))
(focus-widget application 0))
;; revert: restore precedent geometry and decoration style.
(with-event-mask ((xlib:drawable-root window))
(setf (drawable-sizes window) (geometry-sizes fgeometry))
(unless (window-not-decorable-p window)
(setf (decoration-frame-style master)
(slot-value master 'old-frame-style)))
(multiple-value-bind (x y) (geometry-coordinates fgeometry)
(with-slots (window) (or master application)
(configure-window window :x x :y y)))))))
(defun application-leader (application)
"Returns the \"leader\" of an application. The leader is computed
recursively from the transient-for application hint."
(with-slots (transient-for) application
(if transient-for (application-leader transient-for) application)))
(defun migrate-application (application new-screen-number)
"Put an application, all its related dialogs and the top-level it is
transient-for (if any) to the a new virtual screen."
(with-slots (master window transient-for iconic-p) application
(let* ((focused-p (focused-p application))
(unmap-p (/= new-screen-number +any-desktop+ (current-desk)))
(operation (if (or iconic-p unmap-p)
#'xlib:unmap-window
#'xlib:map-window)))
(flet ((migrate (application)
(with-slots (master window) application
(when (shaded-p application) (shade application))
(setf (window-desktop-num window) new-screen-number)
(with-event-mask ((xlib:drawable-root window))
(let ((master-window (when master (widget-window master))))
(funcall operation (or master-window window))
(when master-window
(with-event-mask (master-window)
(funcall operation window)))))
(setf (application-wants-focus-p application) nil))))
(unless (= (window-desktop-num window) new-screen-number)
(mapc #'migrate (application-dialogs application))
(unless transient-for (migrate application))
(when (and unmap-p focused-p (eq *focus-type* :on-click))
(give-focus-to-next-widget-in-desktop)))))))
(defun undecore-application (application &key state)
"Removes all decoration of this application widget and reparent it to root."
(with-slots (window master icon) application
(if master
(let ((root-window (xlib:drawable-root window)))
(multiple-value-bind (x y)
(xlib:translate-coordinates window 0 0 root-window)
(xlib:reparent-window window root-window x y)
(event-process (make-event :destroy-notify) master)))
(event-process (make-event :destroy-notify :window window) *root*))
(when state
(setf (wm-state window) state)
(when (= state 0)
(delete-properties window +properties-to-delete-on-withdrawn+)))))
(defun computes-transient-for (application)
"Sets and returns the transient-for slot of an application. If this
application is a transient-for (ICCCM 4.1.2.6) then it will be added to
the dialogs list of its leader."
(with-slots (transient-for (win window)) application
(let ((transient (lookup-widget (ignore-errors (xlib:transient-for win)))))
(when (and transient (not (eq *root* transient)))
(pushnew application (slot-value transient 'dialogs)))
(when (and transient-for (not (equal transient-for transient)))
(with-slots (dialogs) transient-for
(setf dialogs (delete application dialogs))))
(setf transient-for transient))))
(defun find-input-model (window)
"Returns the input model keyword of this window according to ICCCM (4.1.7)."
(let* ((hint (ignore-errors (xlib:get-property window :WM_HINTS)))
(protocols (ignore-errors (xlib:wm-protocols window)))
(input-p (and hint (logbitp 0 (first hint)) (= 1 (second hint))))
(take-focus-p (ignore-errors (member :wm_take_focus protocols))))
(when (or (not hint) (not (logbitp 0 (first hint))))
;; The input model is not set in the property. For some application
;; that forgot to precise it we'll act as if it was (otherwise they
;; can't get focused).
(setf input-p t))
(cond ((and (not input-p) (not take-focus-p)) :no-input)
((and (not input-p) take-focus-p) :globally-active)
((and input-p (not take-focus-p)) :passive)
((and input-p take-focus-p) :locally-active))))
(defun make-initital-geometry (window &optional (geometry (make-geometry)))
"Returns the initial-geometry of a window. The initial geometry will be
computed according to the wm-normal-hints property if present or to the
actual geometry of the specified window. If the optional geometry is
given then it will be filled and returned."
(multiple-value-bind (x y w h) (window-geometry window)
(let ((hint (ignore-errors (wm-normal-hints window))))
(setf (geometry geometry)
(values (or (when hint (xlib:wm-size-hints-x hint)) x)
(or (when hint (xlib:wm-size-hints-y hint)) y)
(or (when hint (xlib:wm-size-hints-width hint)) w)
(or (when hint (xlib:wm-size-hints-height hint)) h)))
geometry)))
(defun create-application (window master)
(let* ((input (find-input-model window))
(type (ignore-errors (netwm:net-wm-window-type window)))
(desktop-p (member :_net_wm_window_type_desktop type))
(dock-p (member :_net_wm_window_type_dock type))
(initial-geometry (make-initital-geometry window))
(app (make-instance 'application
:window window :master master :input input :type type
:initial-geometry initial-geometry
:full-geometry (copy-geometry initial-geometry))))
(ignore-errors
(computes-transient-for app)
(create-icon app master)
(if (or desktop-p dock-p)
(let* ((prec-desk (root-desktop *root* t))
(stack-mode (if prec-desk :above :below))
(netwm-state (ignore-errors (netwm:net-wm-state window))))
(pushnew :_net_wm_state_skip_pager netwm-state)
(pushnew :_net_wm_state_skip_taskbar netwm-state)
(when desktop-p
(pushnew :_net_wm_state_sticky netwm-state)
(add-desktop-application *root* app)
(setf (xlib:window-priority window prec-desk) stack-mode))
(setf (netwm:net-wm-state window) netwm-state
(window-desktop-num window) +any-desktop+))
(grab-button window :any '(:button-press) :sync-pointer-p t))
(setf (xlib:window-event-mask window) +application-mask+))
app))
(defun kill-client-window (window)
(xlib:kill-client (xlib:drawable-display window) (xlib:window-id window)))
(defun application-p (widget)
(typep widget 'application))
;;;; Buttons
(defclass button (base-widget)
((master :initarg :master :reader button-master)
(item-to-draw :initarg :item-to-draw :accessor button-item-to-draw)))
(eval-when (:compile-toplevel :load-toplevel)
(define-constant +std-button-mask+
'(:button-press :button-release :button-motion :owner-grab-button :exposure)
:test #'equalp))
(defmethod repaint ((widget button) theme (focus t))
(declare (ignorable theme focus))
(with-slots (item-to-draw window gcontext) widget
(xlib:clear-area window)
(typecase item-to-draw
(string (draw-centered-text window gcontext item-to-draw))
(xlib:pixmap (draw-pixmap window gcontext item-to-draw)))))
(defmethod repaint ((widget button) theme (focus null))
(declare (ignorable theme focus))
(xlib:clear-area (widget-window widget)))
(defmethod shaded-p ((widget button))
(with-slots (window) (get-child (button-master widget) :application)
(member :_net_wm_state_shaded (netwm:net-wm-state window))))
(defun button-p (widget)
(typep widget 'button))
(declaim (inline draw-pixmap))
(defun draw-pixmap (window gctxt pix &key (x 0) (y 0) width height)
"Draw, and tile if necessary, the pixmap in the given region in the window."
(multiple-value-bind (w h) (drawable-sizes window)
(unless width (setf width w))
(unless height (setf height h)))
(if (= (xlib:drawable-depth pix) 1)
(xlib:copy-plane pix gctxt 1 0 0 width height window x y)
(xlib:with-gcontext (gctxt :tile pix :fill-style :tiled :ts-x x :ts-y y)
(xlib:draw-rectangle window gctxt x y width height t))))
(defun create-button (button-type &key parent x y width height
item background master (border-width 0)
(border *black*)
(gravity :north-west)
(cursor (root-default-cursor *root*))
(event-mask +std-button-mask+))
;; When calling this function arguments non optional are
;; :parent :x :y :width :height
;; the others are optional.
(when (and (not (xlib:cursor-p cursor)) (keywordp cursor))
(setf cursor (get-x-cursor *display* cursor)))
(make-instance button-type
:window (xlib:create-window
:parent parent :x x :y y
:width width :height height :border-width border-width
:background background :border border
:gravity gravity :bit-gravity (if item :north-west :forget)
:cursor cursor :event-mask event-mask)
:item-to-draw item :master master))
;;;; Box button
;; Use it for displaying short message in window, that do not require
;; any user intervention (no OK/Cancel confirmation).
(defclass box-button (button)
((pixmap :initform nil :initarg :pixmap-to-display :accessor message-pixmap)))
(defun create-message-box (messages &key parent pixmap
(border-width 1)
(background *white*))
(setf messages (apply #'concatenate 'string messages))
(let ((message-box
(create-button 'box-button
:parent parent :event-mask '(:exposure :visibility-change)
:x 0 :y 0 :width 1 :height 1 :border-width border-width
:background background :item messages)))
(setf (xlib:window-override-redirect (widget-window message-box)) :on
(button-item-to-draw message-box) messages
(message-pixmap message-box) pixmap)
message-box))
(defmethod (setf button-item-to-draw) (m (box box-button))
(with-slots (window (gctxt gcontext) pixmap) box
(multiple-value-bind (width height)
(xlib:text-extents (xlib:gcontext-font gctxt) m :translate #'translate)
(incf width 20) (incf height 20)
(when pixmap
(setf height (max (+ 20 (xlib:drawable-height pixmap)) height))
(incf width (+ 10 (xlib:drawable-width pixmap))))
(multiple-value-bind (children parent) (xlib:query-tree window)
(declare (ignore children))
(let ((x (ash (- (xlib:drawable-width parent) width) -1))
(y (ash (- (xlib:drawable-height parent) height) -1)))
(setf (drawable-sizes window) (values width height)
(window-position window) (values x y)
(slot-value box 'item-to-draw) m))))))
(defmethod repaint ((widget box-button) theme focus &aux x)
(declare (ignorable theme focus))
(with-slots (window item-to-draw gcontext pixmap) widget
(xlib:clear-area window)
(when pixmap
(multiple-value-bind (w h) (drawable-sizes pixmap)
(draw-pixmap window gcontext pixmap :x 10 :y 10 :width w :height h)
(setf x (+ w 20))))
(draw-centered-text window gcontext item-to-draw :color *black* :x x)))
(defun timed-message-box (window &rest messages)
"Map a small box, of parent `window', displaying the given string messages.
This box will automatically destroyed two seconds after being mapped."
(let ((box (create-message-box messages :parent window)))
(with-slots (window) box
(xlib:map-window window)
(pt:arm-timer 2 (lambda ()
(xlib:display-finish-output *display*)
(remove-widget box)
(xlib:destroy-window window))))))
;;;; Push button
;; Everybody knows what a push button is.
(defclass push-button (button)
((armed :initform nil :accessor button-armed)
(active-p :initform nil :accessor button-active-p)))
(define-constant +push-button-mask+ '(:exposure . #.+pointer-event-mask+)
:test #'equalp)
(defmethod focus-widget ((button push-button) timestamp)
(focus-widget (button-master button) timestamp))
(defmethod event-process ((event enter-notify) (b push-button))
(when (button-armed b)
(setf (button-active-p b) t)))
(defmethod event-process ((event leave-notify) (b push-button))
(when (button-armed b)
(setf (button-active-p b) nil)))
(defmethod event-process :around ((event button-press) (b push-button))
(setf (button-armed b) t
(button-active-p b) t)
(when (next-method-p)
(call-next-method)))
(defmethod event-process :around ((event button-release) (b push-button))
(with-slots (armed active-p) b
(if (and armed active-p)
(when (next-method-p) (call-next-method))
(event-process event *root*))
(setf armed nil
(button-active-p b) nil)))
(defmethod (setf button-active-p) :after (value (button push-button))
(declare (ignorable value))
(with-slots (window master) button
(when (decoration-p master)
(with-slots (theme) (decoration-frame-style master)
(repaint button theme (focused-p master))))))
(defmethod repaint ((widget push-button) theme (focus t))
(declare (ignorable theme focus))
(with-slots (window gcontext armed active-p item-to-draw) widget
(xlib:clear-area window)
(let ((p (and armed active-p (push-button-pixmap widget :focused-click))))
(when (or p item-to-draw)
(draw-pixmap window gcontext (or p item-to-draw))))))
(defmethod repaint ((widget push-button) theme (focus null))
(declare (ignorable theme focus))
(with-slots (window gcontext armed active-p) widget
(xlib:clear-area window)
(let ((pixmap (push-button-pixmap widget :unfocused-click)))
(when (and armed active-p pixmap)
(draw-pixmap window gcontext pixmap)))))
(defun push-button-pixmap (pbutton pixmap-index)
(with-slots ((astyle frame-style)) (button-master pbutton)
(let ((pixs (frame-item-pixmaps astyle (widget->frame-item-key pbutton))))
(declare (type pixmaps pixs))
(aref pixs
(case pixmap-index
(:focused-click 3)
(:unfocused-click 2)
(:focused-unclick 1)
((and (numberp pixmap-index) (<= 0 pixmap-index 3)) pixmap-index)
(t 0))))))
;;;; Standard decoration buttons
(defclass title-bar (push-button)
((timestamp :initform 0)
(vmargin :initform 0)
(hmargin :initform 0)
(parent :initform nil)))
(defmethod repaint ((widget title-bar) theme focus)
(declare (ignorable theme focus))
(with-slots (item-to-draw window gcontext) widget
(xlib:clear-area window)
(when item-to-draw
(draw-centered-text window gcontext item-to-draw))))
(defclass close-button (push-button) ())
(defclass iconify-button (push-button) ())
(defclass maximize-button (push-button) ())
(defclass menu-button (push-button) ())
;; Those are master edges and master corners
(define-constant +edge-event-mask+
'(:button-press :button-release :button-motion :owner-grab-button)
:test #'equalp)
(defclass edge (button)
((gravity :initform :north-west :accessor edge-gravity)
(cursor :initform :xc_left_ptr :accessor edge-cursor)))
(defmethod initialize-instance :after ((edge edge) &rest options)
(declare (ignore options))
(with-slots (window cursor gravity) edge
(setf (xlib:window-gravity window) gravity)
(setf (xlib:window-cursor window)
(get-x-cursor (xlib:drawable-display window) cursor))))
(defclass top (edge)
((cursor :initform :xc_top_side)))
(defclass top-left (edge)
((cursor :initform :xc_top_left_corner)))
(defclass top-right (edge)
((gravity :initform :north-east)
(cursor :initform :xc_top_right_corner)))
(defclass right (edge)
((gravity :initform :north-east)
(cursor :initform :xc_right_side)))
(defclass left (edge)
((cursor :initform :xc_left_side)))
(defclass bottom (edge)
((gravity :initform :south-west)
(cursor :initform :xc_bottom_side)))
(defclass bottom-right (edge)
((gravity :initform :south-east)
(cursor :initform :xc_bottom_right_corner)))
(defclass bottom-left (edge)
((gravity :initform :south-west)
(cursor :initform :xc_bottom_left_corner)))
;;;; Icon
(defclass icon (push-button)
((desiconify-p :initform nil :accessor icon-desiconify-p)
(creation-time :initform (get-universal-time) :accessor icon-creation-time)
(application :initarg :application :reader icon-application)
(pixmap-to-free :initform nil :reader icon-pixmap-to-free)))
(defun icon-p (widget)
(typep widget 'icon))
(defun create-icon (application master &optional (bg-color *black*))
(with-slots (window icon gcontext) application
(let* ((bkgrd (decode-netwm-icon-pixmap window (netwm:net-wm-icon window)))
(width 45) (height 20) (pixmap-to-free bkgrd))
(unless bkgrd
(setf bkgrd (ignore-errors (clx-ext::wm-hints-icon-pixmap window))))
(ignore-errors
(if (typep bkgrd 'xlib:pixmap)
(multiple-value-setq (width height) (drawable-sizes bkgrd))
(setf bkgrd nil)))
(ignore-errors
(when (and bkgrd (= 1 (xlib:drawable-depth bkgrd)))
(let ((pix (xlib:create-pixmap
:drawable window :width width :height height
:depth (xlib:drawable-depth window))))
(xlib:copy-plane bkgrd gcontext 1 0 0 width height pix 0 0)
(setf bkgrd pix))))
(setf icon (create-button 'icon
:event-mask '(:pointer-motion-hint . #.+std-button-mask+)
:parent (xlib:drawable-root window) :master master
:x 0 :y 0 :width width :height height
:item (unless bkgrd (wm-icon-name window))
:background (or bkgrd bg-color)))
(setf (slot-value icon 'pixmap-to-free) pixmap-to-free)
(setf (slot-value icon 'application) application)
icon)))
(defun icon-sort-creation-order (icon1 icon2)
(< (icon-creation-time icon1) (icon-creation-time icon2)))
(defun icon-sort-name (icon1 icon2)
(string< (xlib:wm-name (widget-window (icon-application icon1)))
(xlib:wm-name (widget-window (icon-application icon2)))))
(defun icon-sort-type (icon1 icon2)
(let ((c1 (application-class (icon-application icon1)))
(c2 (application-class (icon-application icon2))))
(or (string< (cdr c1) (cdr c2))
(and (string= (cdr c1) (cdr c2))
(string< (car c1) (car c2))))))
(defun icon-box-update ()
(declare (type (simple-array integer (4)) *icon-box*))
(unless (eq *icon-box-fill* :top-right)
(timed-message-box (widget-window *root*)
"Only :top-right fill is currently supported"))
(let ((icons (stable-sort
(loop for val being each hash-value in *widget-table*
when (icon-p val) collect val)
(or *icon-box-sort-function* #'icon-sort-creation-order))))
(flet ((absx (v) (if (< v 0) (+ (screen-width) v) v))
(absy (v) (if (< v 0) (+ (screen-height) v) v)))
(let* ((box-tlx (absx (aref *icon-box* 0))) ;top left x
(box-tly (absy (aref *icon-box* 1)))
(box-brx (absx (aref *icon-box* 2))) ;bottom right y
(box-bry (absy (aref *icon-box* 3)))
(box-trx box-brx)
(box-try box-tly)
(box-blx box-tlx)
(box-bly box-bry)
(box-sizex (- box-trx box-tlx))
(box-sizey (- box-bry box-try))
(prev-icon-window nil)
(maxedge 0)
(basex 0)
(basey nil))
(declare (ignore box-sizey box-sizex box-blx))
(dolist (icon icons)
(let* ((icon-window (widget-window icon))
(icon-x (xlib:drawable-x icon-window))
(icon-y (xlib:drawable-y icon-window)))
(setq maxedge (max (xlib:drawable-width icon-window) maxedge)
basex (- box-trx maxedge *icon-box-sep*)
basey (if (not basey)
box-try
(+ basey
(xlib:drawable-height prev-icon-window)
*icon-box-sep*)))
(when (> basey box-bry)
(setq basey box-try
basex (- basex maxedge *icon-box-sep*)
maxedge (xlib:drawable-width icon-window)))
(when (< basex box-tlx)
;;if the box overflows, we put the icon into (0,0)
(setq basex 0 basey 0))
(cond
((and (= basex icon-x) (= basey icon-y)))
((or (< 0 basex box-tlx) (> basex box-trx)
(< 0 basey box-tly) (> basey box-bly)))
(t
(xlib:with-state (icon-window)
(setf (window-position icon-window) (values basex basey)))))
(setq prev-icon-window icon-window)))))))
(defsetf icon-priority (icon) (priority)
"Restack the window of the given icon according the given priority."
(with-gensym (p sibling)
`(let ((,p ,priority) ,sibling)
(when (eq ,priority :below)
(setf ,sibling (root-desktop *root* t)
,p (if ,sibling :above :below)))
(setf (xlib:window-priority (widget-window ,icon) ,sibling) ,p))))
(defmethod close-widget ((widget icon))
(close-widget (icon-application widget)))
(defmethod remove-widget :after ((widget icon))
(with-slots (pixmap-to-free) widget
(and pixmap-to-free (xlib:free-pixmap pixmap-to-free))
(setf pixmap-to-free nil)))
(defmethod repaint ((widget icon) theme focus)
(declare (ignorable theme focus))
(with-slots (window item-to-draw gcontext) widget
(xlib:clear-area window)
(draw-centered-text window gcontext item-to-draw :color *white*)))
(defmethod iconify ((application application))
(icon-box-update)
(flet ((_iconify_ (application &optional (map-icons *icon-hints*))
(with-slots (window iconic-p wants-focus-p icon master) application
(when (shaded-p application)
(shade application))
(setf iconic-p t wants-focus-p t)
(when (eq (xlib:window-map-state window) :unmapped)
(setf (wm-state window) 3))
(xlib:unmap-window window)
(when master
(xlib:unmap-window (widget-window master)))
(when (stringp (slot-value icon 'item-to-draw))
(setf (slot-value icon 'item-to-draw) (wm-icon-name window)))
(when map-icons
(xlib:map-window (widget-window icon))
(setf (icon-priority icon) :below)))))
(with-slots (transient-for) application
(let ((seq (application-dialogs application)))
(mapc (lambda (a) (_iconify_ a nil)) (if transient-for (cdr seq) seq))
(_iconify_ (if transient-for (car seq) application))))
(when (eq *focus-type* :on-click)
(give-focus-to-next-widget-in-desktop))))
(defmethod uniconify ((icon icon))
(flet ((_uniconify_ (application)
(with-slots (icon window) application
(when (shaded-p application)
(shade application))
(setf (icon-desiconify-p icon) nil)
(setf (window-desktop-num window)
(if (stick-p window) +any-desktop+ (current-desk)))
(unmap-icon-window icon)
(xlib:map-window window))))
(with-slots (application) icon
(unless (application-transient-for application)
(_uniconify_ application))
(mapc #'_uniconify_ (application-dialogs application)))))
(defmethod unmap-icon-window ((icon icon))
(with-slots (window master application) icon
(xlib:unmap-window window)
(setf (application-iconic-p application) nil)
(unless master
(with-slots (window) application
(setf (wm-state window) 1)))))