-
Notifications
You must be signed in to change notification settings - Fork 1
/
manager.cl
928 lines (860 loc) · 36.9 KB
/
manager.cl
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
;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
;;; Window Manager Property functions
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
(in-package :xlib)
(defun wm-name (window)
(declare (type window window))
(declare (values string))
(get-property window :WM_NAME :type :STRING :result-type 'string :transform #'card8->char))
(defsetf wm-name (window) (name)
`(set-string-property ,window :WM_NAME ,name))
(defun set-string-property (window property string)
(declare (type window window)
(type keyword property)
(type stringable string))
(change-property window property (string string) :STRING 8 :transform #'char->card8)
string)
(defun wm-icon-name (window)
(declare (type window window))
(declare (values string))
(get-property window :WM_ICON_NAME :type :STRING
:result-type 'string :transform #'card8->char))
(defsetf wm-icon-name (window) (name)
`(set-string-property ,window :WM_ICON_NAME ,name))
(defun wm-client-machine (window)
(declare (type window window))
(declare (values string))
(get-property window :WM_CLIENT_MACHINE :type :STRING
:result-type 'string :transform #'card8->char))
(defsetf wm-client-machine (window) (name)
`(set-string-property ,window :WM_CLIENT_MACHINE ,name))
(defun get-wm-class (window)
(declare (type window window))
(declare (values (or null name-string) (or null class-string)))
(let ((value (get-property window :WM_CLASS :type :STRING
:result-type 'string :transform #'card8->char)))
(declare (type (or null string) value))
(when value
(let* ((name-len (position #.(card8->char 0) (the string value)))
(name (subseq (the string value) 0 name-len))
(class (subseq (the string value) (1+ name-len) (1- (length value)))))
(values (and (plusp (length name)) name)
(and (plusp (length class)) class))))))
(defun set-wm-class (window resource-name resource-class)
(declare (type window window)
(type (or null stringable) resource-name resource-class))
(set-string-property window :WM_CLASS
(concatenate 'string
(string (or resource-name ""))
#.(make-string 1 :initial-element (card8->char 0))
(string (or resource-class ""))
#.(make-string 1 :initial-element (card8->char 0))))
(values))
(defun wm-command (window)
;; Returns a list whose car is the command and
;; whose cdr is the list of arguments
(declare (type window window))
(declare (values list))
(do* ((command-string (get-property window :WM_COMMAND :type :STRING
:result-type 'string :transform #'card8->char))
(command nil)
(start 0 (1+ end))
(end 0)
(len (length command-string)))
((>= start len) (nreverse command))
(setq end (position #.(card8->char 0) command-string :start start))
(push (subseq command-string start end) command)))
(defsetf wm-command set-wm-command)
(defun set-wm-command (window command)
;; Uses PRIN1 inside the ANSI common lisp form WITH-STANDARD-IO-SYNTAX (or
;; equivalent), with elements of command separated by NULL characters. This
;; enables
;; (with-standard-io-syntax (mapcar #'read-from-string (wm-command window)))
;; to recover a lisp command.
(declare (type window window)
(type list command))
(set-string-property
window :WM_COMMAND
(with-output-to-string (stream)
(with-standard-io-syntax
(dolist (c command)
(prin1 c stream)
(write-char #.(card8->char 0) stream)))))
command)
;;-----------------------------------------------------------------------------
;; WM_HINTS
(def-clx-class (wm-hints)
(input nil :type (or null (member :off :on)))
(initial-state nil :type (or null (member :dont-care :normal :zoom :iconic :inactive)))
(icon-pixmap nil :type (or null pixmap))
(icon-window nil :type (or null window))
(icon-x nil :type (or null card16))
(icon-y nil :type (or null card16))
(icon-mask nil :type (or null pixmap))
(window-group nil :type (or null resource-id))
(flags 0 :type card32) ;; Extension-hook. Exclusive-Or'ed with the FLAGS field
;; may be extended in the future
)
(defun wm-hints (window)
(declare (type window window))
(declare (values wm-hints))
(let ((prop (get-property window :WM_HINTS :type :WM_HINTS :result-type 'vector)))
(when prop
(decode-wm-hints prop (window-display window)))))
(defsetf wm-hints set-wm-hints)
(defun set-wm-hints (window wm-hints)
(declare (type window window)
(type wm-hints wm-hints))
(declare (values wm-hints))
(change-property window :WM_HINTS (encode-wm-hints wm-hints) :WM_HINTS 32)
wm-hints)
(defun decode-wm-hints (vector display)
(declare (type (simple-vector 9) vector)
(type display display))
(declare (values wm-hints))
(let ((input-hint 0)
(state-hint 1)
(icon-pixmap-hint 2)
(icon-window-hint 3)
(icon-position-hint 4)
(icon-mask-hint 5)
(window-group-hint 6))
(let ((flags (aref vector 0))
(hints (make-wm-hints))
(%buffer display))
(declare (type card32 flags)
(type wm-hints hints)
(type display %buffer))
(setf (wm-hints-flags hints) flags)
(when (logbitp input-hint flags)
(setf (wm-hints-input hints) (decode-type (member :off :on) (aref vector 1))))
(when (logbitp state-hint flags)
(setf (wm-hints-initial-state hints)
(decode-type (member :dont-care :normal :zoom :iconic :inactive)
(aref vector 2))))
(when (logbitp icon-pixmap-hint flags)
(setf (wm-hints-icon-pixmap hints) (decode-type pixmap (aref vector 3))))
(when (logbitp icon-window-hint flags)
(setf (wm-hints-icon-window hints) (decode-type window (aref vector 4))))
(when (logbitp icon-position-hint flags)
(setf (wm-hints-icon-x hints) (aref vector 5)
(wm-hints-icon-y hints) (aref vector 6)))
(when (logbitp icon-mask-hint flags)
(setf (wm-hints-icon-mask hints) (decode-type pixmap (aref vector 7))))
(when (and (logbitp window-group-hint flags) (> (length vector) 7))
(setf (wm-hints-window-group hints) (aref vector 8)))
hints)))
(defun encode-wm-hints (wm-hints)
(declare (type wm-hints wm-hints))
(declare (values simple-vector))
(let ((input-hint #b1)
(state-hint #b10)
(icon-pixmap-hint #b100)
(icon-window-hint #b1000)
(icon-position-hint #b10000)
(icon-mask-hint #b100000)
(window-group-hint #b1000000)
(mask #b1111111)
)
(let ((vector (make-array 9 :initial-element 0))
(flags 0))
(declare (type (simple-vector 9) vector)
(type card16 flags))
(when (wm-hints-input wm-hints)
(setf flags input-hint
(aref vector 1) (encode-type (member :off :on) (wm-hints-input wm-hints))))
(when (wm-hints-initial-state wm-hints)
(setf flags (logior flags state-hint)
(aref vector 2) (encode-type (member :dont-care :normal :zoom :iconic :inactive)
(wm-hints-initial-state wm-hints))))
(when (wm-hints-icon-pixmap wm-hints)
(setf flags (logior flags icon-pixmap-hint)
(aref vector 3) (encode-type pixmap (wm-hints-icon-pixmap wm-hints))))
(when (wm-hints-icon-window wm-hints)
(setf flags (logior flags icon-window-hint)
(aref vector 4) (encode-type window (wm-hints-icon-window wm-hints))))
(when (and (wm-hints-icon-x wm-hints) (wm-hints-icon-y wm-hints))
(setf flags (logior flags icon-position-hint)
(aref vector 5) (encode-type card16 (wm-hints-icon-x wm-hints))
(aref vector 6) (encode-type card16 (wm-hints-icon-y wm-hints))))
(when (wm-hints-icon-mask wm-hints)
(setf flags (logior flags icon-mask-hint)
(aref vector 7) (encode-type pixmap (wm-hints-icon-mask wm-hints))))
(when (wm-hints-window-group wm-hints)
(setf flags (logior flags window-group-hint)
(aref vector 8) (wm-hints-window-group wm-hints)))
(setf (aref vector 0) (logior flags (logandc2 (wm-hints-flags wm-hints) mask)))
vector)))
;;-----------------------------------------------------------------------------
;; WM_SIZE_HINTS
(def-clx-class (wm-size-hints)
(user-specified-position-p nil :type boolean) ;; True when user specified x y
(user-specified-size-p nil :type boolean) ;; True when user specified width height
(x nil :type (or null int16)) ;; Obsolete
(y nil :type (or null int16)) ;; Obsolete
(width nil :type (or null card16)) ;; Obsolete
(height nil :type (or null card16)) ;; Obsolete
(min-width nil :type (or null card16))
(min-height nil :type (or null card16))
(max-width nil :type (or null card16))
(max-height nil :type (or null card16))
(width-inc nil :type (or null card16))
(height-inc nil :type (or null card16))
(min-aspect nil :type (or null number))
(max-aspect nil :type (or null number))
(base-width nil :type (or null card16))
(base-height nil :type (or null card16))
(win-gravity nil :type (or null win-gravity))
(program-specified-position-p nil :type boolean) ;; True when program specified x y
(program-specified-size-p nil :type boolean) ;; True when program specified width height
)
(defun wm-normal-hints (window)
(declare (type window window))
(declare (values wm-size-hints))
(decode-wm-size-hints (get-property window :WM_NORMAL_HINTS :type :WM_SIZE_HINTS :result-type 'vector)))
(defsetf wm-normal-hints set-wm-normal-hints)
(defun set-wm-normal-hints (window hints)
(declare (type window window)
(type wm-size-hints hints))
(declare (values wm-size-hints))
(change-property window :WM_NORMAL_HINTS (encode-wm-size-hints hints) :WM_SIZE_HINTS 32)
hints)
;;; OBSOLETE
(defun wm-zoom-hints (window)
(declare (type window window))
(declare (values wm-size-hints))
(decode-wm-size-hints (get-property window :WM_ZOOM_HINTS :type :WM_SIZE_HINTS :result-type 'vector)))
;;; OBSOLETE
(defsetf wm-zoom-hints set-wm-zoom-hints)
;;; OBSOLETE
(defun set-wm-zoom-hints (window hints)
(declare (type window window)
(type wm-size-hints hints))
(declare (values wm-size-hints))
(change-property window :WM_ZOOM_HINTS (encode-wm-size-hints hints) :WM_SIZE_HINTS 32)
hints)
(defun decode-wm-size-hints (vector)
(declare (type (or null (simple-vector *)) vector))
(declare (values (or null wm-size-hints)))
(when vector
(let ((flags (aref vector 0))
(hints (make-wm-size-hints)))
(declare (type card16 flags)
(type wm-size-hints hints))
(setf (wm-size-hints-user-specified-position-p hints) (logbitp 0 flags))
(setf (wm-size-hints-user-specified-size-p hints) (logbitp 1 flags))
(setf (wm-size-hints-program-specified-position-p hints) (logbitp 2 flags))
(setf (wm-size-hints-program-specified-size-p hints) (logbitp 3 flags))
(when (logbitp 4 flags)
(setf (wm-size-hints-min-width hints) (aref vector 5)
(wm-size-hints-min-height hints) (aref vector 6)))
(when (logbitp 5 flags)
(setf (wm-size-hints-max-width hints) (aref vector 7)
(wm-size-hints-max-height hints) (aref vector 8)))
(when (logbitp 6 flags)
(setf (wm-size-hints-width-inc hints) (aref vector 9)
(wm-size-hints-height-inc hints) (aref vector 10)))
(when (logbitp 7 flags)
(setf (wm-size-hints-min-aspect hints) (/ (aref vector 11) (aref vector 12))
(wm-size-hints-max-aspect hints) (/ (aref vector 13) (aref vector 14))))
(when (> (length vector) 15)
;; This test is for backwards compatibility since old Xlib programs
;; can set a size-hints structure that is too small. See ICCCM.
(when (logbitp 8 flags)
(setf (wm-size-hints-base-width hints) (aref vector 15)
(wm-size-hints-base-height hints) (aref vector 16)))
(when (logbitp 9 flags)
(setf (wm-size-hints-win-gravity hints)
(decode-type (member-vector *win-gravity-vector*) (aref vector 17)))))
;; Obsolete fields
(when (or (logbitp 0 flags) (logbitp 2 flags))
(setf (wm-size-hints-x hints) (aref vector 1)
(wm-size-hints-y hints) (aref vector 2)))
(when (or (logbitp 1 flags) (logbitp 3 flags))
(setf (wm-size-hints-width hints) (aref vector 3)
(wm-size-hints-height hints) (aref vector 4)))
hints)))
(defun encode-wm-size-hints (hints)
(declare (type wm-size-hints hints))
(declare (values simple-vector))
(let ((vector (make-array 18 :initial-element 0))
(flags 0))
(declare (type (simple-vector 18) vector)
(type card16 flags))
(when (wm-size-hints-user-specified-position-p hints)
(setf (ldb (byte 1 0) flags) 1))
(when (wm-size-hints-user-specified-size-p hints)
(setf (ldb (byte 1 1) flags) 1))
(when (wm-size-hints-program-specified-position-p hints)
(setf (ldb (byte 1 2) flags) 1))
(when (wm-size-hints-program-specified-size-p hints)
(setf (ldb (byte 1 3) flags) 1))
(when (and (wm-size-hints-min-width hints) (wm-size-hints-min-height hints))
(setf (ldb (byte 1 4) flags) 1
(aref vector 5) (wm-size-hints-min-width hints)
(aref vector 6) (wm-size-hints-min-height hints)))
(when (and (wm-size-hints-max-width hints) (wm-size-hints-max-height hints))
(setf (ldb (byte 1 5) flags) 1
(aref vector 7) (wm-size-hints-max-width hints)
(aref vector 8) (wm-size-hints-max-height hints)))
(when (and (wm-size-hints-width-inc hints) (wm-size-hints-height-inc hints))
(setf (ldb (byte 1 6) flags) 1
(aref vector 9) (wm-size-hints-width-inc hints)
(aref vector 10) (wm-size-hints-height-inc hints)))
(let ((min-aspect (wm-size-hints-min-aspect hints))
(max-aspect (wm-size-hints-max-aspect hints)))
(when (and min-aspect max-aspect)
(setf (ldb (byte 1 7) flags) 1
min-aspect (rationalize min-aspect)
max-aspect (rationalize max-aspect)
(aref vector 11) (numerator min-aspect)
(aref vector 12) (denominator min-aspect)
(aref vector 13) (numerator max-aspect)
(aref vector 14) (denominator max-aspect))))
(when (and (wm-size-hints-base-width hints)
(wm-size-hints-base-height hints))
(setf (ldb (byte 1 8) flags) 1
(aref vector 15) (wm-size-hints-base-width hints)
(aref vector 16) (wm-size-hints-base-height hints)))
(when (wm-size-hints-win-gravity hints)
(setf (ldb (byte 1 9) flags) 1
(aref vector 17) (encode-type
(member-vector *win-gravity-vector*)
(wm-size-hints-win-gravity hints))))
;; Obsolete fields
(when (and (wm-size-hints-x hints) (wm-size-hints-y hints))
(unless (wm-size-hints-user-specified-position-p hints)
(setf (ldb (byte 1 2) flags) 1))
(setf (aref vector 1) (wm-size-hints-x hints)
(aref vector 2) (wm-size-hints-y hints)))
(when (and (wm-size-hints-width hints) (wm-size-hints-height hints))
(unless (wm-size-hints-user-specified-size-p hints)
(setf (ldb (byte 1 3) flags) 1))
(setf (aref vector 3) (wm-size-hints-width hints)
(aref vector 4) (wm-size-hints-height hints)))
(setf (aref vector 0) flags)
vector))
;;-----------------------------------------------------------------------------
;; Icon_Size
;; Use the same intermediate structure as WM_SIZE_HINTS
(defun icon-sizes (window)
(declare (type window window))
(declare (values wm-size-hints))
(let ((vector (get-property window :WM_ICON_SIZE :type :WM_ICON_SIZE :result-type 'vector)))
(declare (type (or null (simple-vector 6)) vector))
(when vector
(make-wm-size-hints
:min-width (aref vector 0)
:min-height (aref vector 1)
:max-width (aref vector 2)
:max-height (aref vector 3)
:width-inc (aref vector 4)
:height-inc (aref vector 5)))))
(defsetf icon-sizes set-icon-sizes)
(defun set-icon-sizes (window wm-size-hints)
(declare (type window window)
(type wm-size-hints wm-size-hints))
(let ((vector (vector (wm-size-hints-min-width wm-size-hints)
(wm-size-hints-min-height wm-size-hints)
(wm-size-hints-max-width wm-size-hints)
(wm-size-hints-max-height wm-size-hints)
(wm-size-hints-width-inc wm-size-hints)
(wm-size-hints-height-inc wm-size-hints))))
(change-property window :WM_ICON_SIZE vector :WM_ICON_SIZE 32)
wm-size-hints))
;;-----------------------------------------------------------------------------
;; WM-Protocols
(defun wm-protocols (window)
(map 'list #'(lambda (id) (atom-name (window-display window) id))
(get-property window :WM_PROTOCOLS :type :ATOM)))
(defsetf wm-protocols set-wm-protocols)
(defun set-wm-protocols (window protocols)
(change-property window :WM_PROTOCOLS
(map 'list #'(lambda (atom) (intern-atom (window-display window) atom))
protocols)
:ATOM 32)
protocols)
;;-----------------------------------------------------------------------------
;; WM-Colormap-windows
(defun wm-colormap-windows (window)
(values (get-property window :WM_COLORMAP_WINDOWS :type :WINDOW
:transform #'(lambda (id)
(lookup-window (window-display window) id)))))
(defsetf wm-colormap-windows set-wm-colormap-windows)
(defun set-wm-colormap-windows (window colormap-windows)
(change-property window :WM_COLORMAP_WINDOWS colormap-windows :WINDOW 32
:transform #'window-id)
colormap-windows)
;;-----------------------------------------------------------------------------
;; Transient-For
(defun transient-for (window)
(let ((prop (get-property window :WM_TRANSIENT_FOR :type :WINDOW :result-type 'list)))
(and prop (lookup-window (window-display window) (car prop)))))
(defsetf transient-for set-transient-for)
(defun set-transient-for (window transient)
(declare (type window window transient))
(change-property window :WM_TRANSIENT_FOR (list (window-id transient)) :WINDOW 32)
transient)
;;-----------------------------------------------------------------------------
;; Set-WM-Properties
(defun set-wm-properties (window &rest options &key
name icon-name resource-name resource-class command
client-machine hints normal-hints zoom-hints
;; the following are used for wm-normal-hints
(user-specified-position-p nil usppp)
(user-specified-size-p nil usspp)
(program-specified-position-p nil psppp)
(program-specified-size-p nil psspp)
x y width height min-width min-height max-width max-height
width-inc height-inc min-aspect max-aspect
base-width base-height win-gravity
;; the following are used for wm-hints
input initial-state icon-pixmap icon-window
icon-x icon-y icon-mask window-group)
;; Set properties for WINDOW.
(declare (arglist window &rest options &key
name icon-name resource-name resource-class command
client-machine hints normal-hints
;; the following are used for wm-normal-hints
user-specified-position-p user-specified-size-p
program-specified-position-p program-specified-size-p
min-width min-height max-width max-height
width-inc height-inc min-aspect max-aspect
base-width base-height win-gravity
;; the following are used for wm-hints
input initial-state icon-pixmap icon-window
icon-x icon-y icon-mask window-group))
(declare (type window window)
(type (or null stringable) name icon-name resource-name resource-class client-machine)
(type (or null list) command)
(type (or null wm-hints) hints)
(type (or null wm-size-hints) normal-hints zoom-hints)
(type boolean user-specified-position-p user-specified-size-p)
(type boolean program-specified-position-p program-specified-size-p)
(type (or null int16) x y)
(type (or null card16) width height min-width min-height max-width max-height width-inc height-inc base-width base-height)
(type (or null win-gravity) win-gravity)
(type (or null number) min-aspect max-aspect)
(type (or null (member :off :on)) input)
(type (or null (member :dont-care :normal :zoom :iconic :inactive)) initial-state)
(type (or null pixmap) icon-pixmap icon-mask)
(type (or null window) icon-window)
(type (or null card16) icon-x icon-y)
(type (or null resource-id) window-group)
(dynamic-extent options))
(when name (setf (wm-name window) name))
(when icon-name (setf (wm-icon-name window) icon-name))
(when client-machine (setf (wm-client-machine window) client-machine))
(when (or resource-name resource-class)
(set-wm-class window resource-name resource-class))
(when command (setf (wm-command window) command))
;; WM-HINTS
(if (dolist (arg '(:input :initial-state :icon-pixmap :icon-window
:icon-x :icon-y :icon-mask :window-group))
(when (getf options arg) (return t)))
(let ((wm-hints (if hints (copy-wm-hints hints) (make-wm-hints))))
(when input (setf (wm-hints-input wm-hints) input))
(when initial-state (setf (wm-hints-initial-state wm-hints) initial-state))
(when icon-pixmap (setf (wm-hints-icon-pixmap wm-hints) icon-pixmap))
(when icon-window (setf (wm-hints-icon-window wm-hints) icon-window))
(when icon-x (setf (wm-hints-icon-x wm-hints) icon-x))
(when icon-y (setf (wm-hints-icon-y wm-hints) icon-y))
(when icon-mask (setf (wm-hints-icon-mask wm-hints) icon-mask))
(when window-group (setf (wm-hints-input wm-hints) window-group))
(setf (wm-hints window) wm-hints))
(when hints (setf (wm-hints window) hints)))
;; WM-NORMAL-HINTS
(if (dolist (arg '(:x :y :width :height :min-width :min-height :max-width :max-height
:width-inc :height-inc :min-aspect :max-aspect
:user-specified-position-p :user-specified-size-p
:program-specified-position-p :program-specified-size-p
:base-width :base-height :win-gravity))
(when (getf options arg) (return t)))
(let ((size (if normal-hints (copy-wm-size-hints normal-hints) (make-wm-size-hints))))
(when x (setf (wm-size-hints-x size) x))
(when y (setf (wm-size-hints-y size) y))
(when width (setf (wm-size-hints-width size) width))
(when height (setf (wm-size-hints-height size) height))
(when min-width (setf (wm-size-hints-min-width size) min-width))
(when min-height (setf (wm-size-hints-min-height size) min-height))
(when max-width (setf (wm-size-hints-max-width size) max-width))
(when max-height (setf (wm-size-hints-max-height size) max-height))
(when width-inc (setf (wm-size-hints-width-inc size) width-inc))
(when height-inc (setf (wm-size-hints-height-inc size) height-inc))
(when min-aspect (setf (wm-size-hints-min-aspect size) min-aspect))
(when max-aspect (setf (wm-size-hints-max-aspect size) max-aspect))
(when base-width (setf (wm-size-hints-base-width size) base-width))
(when base-height (setf (wm-size-hints-base-height size) base-height))
(when win-gravity (setf (wm-size-hints-win-gravity size) win-gravity))
(when usppp
(setf (wm-size-hints-user-specified-position-p size) user-specified-position-p))
(when usspp
(setf (wm-size-hints-user-specified-size-p size) user-specified-size-p))
(when psppp
(setf (wm-size-hints-program-specified-position-p size) program-specified-position-p))
(when psspp
(setf (wm-size-hints-program-specified-size-p size) program-specified-size-p))
(setf (wm-normal-hints window) size))
(when normal-hints (setf (wm-normal-hints window) normal-hints)))
(when zoom-hints (setf (wm-zoom-hints window) zoom-hints))
)
;;; OBSOLETE
(defun set-standard-properties (window &rest options)
(declare (dynamic-extent options))
(apply #'set-wm-properties window options))
;;-----------------------------------------------------------------------------
;; WM Control
(defun iconify-window (window screen)
(declare (type window window)
(type screen screen))
(let ((root (screen-root screen)))
(declare (type window root))
(send-event root :client-message '(:substructure-redirect :substructure-notify)
:window window :format 32 :type :WM_CHANGE_STATE :data (list 3))))
(defun withdraw-window (window screen)
(declare (type window window)
(type screen screen))
(unmap-window window)
(let ((root (screen-root screen)))
(declare (type window root))
(send-event root :unmap-notify '(:substructure-redirect :substructure-notify)
:window window :event-window root :configure-p nil)))
;;-----------------------------------------------------------------------------
;; Colormaps
(def-clx-class (standard-colormap (:copier nil) (:predicate nil))
(colormap nil :type (or null colormap))
(base-pixel 0 :type pixel)
(max-color nil :type (or null color))
(mult-color nil :type (or null color))
(visual nil :type (or null visual-info))
(kill nil :type (or (member nil :release-by-freeing-colormap)
drawable gcontext cursor colormap font)))
(defun rgb-colormaps (window property)
(declare (type window window)
(type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP
:RGB_GREEN_MAP :RGB_BLUE_MAP) property))
(let ((prop (get-property window property :type :RGB_COLOR_MAP :result-type 'vector)))
(declare (type (or null simple-vector) prop))
(when prop
(list (make-standard-colormap
:colormap (lookup-colormap (window-display window) (aref prop 0))
:base-pixel (aref prop 7)
:max-color (make-color :red (card16->rgb-val (aref prop 1))
:green (card16->rgb-val (aref prop 3))
:blue (card16->rgb-val (aref prop 5)))
:mult-color (make-color :red (card16->rgb-val (aref prop 2))
:green (card16->rgb-val (aref prop 4))
:blue (card16->rgb-val (aref prop 6)))
:visual (and (<= 9 (length prop))
(visual-info (window-display window) (aref prop 8)))
:kill (and (<= 10 (length prop))
(let ((killid (aref prop 9)))
(if (= killid 1)
:release-by-freeing-colormap
(lookup-resource-id (window-display window) killid)))))))))
(defsetf rgb-colormaps set-rgb-colormaps)
(defun set-rgb-colormaps (window property maps)
(declare (type window window)
(type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP
:RGB_GREEN_MAP :RGB_BLUE_MAP) property)
(type list maps))
(let ((prop (make-array (* 10 (length maps)) :element-type 'card32))
(index -1))
(dolist (map maps)
(setf (aref prop (incf index))
(encode-type colormap (standard-colormap-colormap map)))
(setf (aref prop (incf index))
(encode-type rgb-val (color-red (standard-colormap-max-color map))))
(setf (aref prop (incf index))
(encode-type rgb-val (color-red (standard-colormap-mult-color map))))
(setf (aref prop (incf index))
(encode-type rgb-val (color-green (standard-colormap-max-color map))))
(setf (aref prop (incf index))
(encode-type rgb-val (color-green (standard-colormap-mult-color map))))
(setf (aref prop (incf index))
(encode-type rgb-val (color-blue (standard-colormap-max-color map))))
(setf (aref prop (incf index))
(encode-type rgb-val (color-blue (standard-colormap-mult-color map))))
(setf (aref prop (incf index))
(standard-colormap-base-pixel map))
(setf (aref prop (incf index))
(visual-info-id (standard-colormap-visual map)))
(setf (aref prop (incf index))
(let ((kill (standard-colormap-kill map)))
(etypecase kill
(symbol
(ecase kill
((nil) 0)
((:release-by-freeing-colormap) 1)))
(drawable (drawable-id kill))
(gcontext (gcontext-id kill))
(cursor (cursor-id kill))
(colormap (colormap-id kill))
(font (font-id kill))))))
(change-property window property prop :RGB_COLOR_MAP 32)))
;;; OBSOLETE
(defun get-standard-colormap (window property)
(declare (type window window)
(type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP
:RGB_GREEN_MAP :RGB_BLUE_MAP) property))
(declare (values colormap base-pixel max-color mult-color))
(let ((prop (get-property window property :type :RGB_COLOR_MAP :result-type 'vector)))
(declare (type (or null simple-vector) prop))
(when prop
(values (lookup-colormap (window-display window) (aref prop 0))
(aref prop 7) ;Base Pixel
(make-color :red (card16->rgb-val (aref prop 1)) ;Max Color
:green (card16->rgb-val (aref prop 3))
:blue (card16->rgb-val (aref prop 5)))
(make-color :red (card16->rgb-val (aref prop 2)) ;Mult color
:green (card16->rgb-val (aref prop 4))
:blue (card16->rgb-val (aref prop 6)))))))
;;; OBSOLETE
(defun set-standard-colormap (window property colormap base-pixel max-color mult-color)
(declare (type window window)
(type (member :RGB_DEFAULT_MAP :RGB_BEST_MAP :RGB_RED_MAP
:RGB_GREEN_MAP :RGB_BLUE_MAP) property)
(type colormap colormap)
(type pixel base-pixel)
(type color max-color mult-color))
(let ((prop (apply #'vector (encode-type colormap colormap)
(encode-type rgb-val (color-red max-color))
(encode-type rgb-val (color-red mult-color))
(encode-type rgb-val (color-green max-color))
(encode-type rgb-val (color-green mult-color))
(encode-type rgb-val (color-blue max-color))
(encode-type rgb-val (color-blue mult-color))
base-pixel)))
(change-property window property prop :RGB_COLOR_MAP 32)))
;;-----------------------------------------------------------------------------
;; Cut-Buffers
(defun cut-buffer (display &key (buffer 0) (type :STRING) (result-type 'string)
(transform #'card8->char) (start 0) end)
;; Return the contents of cut-buffer BUFFER
(declare (type display display)
(type (integer 0 7) buffer)
(type xatom type)
(type array-index start)
(type (or null array-index) end)
(type t result-type) ;a sequence type
(type (or null (function (integer) t)) transform))
(declare (values sequence type format bytes-after))
(let* ((root (screen-root (first (display-roots display))))
(property (aref '#(:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3
:CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7)
buffer)))
(get-property root property :type type :result-type result-type
:start start :end end :transform transform)))
;; Implement the following:
;; (defsetf cut-buffer (display &key (buffer 0) (type :string) (format 8)
;; (transform #'char->card8) (start 0) end) (data)
;; In order to avoid having to pass positional parameters to set-cut-buffer,
;; We've got to do the following. WHAT A PAIN...
#-clx-ansi-common-lisp
(define-setf-method cut-buffer (display &rest option-list)
(declare (dynamic-extent option-list))
(do* ((options (copy-list option-list))
(option options (cddr option))
(store (gensym))
(dtemp (gensym))
(temps (list dtemp))
(values (list display)))
((endp option)
(values (nreverse temps)
(nreverse values)
(list store)
`(set-cut-buffer ,store ,dtemp ,@options)
`(cut-buffer ,@options)))
(unless (member (car option) '(:buffer :type :format :start :end :transform))
(error "Keyword arg ~s isn't recognized" (car option)))
(let ((x (gensym)))
(push x temps)
(push (cadr option) values)
(setf (cadr option) x))))
(defun
#+clx-ansi-common-lisp (setf cut-buffer)
#-clx-ansi-common-lisp set-cut-buffer
(data display &key (buffer 0) (type :STRING) (format 8)
(start 0) end (transform #'char->card8))
(declare (type sequence data)
(type display display)
(type (integer 0 7) buffer)
(type xatom type)
(type (member 8 16 32) format)
(type array-index start)
(type (or null array-index) end)
(type (or null (function (integer) t)) transform))
(let* ((root (screen-root (first (display-roots display))))
(property (aref '#(:CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3
:CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7)
buffer)))
(change-property root property data type format :transform transform :start start :end end)
data))
(defun rotate-cut-buffers (display &optional (delta 1) (careful-p t))
;; Positive rotates left, negative rotates right (opposite of actual protocol request).
;; When careful-p, ensure all cut-buffer properties are defined, to prevent errors.
(declare (type display display)
(type int16 delta)
(type boolean careful-p))
(let* ((root (screen-root (first (display-roots display))))
(buffers '#(:cut_buffer0 :cut_buffer1 :cut_buffer2 :cut_buffer3
:cut_buffer4 :cut_buffer5 :cut_buffer6 :cut_buffer7)))
(when careful-p
(let ((props (list-properties root)))
(dotimes (i 8)
(unless (member (aref buffers i) props)
(setf (cut-buffer display :buffer i) "")))))
(rotate-properties root buffers delta)))
;;-----------------------------------------------------------------------------
;; Parsing geometry and color specifications
;;
;; If any value is not specified, it is returned as nil. Any illegality in
;; the parsestring will cause this function to abort and return nil.
;;
(defun parse-geometry (parsestring)
(declare (type stringable parsestring))
(declare (values (or null x) (or null y) (or null width) (or null height)
x-negative-p y-negative-p))
(setq parsestring (string parsestring))
(let ((index 0)
(len (length parsestring))
(next-index 0)
char
(x-negative nil)
(y-negative nil)
(x nil)
(y nil)
(width nil)
(height nil))
(declare (type array-index index next-index len))
(if (eql len 0)
(return-from parse-geometry))
(if (eql (aref parsestring index) #\=)
(incf index)) ; Skip leading '='.
(setq char (aref parsestring index))
(when (and (not (eql char #\+)) (not (eql char #\-)) (not (eql char #\x)))
(multiple-value-setq (width next-index)
(parse-integer parsestring :start index :junk-allowed t))
(if (eql index next-index)
(return-from parse-geometry))
(setq index next-index))
(when (eql (aref parsestring index) #\x)
(incf index)
(multiple-value-setq (height next-index)
(parse-integer parsestring :start index :junk-allowed t))
(if (eql index next-index)
(return-from parse-geometry))
(setq index next-index))
(if (eql index len)
(return-from parse-geometry (values nil nil width height nil nil)))
(setq char (aref parsestring index))
(when (or (eql char #\+) (eql char #\-))
(excl:if* (eql char #\-)
then (incf index)
(multiple-value-setq (x next-index)
(parse-integer parsestring :start index :junk-allowed t))
;; (setq x (- x))
(if (eql index next-index)
(return-from parse-geometry))
(setq index next-index)
(setq x-negative t)
else (incf index)
(multiple-value-setq (x next-index)
(parse-integer parsestring :start index :junk-allowed t))
(if (eql index next-index)
(return-from parse-geometry))
(setq index next-index))
(setq char (aref parsestring index))
(when (or (eql char #\+) (eql char #\-))
(excl:if* (eql char #\-)
then (incf index)
(multiple-value-setq (y next-index)
(parse-integer parsestring :start index :junk-allowed t))
;; (setq y (- y))
(if (eql index next-index)
(return-from parse-geometry))
(setq index next-index)
(setq y-negative t)
else (incf index)
(multiple-value-setq (y next-index)
(parse-integer parsestring :start index :junk-allowed t))
(if (eql index next-index)
(return-from parse-geometry))
(setq index next-index))))
(if (not (eql index (length parsestring)))
(return-from parse-geometry))
(values x y width height x-negative y-negative)))
;;
;; Returns nil if the color specification is illegal or is not found by
;; the server. See C Xlib manual section 10.4 for documentation.
;;
(defun parse-color (colormap spec)
(declare (type colormap colormap)
(type stringable spec))
(declare (values (or null true-color)))
(setq spec (string spec))
(let ((len (length spec)))
(declare (type array-index len))
(if (eql len 0)
(return-from parse-color))
(cond ((eq (aref spec 0) #\#)
(decf len)
(if (and (not (eql len 3)) (not (eql len 6)) (not (eql len 9))
(not (eql len 12)))
(return-from parse-color))
(setq len (the array-index (/ len 3)))
(let ((start 1) red green blue
(multiplier (expt 16 (- 4 len))))
(declare (type array-index start)
(type (integer 1 4096) multiplier))
(setq red (parse-integer spec :start start
:end (+ start len)
:radix 16))
(incf start len)
(setq green (parse-integer spec :start start
:end (+ start len)
:radix 16))
(incf start len)
(setq blue (parse-integer spec :start start
:end (+ start len)
:radix 16))
(make-color :red (card16->rgb-val (* red multiplier))
:green (card16->rgb-val (* green multiplier))
:blue (card16->rgb-val (* blue multiplier)))))
(t
(handler-case
(lookup-color colormap spec)
(name-error ()
(return-from parse-color)))))))
;;
;; Given a top level window (immediate child of the root window), find the
;; actual client window. (Most window managers reparent client windows).
;; Return the argument if we can't find one, or aren't sure.
;;
(defun wm-client-window (window)
(if (get-property window :WM_STATE)
window
(or (try-children window) window)))
(defun try-children (window)
(let ((children (query-tree window)))
(dolist (child children)
(when (get-property child :WM_STATE)
(return-from try-children child)))
(dolist (child children)
(let ((result (try-children child)))
(when result
(return-from try-children result))))))