forked from stumpwm/stumpwm
-
Notifications
You must be signed in to change notification settings - Fork 0
/
test-wm.lisp
225 lines (209 loc) · 9.5 KB
/
test-wm.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
(defpackage :test-wm (:use :cl))
(in-package :test-wm)
(defparameter *current-test-num* 0)
(defparameter *tests* nil)
(defmacro define-test ((dpy screen) &body body)
(let ((name (intern (format nil "TEST-~d" *current-test-num*))))
`(progn
(defun ,name (,dpy ,screen)
(format t "Starting test ~d~%" ,*current-test-num*)
,@body
(format t "Done.~%"))
(push ',name *tests*)
(incf *current-test-num*))))
(define-test (dpy screen)
(let ((w (xlib:create-window :parent (xlib:screen-root screen)
:x 10 :y 10 :width 100 :height 100 :border-width 1)))
(xlib:map-window w)
(xlib:display-finish-output dpy)
(xlib:destroy-window w)
(xlib:display-finish-output dpy)))
(define-test (dpy screen)
(let ((w (xlib:create-window :parent (xlib:screen-root screen)
:x 10 :y 10 :width 100 :height 100 :border-width 1)))
(xlib:map-window w)
(xlib:display-finish-output dpy)
(sleep 1)
(setf (xlib:window-priority w) :above)
;; (setf (xlib:drawable-border-width w) 3)
(xlib:display-finish-output dpy)
(xlib:destroy-window w)
(xlib:display-finish-output dpy)))
(define-test (dpy screen)
(let ((windows (loop for i from 0 to 100
collect (let ((w (xlib:create-window :parent (xlib:screen-root screen)
:x 10 :y 10 :width 100 :height 100 :border-width 1)))
(xlib:map-window w)
(xlib:display-finish-output dpy)
(setf (xlib:window-priority w) :above)
w))))
(xlib:display-finish-output dpy)
(loop for i in windows do
(xlib:unmap-window i))
(xlib:display-finish-output dpy)
(sleep 3)
(loop for i in windows do
(xlib:destroy-window i))))
;; (define-test (dpy screen)
;; (let ((windows (loop for i from 0 to 100
;; collect (let ((w (xlib:create-window :parent (xlib:screen-root screen)
;; :x 10 :y 10 :width 100 :height 100 :border-width 1)))
;; (xlib:map-window w)
;; (xlib:display-finish-output dpy)
;; (setf (xlib:window-priority w) :above)
;; w))))
;; (xlib:display-finish-output dpy)
;; (loop for i in windows do
;; (xlib:unmap-window i))
;; (xlib:display-finish-output dpy)
;; (sleep 3)
;; (loop for i in windows do
;; (xlib:destroy-window i))))
(define-test (dpy screen)
(let ((w (xlib:create-window :parent (xlib:screen-root screen)
:x 10 :y 10 :width 100 :height 100 :border-width 1)))
(xlib:map-window w)
(setf (xlib:window-priority w) :above)
(xlib:display-finish-output dpy)
(xlib:unmap-window w)
(setf (xlib:drawable-x w) 5)
(xlib:display-finish-output dpy)))
(define-test (dpy screen)
;; create a window and set its role after being mapped
(let ((w (xlib:create-window :parent (xlib:screen-root screen)
:x 10 :y 10 :width 100 :height 100 :border-width 1)))
(xlib:map-window w)
(xlib:display-finish-output dpy)
(sleep 1)
(xlib:change-property w
:WM_WINDOW_ROLE
(map 'list 'char-code "rad dude")
:string
8)
(xlib:display-finish-output dpy)
(sleep 10)))
(defun break-display-xid-cache ()
(labels ((make-win (dpy)
(xlib:create-window :parent (xlib:screen-root (first (xlib:display-roots dpy))) :x 0 :y 0 :width 50 :height 50))
(make-pixmap (window)
(xlib:create-pixmap :width (random 100) :height (random 100) :depth 8 :drawable window))
(first-pass (dpy)
;; Open a fresh connection. Create a window and a pixmap.
(let* ((dpy2 (xlib:open-default-display))
(window (make-win dpy2))
(pixmap (make-pixmap window)))
;; make the pixmap the window's icon pixmap hint.
(setf (xlib:wm-hints window) (xlib:make-wm-hints :icon-pixmap pixmap))
(format t "Window ID: ~s pixmap ID: ~s~%" (xlib:window-id window) (xlib:pixmap-id pixmap))
(xlib:map-window window)
(xlib:display-finish-output dpy2)
(sleep 1)
;; On the old connection, list the root window children
;; and the icon pixmap hint to cache their XIDs.
(loop for w in (xlib:query-tree (xlib:screen-root (first (xlib:display-roots dpy))))
for hints = (xlib:wm-hints w)
when hints
do (format t "top level window id: ~s | icon pixmap hint: ~s~%" (xlib:window-id w) (xlib:wm-hints-icon-pixmap hints)))
(xlib:close-display dpy2)))
(second-pass (dpy)
;; Open a fresh connection and create 2 windows.
(let* ((dpy2 (xlib:open-default-display))
(window1 (make-win dpy2))
(window2 (make-win dpy2)))
(format t "Window#1 ID: ~s Window#2 ID: ~s~%" (xlib:window-id window1) (xlib:window-id window2))
(xlib:display-finish-output dpy2)
;; On the old connection, list the root window children
;; and note the second window is erroneously a pixmap
;; due to too agressive caching in clx.
(loop for w in (xlib:query-tree (xlib:screen-root (first (xlib:display-roots dpy))))
do (format t "window: ~s~%" w))
(xlib:close-display dpy2))))
(let ((dpy (xlib:open-default-display)))
(first-pass dpy)
(second-pass dpy)
(xlib:close-display dpy))))
(defun test-wm-class (map-p)
"Test the robustness of CLX's wm-class function. If MAP-P is T then
map the window. Useful if you want to test the running window
manager."
(labels ((test-it (w &rest strings)
(xlib:change-property w :WM_CLASS
(apply #'concatenate '(vector xlib:card8)
strings)
:string 8)
(print (multiple-value-list (xlib:get-wm-class w)))
;; give the wm a chance to try out the value
(when map-p
(sleep 1)))
(convert (s)
(map '(vector xlib:card8) #'xlib:char->card8 s)))
(let* ((dpy (xlib:open-default-display))
(screen (first (xlib:display-roots dpy)))
(root (xlib:screen-root screen))
(win (xlib:create-window :parent root :x 0 :y 0 :width 100 :height 100 :background (xlib:screen-white-pixel screen))))
(unwind-protect
(when map-p
(xlib:map-window win))
(progn
(test-it win
(convert "string 1")
#(0)
(convert "string 2")
#(0))
(test-it win
(convert "Manifold X")
#(0)
(convert "Powercoupling Y")
#(0)
(convert "Magistrate Z")
#(0))
(test-it win
#(0))
(test-it win)
(test-it win
#(0)
(convert "checkity checkfoo"))
(test-it win
(convert "ohh bother")
#(0)
(convert "Magic Fudge"))
(test-it win
(convert "You Gellin?")
#(0))
(test-it win
(convert "Blinky The Cloon")))
(xlib:close-display dpy))
(values))))
(defun get-wm-hints ()
"simias reports that on sbcl the wm-hints property is all screwed up
when he runs an x server on 32 or 64bit freebsd and runs any x client
on a fedora 32bit, connecting through an ssh tunnel. clisp works fine.
so run this function on clisp and sbcl and compare the numbers. This
assumes you're running a reparenting wm."
(let ((dpy (xlib:open-default-display)))
(write-line "you gotta have some windows open for this to work.")
(dolist (top (xlib:query-tree (xlib:screen-root (first (xlib:display-roots dpy)))))
(dolist (w (xlib:query-tree top))
(format t "~s ~s: ~s~%" w (xlib:wm-name w) (xlib:get-property w :WM_HINTS :type :WM_HINTS :result-type 'vector))))
(xlib:close-display dpy)))
(defun parse-display-string (display)
"Parse an X11 DISPLAY string and return the host and display from it."
(let* ((colon (position #\: display))
(host (subseq display 0 colon))
(rest (subseq display (1+ colon)))
(dot (position #\. rest))
(num (parse-integer (subseq rest 0 dot))))
(values host num)))
(defvar *dpy* nil)
(defun test-wm (display-str)
(multiple-value-bind (host display) (parse-display-string display-str)
(setf *dpy* (xlib:open-display host :display display :protocol nil))
(let* ((dpy *dpy*)
(screen (first (xlib:display-roots dpy))))
(unwind-protect
(progn
;; (dolist (i *tests*)
;; (funcall i dpy screen))
(funcall (car *tests*) dpy screen)
)
(xlib:close-display *dpy*)))))