Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 646 lines (594 sloc) 28.569 kB
c81a732 restructure almost all the code in core.lisp into seperate files.
Shawn authored
1 ;; Copyright (C) 2003-2008 Shawn Betts
2 ;;
3 ;; This file is part of stumpwm.
4 ;;
5 ;; stumpwm is free software; you can redistribute it and/or modify
6 ;; it under the terms of the GNU General Public License as published by
7 ;; the Free Software Foundation; either version 2, or (at your option)
8 ;; any later version.
9
10 ;; stumpwm is distributed in the hope that it will be useful,
11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 ;; GNU General Public License for more details.
14
15 ;; You should have received a copy of the GNU General Public License
16 ;; along with this software; see the file COPYING. If not, write to
17 ;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
18 ;; Boston, MA 02111-1307 USA
19
20 ;; Commentary:
21 ;;
22 ;; Event handling.
23 ;;
24 ;; Code:
25
26 (in-package #:stumpwm)
27
28 ;;; Event handler functions
29
30 (defparameter *event-fn-table* (make-hash-table)
31 "A hash of event types to functions")
32
33 (defmacro define-stump-event-handler (event keys &body body)
34 (let ((fn-name (gensym))
35 (event-slots (gensym)))
36 `(labels ((,fn-name (&rest ,event-slots &key ,@keys &allow-other-keys)
37 (declare (ignore ,event-slots))
38 ,@body))
39 (setf (gethash ,event *event-fn-table*) #',fn-name))))
40
41 ;(define-stump-event-handler :map-notify (event-window window override-redirect-p)
42 ; )
43
44 (defun handle-mode-line-window (xwin x y width height)
45 (declare (ignore width))
46 (let ((ml (find-mode-line-window xwin)))
47 (when ml
48 (setf (xlib:drawable-height xwin) height)
49 (update-mode-line-position ml x y)
50 (resize-mode-line ml)
51 (sync-mode-line ml))))
52
53 (defun handle-unmanaged-window (xwin x y width height border-width value-mask)
54 "Call this function for windows that stumpwm isn't
55 managing. Basically just give the window what it wants."
56 (labels ((has-x (mask) (= 1 (logand mask 1)))
57 (has-y (mask) (= 2 (logand mask 2)))
58 (has-w (mask) (= 4 (logand mask 4)))
59 (has-h (mask) (= 8 (logand mask 8)))
60 (has-bw (mask) (= 16 (logand mask 16)))
61 ;; (has-stackmode (mask) (= 64 (logand mask 64)))
62 )
63 (xlib:with-state (xwin)
64 (when (has-x value-mask)
65 (setf (xlib:drawable-x xwin) x))
66 (when (has-y value-mask)
67 (setf (xlib:drawable-y xwin) y))
68 (when (has-h value-mask)
69 (setf (xlib:drawable-height xwin) height))
70 (when (has-w value-mask)
71 (setf (xlib:drawable-width xwin) width))
72 (when (has-bw value-mask)
73 (setf (xlib:drawable-border-width xwin) border-width)))))
74
75 (defun update-configuration (win)
76 ;; Send a synthetic configure-notify event so that the window
77 ;; knows where it is onscreen.
78 (xwin-send-configuration-notify (window-xwin win)
79 (xlib:drawable-x (window-parent win))
80 (xlib:drawable-y (window-parent win))
81 (window-width win) (window-height win) 0))
82
83 (define-stump-event-handler :configure-request (stack-mode #|parent|# window #|above-sibling|# x y width height border-width value-mask)
dfe2723 fix fullscreen in float-group
Shawn authored
84 (labels ((has-x () (= 1 (logand value-mask 1)))
85 (has-y () (= 2 (logand value-mask 2)))
86 (has-w () (= 4 (logand value-mask 4)))
87 (has-h () (= 8 (logand value-mask 8)))
88 (has-stackmode () (= 64 (logand value-mask 64))))
3ba1e2d add a group API and isolate all tile-group related code within the api
Shawn authored
89 ;; Grant the configure request but then maximize the window after the granting.
90 (dformat 3 "CONFIGURE REQUEST ~@{~S ~}~%" stack-mode window x y width height border-width value-mask)
91 (let ((win (find-window window)))
92 (cond
93 (win
dfe2723 fix fullscreen in float-group
Shawn authored
94 (when (or (has-w) (has-h) (has-stackmode))
95 ;; FIXME: I don't know why we need to clear the urgency bit
96 ;; here, but the old code would anytime a resize or raise
97 ;; request came in, so keep doing it. -sabetts
98 (when (window-urgent-p win)
99 (window-clear-urgency win)))
100 (when (or (has-x) (has-y))
3ba1e2d add a group API and isolate all tile-group related code within the api
Shawn authored
101 (group-move-request (window-group win) win x y :parent))
dfe2723 fix fullscreen in float-group
Shawn authored
102 (when (or (has-w) (has-h))
103 (group-resize-request (window-group win) win width height))
104 (when (has-stackmode)
105 (group-raise-request (window-group win) win stack-mode))
106 ;; Just to be on the safe side, hit the client with a fake
107 ;; configure event. The ICCCM says we have to do this at
108 ;; certain times; exactly when, I've sorta forgotten.
109 (update-configuration win))
110 ((handle-mode-line-window win x y width height))
3ba1e2d add a group API and isolate all tile-group related code within the api
Shawn authored
111 (t (handle-unmanaged-window window x y width height border-width value-mask))))))
c81a732 restructure almost all the code in core.lisp into seperate files.
Shawn authored
112
113 (define-stump-event-handler :configure-notify (stack-mode #|parent|# window #|above-sibling|# x y width height border-width value-mask)
e66214c fix the pixmap/window error for sbcl and clisp
Shawn authored
114 (dformat 4 "CONFIGURE NOTIFY ~@{~S ~}~%" stack-mode window x y width height border-width value-mask)
115 (let ((screen (find-screen window)))
116 (when screen
117 (let ((old-heads (copy-list (screen-heads screen))))
118 (setf (screen-heads screen) nil)
119 (let ((new-heads (make-screen-heads screen (screen-root screen))))
120 (setf (screen-heads screen) old-heads)
121 (cond
122 ((equalp old-heads new-heads)
123 (dformat 3 "Bogus configure-notify on root window of ~S~%" screen) t)
124 (t
125 (dformat 1 "Updating Xinerama configuration for ~S.~%" screen)
126 (if new-heads
127 (progn
128 (scale-screen screen new-heads)
3ba1e2d add a group API and isolate all tile-group related code within the api
Shawn authored
129 (mapc 'group-add-head (screen-groups screen))
e66214c fix the pixmap/window error for sbcl and clisp
Shawn authored
130 (update-mode-lines screen))
131 (dformat 1 "Invalid configuration! ~S~%" new-heads)))))))))
c81a732 restructure almost all the code in core.lisp into seperate files.
Shawn authored
132
133 (define-stump-event-handler :map-request (parent send-event-p window)
134 (unless send-event-p
135 ;; This assumes parent is a root window and it should be.
136 (dformat 3 "map request: ~a ~a ~a~%" window parent (find-window window))
137 (let ((screen (find-screen parent))
138 (win (find-window window))
139 (wwin (find-withdrawn-window window)))
140 ;; only absorb it if it's not already managed (it could be iconic)
141 (cond
142 (win (dformat 1 "map request for mapped window ~a~%" win))
143 ((eq (xwin-type window) :dock)
144 (when wwin
145 (setf screen (window-screen wwin)))
146 (dformat 1 "window is dock-type. attempting to place in mode-line.")
147 (place-mode-line-window screen window)
148 ;; Some panels are broken and only set the dock type after they map and withdraw.
149 (when wwin
150 (setf (screen-withdrawn-windows screen) (delete wwin (screen-withdrawn-windows screen))))
151 t)
152 (wwin (restore-window wwin))
153 ((xlib:get-property window :_KDE_NET_WM_SYSTEM_TRAY_WINDOW_FOR)
154 ;; Do nothing if this is a systray window (the system tray
155 ;; will handle it, if there is one, and, if there isn't the
156 ;; user doesn't want this popping up as a managed window
157 ;; anyway.
158 t)
159 (t
160 (let ((window (process-mapped-window screen window)))
3ba1e2d add a group API and isolate all tile-group related code within the api
Shawn authored
161 (group-raise-request (window-group window) window :map)))))))
c81a732 restructure almost all the code in core.lisp into seperate files.
Shawn authored
162
163 (define-stump-event-handler :unmap-notify (send-event-p event-window window #|configure-p|#)
164 ;; There are two kinds of unmap notify events: the straight up
165 ;; ones where event-window and window are the same, and
166 ;; substructure unmap events when the event-window is the parent
167 ;; of window.
168 (dformat 2 "UNMAP: ~s ~s ~a~%" send-event-p (not (xlib:window-equal event-window window)) (find-window window))
169 (unless (and (not send-event-p)
170 (not (xlib:window-equal event-window window)))
171 (let ((window (find-window window)))
172 ;; if we can't find the window then there's nothing we need to
173 ;; do.
174 (when window
175 (if (plusp (window-unmap-ignores window))
176 (progn
177 (dformat 3 "decrement ignores! ~d~%" (window-unmap-ignores window))
178 (decf (window-unmap-ignores window)))
179 (withdraw-window window))))))
180
181 ;;(define-stump-event-handler :create-notify (#|window parent x y width height border-width|# override-redirect-p))
182 ;; (unless (or override-redirect-p
183 ;; (internal-window-p (window-screen window) window))
184 ;; (process-new-window (window-screen window) window))
185 ;; (run-hook-with-args *new-window-hook* window)))
186
187 (define-stump-event-handler :destroy-notify (send-event-p event-window window)
188 (unless (or send-event-p
189 (xlib:window-equal event-window window))
190 ;; Ignore structure destroy notifies and only
191 ;; use substructure destroy notifiers. This way
192 ;; event-window is the window's parent.
193 (let ((win (or (find-window window)
194 (find-withdrawn-window window))))
195 (if win
196 (destroy-window win)
197 (progn
198 (let ((ml (find-mode-line-window window)))
199 (when ml (destroy-mode-line-window ml))))))))
200
9fe89bb fix :key-seq type to work with read-from-keymap
Shawn authored
201 (defun read-from-keymap (kmaps &optional update-fn)
202 "Read a sequence of keys from the user, guided by the keymaps,
203 KMAPS and return the binding or nil if the user hit an unbound sequence.
c81a732 restructure almost all the code in core.lisp into seperate files.
Shawn authored
204
205 The Caller is responsible for setting up the input focus."
206 (let* ((code-state (read-key-no-modifiers))
207 (code (car code-state))
208 (state (cdr code-state)))
9fe89bb fix :key-seq type to work with read-from-keymap
Shawn authored
209 (handle-keymap kmaps code state nil nil update-fn)))
c81a732 restructure almost all the code in core.lisp into seperate files.
Shawn authored
210
1ebb8bf active bindings now change based on the current group
Shawn authored
211 (defun handle-keymap (kmaps code state key-seq grab update-fn)
c81a732 restructure almost all the code in core.lisp into seperate files.
Shawn authored
212 "Find the command mapped to the (code state) and return it."
1ebb8bf active bindings now change based on the current group
Shawn authored
213 ;; KMAPS is a list of keymaps that may match the user's key sequence.
214 (dformat 1 "Awaiting key ~a~%" kmaps)
215 (let* ((key (code-state->key code state))
216 (key-seq (cons key key-seq))
217 (bindings (mapcar (lambda (m)
218 (lookup-key m key))
219 (dereference-kmaps kmaps)))
220 ;; if the first non-nil thing is another keymap, then grab
221 ;; all the keymaps and recurse on them. If the first one is a
222 ;; command, then we're done.
223 (match (find-if-not 'null bindings)))
224 (dformat 1 "key-press: ~S ~S ~S~%" key state match)
225 (run-hook-with-args *key-press-hook* key key-seq match)
226 (when update-fn
227 (funcall update-fn key-seq))
671ff72 change kmaps from a hashtable to a struct containing a list
Shawn authored
228 (cond ((kmap-or-kmap-symbol-p match)
1ebb8bf active bindings now change based on the current group
Shawn authored
229 (when grab
230 (grab-pointer (current-screen)))
231 (let* ((code-state (read-key-no-modifiers))
232 (code (car code-state))
233 (state (cdr code-state)))
234 (unwind-protect
671ff72 change kmaps from a hashtable to a struct containing a list
Shawn authored
235 (handle-keymap (remove-if-not 'kmap-or-kmap-symbol-p bindings) code state key-seq nil update-fn)
1ebb8bf active bindings now change based on the current group
Shawn authored
236 (when grab (ungrab-pointer)))))
237 (match
238 (values match key-seq))
239 ((and (find key (list (kbd "?")
240 (kbd "C-h"))
241 :test 'equalp))
242 (apply 'display-bindings-for-keymaps (reverse (cdr key-seq)) (dereference-kmaps kmaps))
243 (values t key-seq))
244 (t
245 (values nil key-seq)))))
246
247 (defun top-maps (&optional (group (current-group)))
248 "Return all top level keymaps that are active."
0ea16c4 rearrange the top level binding order.
Shawn authored
249 (append
250 ;; The plain jane top map is first because that's where users are
251 ;; going to throw in their universally accessible customizations
252 ;; which we don't want groups or minor modes shadowing them.
253 (list '*top-map*)
254 ;; TODO: Minor Mode maps go here
255 ;; lastly, group maps. Last because minor modes should be able to
256 ;; shadow a group's default bindings.
257 (loop for i in *group-top-maps*
258 when (typep group (first i))
259 collect (second i))))
c81a732 restructure almost all the code in core.lisp into seperate files.
Shawn authored
260
261 (define-stump-event-handler :key-press (code state #|window|#)
262 (labels ((get-cmd (code state)
263 (with-focus (screen-key-window (current-screen))
1ebb8bf active bindings now change based on the current group
Shawn authored
264 (handle-keymap (top-maps) code state nil t nil))))
c81a732 restructure almost all the code in core.lisp into seperate files.
Shawn authored
265 (unwind-protect
266 ;; modifiers can sneak in with a race condition. so avoid that.
267 (unless (is-modifier code)
268 (multiple-value-bind (cmd key-seq) (get-cmd code state)
269 (cond
270 ((eq cmd t))
271 (cmd
272 (unmap-message-window (current-screen))
9ff9e45 interactive-command renamed to eval-command; new argument "interactivep"
Lionel Flandrin authored
273 (eval-command cmd t) t)
c81a732 restructure almost all the code in core.lisp into seperate files.
Shawn authored
274 (t (message "~{~a ~}not bound." (mapcar 'print-key (nreverse key-seq))))))))))
275
276 (defun bytes-to-window (bytes)
277 "A sick hack to assemble 4 bytes into a 32 bit number. This is
278 because ratpoison sends the rp_command_request window in 8 byte
279 chunks."
280 (+ (first bytes)
281 (ash (second bytes) 8)
282 (ash (third bytes) 16)
283 (ash (fourth bytes) 24)))
284
285 (defun handle-rp-commands (root)
286 "Handle a ratpoison style command request."
287 (labels ((one-cmd ()
288 (multiple-value-bind (win type format bytes-after) (xlib:get-property root :rp_command_request :end 4 :delete-p t)
289 (declare (ignore type format))
290 (setf win (xlib::lookup-window *display* (bytes-to-window win)))
291 (when (xlib:window-p win)
292 (let* ((data (xlib:get-property win :rp_command))
293 (interactive-p (car data))
294 (cmd (map 'string 'code-char (nbutlast (cdr data)))))
295 (declare (ignore interactive-p))
9ff9e45 interactive-command renamed to eval-command; new argument "interactivep"
Lionel Flandrin authored
296 (eval-command cmd)
c81a732 restructure almost all the code in core.lisp into seperate files.
Shawn authored
297 (xlib:change-property win :rp_command_result (map 'list 'char-code "0TODO") :string 8)
298 (xlib:display-finish-output *display*)))
299 bytes-after)))
300 (loop while (> (one-cmd) 0))))
301
302 (defun handle-stumpwm-commands (root)
303 "Handle a StumpWM style command request."
304 (let* ((win root)
305 (screen (find-screen root))
306 (data (xlib:get-property win :stumpwm_command :delete-p t))
307 (cmd (bytes-to-string data)))
308 (let ((msgs (screen-last-msg screen))
309 (hlts (screen-last-msg-highlights screen))
310 (*executing-stumpwm-command* t))
311 (setf (screen-last-msg screen) '()
312 (screen-last-msg-highlights screen) '())
9ff9e45 interactive-command renamed to eval-command; new argument "interactivep"
Lionel Flandrin authored
313 (eval-command cmd)
689a13c Support window urgency notification.
Jonathan Moore Liles authored
314 (xlib:change-property win :stumpwm_command_result
c81a732 restructure almost all the code in core.lisp into seperate files.
Shawn authored
315 (string-to-bytes (format nil "~{~{~a~%~}~}" (nreverse (screen-last-msg screen))))
316 :string 8)
317 (setf (screen-last-msg screen) msgs
318 (screen-last-msg-highlights screen) hlts))
319 (xlib:display-finish-output *display*)))
320
7fcaf21 Clean up urgency handling. Properly handle _NET_WM_STATE_DEMANDS_ATTE…
Jonathan Moore Liles authored
321 (defun maybe-set-urgency (window)
322 (when (and (window-urgent-p window)
323 (not (find window (screen-urgent-windows (window-screen window)))))
324 (when (register-urgent-window window)
325 (run-hook-with-args *urgent-window-hook* window))))
326
5673a35 use safe-atom-name to convert IDs to atoms
Shawn authored
327 (defun safe-atom-name (n)
328 "Return the name of the atom with atom-id N or nil if there isn't one."
329 (handler-case
330 (xlib:atom-name *display* n)
331 (xlib:atom-error ()
332 nil)))
333
16f85c4 in update-window-properties, run :_NET_WM_STATE's property data throu…
Shawn authored
334 (defun safe-bytes-to-atoms (list)
335 "Return a list of atoms from list. Any number that cannot be
336 converted to an atom is removed."
337 (loop for p in list
338 when (typep p '(unsigned-byte 29))
5673a35 use safe-atom-name to convert IDs to atoms
Shawn authored
339 collect (safe-atom-name p)))
16f85c4 in update-window-properties, run :_NET_WM_STATE's property data throu…
Shawn authored
340
c81a732 restructure almost all the code in core.lisp into seperate files.
Shawn authored
341 (defun update-window-properties (window atom)
342 (case atom
343 (:wm_name
344 (setf (window-title window) (xwin-name (window-xwin window)))
345 ;; Let the mode line know about the new name.
346 (update-all-mode-lines))
347 (:wm_normal_hints
9155760 normalize the wm-normal-hints structure whenever it is requested from…
Shawn authored
348 (setf (window-normal-hints window) (get-normalized-normal-hints (window-xwin window))
c81a732 restructure almost all the code in core.lisp into seperate files.
Shawn authored
349 (window-type window) (xwin-type (window-xwin window)))
350 (dformat 4 "new hints: ~s~%" (window-normal-hints window))
d066615 add window-sync generic function and use it in a few places
Shawn authored
351 (window-sync window :normal-hints))
689a13c Support window urgency notification.
Jonathan Moore Liles authored
352 (:wm_hints
7fcaf21 Clean up urgency handling. Properly handle _NET_WM_STATE_DEMANDS_ATTE…
Jonathan Moore Liles authored
353 (maybe-set-urgency window))
c81a732 restructure almost all the code in core.lisp into seperate files.
Shawn authored
354 (:wm_class
355 (setf (window-class window) (xwin-class (window-xwin window))
356 (window-res window) (xwin-res-name (window-xwin window))))
357 (:wm_window_role
358 (setf (window-role window) (xwin-role (window-xwin window))))
359 (:wm_transient_for
360 (setf (window-type window) (xwin-type (window-xwin window)))
d066615 add window-sync generic function and use it in a few places
Shawn authored
361 (window-sync window :type))
c81a732 restructure almost all the code in core.lisp into seperate files.
Shawn authored
362 (:_NET_WM_STATE
16f85c4 in update-window-properties, run :_NET_WM_STATE's property data throu…
Shawn authored
363 ;; Some clients put really big numbers in the list causing
364 ;; atom-name to fail, so filter out anything that can't be
365 ;; converted into an atom.
366 (dolist (p (safe-bytes-to-atoms
367 (xlib:get-property (window-xwin window) :_NET_WM_STATE)))
368 (case p
c81a732 restructure almost all the code in core.lisp into seperate files.
Shawn authored
369 (:_NET_WM_STATE_FULLSCREEN
689a13c Support window urgency notification.
Jonathan Moore Liles authored
370 ;; Client is broken and sets this property itself instead of sending a
371 ;; client request to the root window. Try to make do.
c81a732 restructure almost all the code in core.lisp into seperate files.
Shawn authored
372 ;; FIXME: what about when properties are REMOVED?
373 (update-fullscreen window 1)))))))
374
375 (define-stump-event-handler :property-notify (window atom state)
376 (dformat 2 "property notify ~s ~s ~s~%" window atom state)
377 (case atom
378 (:rp_command_request
379 ;; we will only find the screen if window is a root window, which
380 ;; is the only place we listen for ratpoison commands.
381 (let* ((screen (find-screen window)))
382 (when (and (eq state :new-value)
383 screen)
384 (handle-rp-commands window))))
385 (:stumpwm_command
386 ;; RP commands are too weird and problematic, KISS.
387 (let* ((screen (find-screen window)))
388 (when (and (eq state :new-value)
389 screen)
390 (handle-stumpwm-commands window))))
391 (t
392 (let ((window (find-window window)))
393 (when window
394 (update-window-properties window atom))))))
395
396 (define-stump-event-handler :mapping-notify (request start count)
397 ;; We could be a bit more intelligent about when to update the
398 ;; modifier map, but I don't think it really matters.
399 (xlib:mapping-notify *display* request start count)
400 (update-modifier-map)
401 (sync-keys))
402
403 (define-stump-event-handler :selection-request (requestor property selection target time)
404 (send-selection requestor property selection target time))
405
406 (define-stump-event-handler :selection-clear ()
407 (setf *x-selection* nil))
408
409 (defun find-message-window-screen (win)
410 "Return the screen, if any, that message window WIN belongs."
411 (dolist (screen *screen-list*)
412 (when (xlib:window-equal (screen-message-window screen) win)
413 (return screen))))
414
415 (defun draw-cross (screen window x y width height)
416 (xlib:draw-line window
417 (screen-frame-outline-gc screen)
418 x y
419 width height
420 t)
421 (xlib:draw-line window
422 (screen-frame-outline-gc screen)
423 x (+ y height)
424 (+ x width) y))
425
426 (define-stump-event-handler :exposure (window x y width height count)
427 (let (screen ml)
428 (when (zerop count)
429 (cond
430 ((setf screen (find-screen window))
431 ;; root exposed
3ba1e2d add a group API and isolate all tile-group related code within the api
Shawn authored
432 (group-root-exposure (screen-current-group screen)))
c81a732 restructure almost all the code in core.lisp into seperate files.
Shawn authored
433 ((setf screen (find-message-window-screen window))
434 ;; message window exposed
435 (if (plusp (screen-ignore-msg-expose screen))
436 (decf (screen-ignore-msg-expose screen))
437 (redraw-current-message screen)))
438 ((setf ml (find-mode-line-window window))
439 (setf screen (mode-line-screen ml))
440 (redraw-mode-line ml t)))
441 ;; Show the area.
442 (when (and *debug-expose-events* screen)
443 (draw-cross screen window x y width height)))))
444
445 (define-stump-event-handler :reparent-notify (window parent)
446 (let ((win (find-window window)))
447 (when (and win
448 (not (xlib:window-equal parent (window-parent win))))
449 ;; reparent it back
450 (unless (eq (xlib:window-map-state (window-xwin win)) :unmapped)
451 (incf (window-unmap-ignores win)))
452 (xlib:reparent-window (window-xwin win) (window-parent win) 0 0))))
453
454 ;;; Fullscreen functions
455
456 (defun activate-fullscreen (window)
457 (dformat 2 "client requests to go fullscreen~%")
458 (add-wm-state (window-xwin window) :_NET_WM_STATE_FULLSCREEN)
459 (setf (window-fullscreen window) t)
460 (focus-window window))
461
462 (defun deactivate-fullscreen (window)
463 (setf (window-fullscreen window) nil)
464 (dformat 2 "client requests to leave fullscreen~%")
465 (remove-wm-state (window-xwin window) :_NET_WM_STATE_FULLSCREEN)
f121d90 implement a basic floating group
Shawn authored
466 (update-decoration window)
c81a732 restructure almost all the code in core.lisp into seperate files.
Shawn authored
467 (update-mode-lines (current-screen)))
468
469 (defun update-fullscreen (window action)
470 (let ((fullscreen-p (window-fullscreen window)))
471 (case action
472 (0 ; _NET_WM_STATE_REMOVE
473 (when fullscreen-p
474 (deactivate-fullscreen window)))
475 (1 ; _NET_WM_STATE_ADD
476 (unless fullscreen-p
477 (activate-fullscreen window)))
478 (2 ; _NET_WM_STATE_TOGGLE
479 (if fullscreen-p
480 (deactivate-fullscreen window)
481 (activate-fullscreen window))))))
482
3ba1e2d add a group API and isolate all tile-group related code within the api
Shawn authored
483 (defun maybe-map-window (window)
d1d1059 fix maybe-map-window
Shawn authored
484 (if (deny-request-p window *deny-map-request*)
485 (unless *suppress-deny-messages*
3ba1e2d add a group API and isolate all tile-group related code within the api
Shawn authored
486 (if (eq (window-group window) (current-group))
487 (echo-string (window-screen window) (format nil "'~a' denied map request" (window-name window)))
488 (echo-string (window-screen window) (format nil "'~a' denied map request in group ~a" (window-name window) (group-name (window-group window))))))
489 (frame-raise-window (window-group window) (window-frame window) window
490 (if (eq (window-frame window)
491 (tile-group-current-frame (window-group window)))
492 t nil))))
493
c81a732 restructure almost all the code in core.lisp into seperate files.
Shawn authored
494 (defun maybe-raise-window (window)
495 (if (deny-request-p window *deny-raise-request*)
496 (unless (or *suppress-deny-messages*
497 ;; don't mention windows that are already visible
3ba1e2d add a group API and isolate all tile-group related code within the api
Shawn authored
498 (group-window-visible-p (window-group window) window))
c81a732 restructure almost all the code in core.lisp into seperate files.
Shawn authored
499 (if (eq (window-group window) (current-group))
500 (echo-string (window-screen window) (format nil "'~a' denied raise request" (window-name window)))
501 (echo-string (window-screen window) (format nil "'~a' denied raise request in group ~a" (window-name window) (group-name (window-group window))))))
502 (focus-all window)))
503
504 (define-stump-event-handler :client-message (window type #|format|# data)
505 (dformat 2 "client message: ~s ~s~%" type data)
506 (case type
507 (:_NET_CURRENT_DESKTOP ;switch desktop
508 (let* ((screen (find-screen window))
509 (n (elt data 0))
510 (group (and screen
511 (< n (length (screen-groups screen)))
512 (elt (sort-groups screen) n))))
513 (when group
514 (switch-to-group group))))
515 (:_NET_WM_DESKTOP ;move window to desktop
516 (let* ((our-window (find-window window))
517 (screen (when our-window
518 (window-screen our-window)))
519 (n (elt data 0))
520 (group (and screen
521 (< n (length (screen-groups screen)))
522 (elt (sort-groups screen) n))))
523 (when (and our-window group)
524 (move-window-to-group our-window group))))
525 (:_NET_ACTIVE_WINDOW
526 (let ((our-window (find-window window))
527 (source (elt data 0)))
528 (when our-window
529 (if (= source 2) ;request is from a pager
530 (focus-all our-window)
531 (maybe-raise-window our-window)))))
532 (:_NET_CLOSE_WINDOW
533 (let ((our-window (find-window window)))
534 (when our-window
535 (delete-window our-window))))
536 (:_NET_WM_STATE
537 (let ((our-window (find-window window)))
538 (when our-window
539 (let ((action (elt data 0))
540 (p1 (elt data 1))
541 (p2 (elt data 2)))
542 (dolist (p (list p1 p2))
99e96b8 skip nonatoms for _net_wm_state in client-message event
Shawn authored
543 ;; Sometimes the number cannot be converted to an atom, so skip them.
544 (unless (or (= p 0)
545 (not (typep p '(unsigned-byte 29))))
5673a35 use safe-atom-name to convert IDs to atoms
Shawn authored
546 (case (safe-atom-name p)
7fcaf21 Clean up urgency handling. Properly handle _NET_WM_STATE_DEMANDS_ATTE…
Jonathan Moore Liles authored
547 (:_NET_WM_STATE_DEMANDS_ATTENTION
548 (case action
549 (1
550 (add-wm-state window :_NET_WM_STATE_DEMANDS_ATTENTION))
551 (2
552 (unless (find-wm-state window :_NET_WM_STATE_DEMANDS_ATTENTION)
553 (add-wm-state window :_NET_WM_STATE_DEMANDS_ATTENTION))))
33adc5c @sabetts fix typo in client-message event
sabetts authored
554 (maybe-set-urgency our-window))
0825287 @joelagnel events.lisp idented with spaces
authored
555 (:_NET_WM_STATE_FULLSCREEN
556 (update-fullscreen our-window action)))))))))
7fcaf21 Clean up urgency handling. Properly handle _NET_WM_STATE_DEMANDS_ATTE…
Jonathan Moore Liles authored
557 (:_NET_MOVERESIZE_WINDOW
558 (let ((our-window (find-window window)))
559 (when our-window
560 (let ((x (elt data 1))
561 (y (elt data 2)))
562 (dformat 3 "!!! Data: ~S~%" data)
3ba1e2d add a group API and isolate all tile-group related code within the api
Shawn authored
563 (group-move-request (window-group our-window) our-window x y :root)))))
7fcaf21 Clean up urgency handling. Properly handle _NET_WM_STATE_DEMANDS_ATTE…
Jonathan Moore Liles authored
564 (t
565 (dformat 2 "ignored message~%"))))
c81a732 restructure almost all the code in core.lisp into seperate files.
Shawn authored
566
567 (define-stump-event-handler :focus-out (window mode kind)
568 (dformat 5 "~@{~s ~}~%" window mode kind))
569
570 ;;; Mouse focus
571
572 (defun focus-all (win)
573 "Focus the window, frame, group and screen belonging to WIN. Raise
574 the window in it's frame."
3ba1e2d add a group API and isolate all tile-group related code within the api
Shawn authored
575 (when win
c81a732 restructure almost all the code in core.lisp into seperate files.
Shawn authored
576 (unmap-message-window (window-screen win))
577 (switch-to-screen (window-screen win))
3ba1e2d add a group API and isolate all tile-group related code within the api
Shawn authored
578 (let ((group (window-group win)))
c81a732 restructure almost all the code in core.lisp into seperate files.
Shawn authored
579 (switch-to-group group)
3ba1e2d add a group API and isolate all tile-group related code within the api
Shawn authored
580 (group-focus-window (window-group win) win))))
c81a732 restructure almost all the code in core.lisp into seperate files.
Shawn authored
581
582 (define-stump-event-handler :enter-notify (window mode)
583 (when (and window (eq mode :normal) (eq *mouse-focus-policy* :sloppy))
584 (let ((win (find-window window)))
585 (when (and win (find win (top-windows)))
a5ac4dc @jli update-all-mode-lines added for mouse-based window focus events.
jli authored
586 (focus-all win)
587 (update-all-mode-lines)))))
c81a732 restructure almost all the code in core.lisp into seperate files.
Shawn authored
588
589 (define-stump-event-handler :button-press (window code x y child time)
590 ;; Pass click to client
591 (xlib:allow-events *display* :replay-pointer time)
0119eab added cube click to button-press handler
root authored
592 (let (screen ml win cube)
c81a732 restructure almost all the code in core.lisp into seperate files.
Shawn authored
593 (cond
594 ((and (setf screen (find-screen window)) (not child))
3ba1e2d add a group API and isolate all tile-group related code within the api
Shawn authored
595 (group-button-press (screen-current-group screen) x y :root))
c81a732 restructure almost all the code in core.lisp into seperate files.
Shawn authored
596 ((setf ml (find-mode-line-window window))
597 (run-hook-with-args *mode-line-click-hook* ml code x y))
0119eab added cube click to button-press handler
root authored
598 ((setf cube (find-cube-window window))
599 (cube-clicked cube))
9fe89bb fix :key-seq type to work with read-from-keymap
Shawn authored
600 ((setf win (find-window-by-parent window (top-windows)))
3ba1e2d add a group API and isolate all tile-group related code within the api
Shawn authored
601 (group-button-press (window-group win) x y win)))))
c81a732 restructure almost all the code in core.lisp into seperate files.
Shawn authored
602
603 ;; Handling event :KEY-PRESS
604 ;; (:DISPLAY #<XLIB:DISPLAY :0 (The X.Org Foundation R60700000)> :EVENT-KEY :KEY-PRESS :EVENT-CODE 2 :SEND-EVENT-P NIL :CODE 45 :SEQUENCE 1419 :TIME 98761213 :ROOT #<XLIB:WINDOW :0 96> :WINDOW #<XLIB:WINDOW :0 6291484> :EVENT-WINDOW #<XLIB:WINDOW :0 6291484> :CHILD
605 ;; #<XLIB:WINDOW :0 6291485> :ROOT-X 754 :ROOT-Y 223 :X 753 :Y 222 :STATE 4 :SAME-SCREEN-P T)
606 ;; H
607
608 (defun handle-event (&rest event-slots &key display event-key &allow-other-keys)
609 (declare (ignore display))
610 (dformat 1 ">>> ~S~%" event-key)
a831cd9 workaround the clx pixmap/window error
Shawn authored
611 (let ((eventfn (gethash event-key *event-fn-table*))
612 (win (getf event-slots :window)))
c81a732 restructure almost all the code in core.lisp into seperate files.
Shawn authored
613 (when eventfn
a5207b6 fix up a comment
Shawn authored
614 ;; XXX: In both the clisp and sbcl clx libraries, sometimes what
615 ;; should be a window will be a pixmap instead. In this case, we
616 ;; need to manually translate it to a window to avoid breakage
617 ;; in stumpwm. So far the only slot that seems to be affected is
618 ;; the :window slot for configure-request and reparent-notify
619 ;; events. It appears as though the hash table of XIDs and clx
620 ;; structures gets out of sync with X or perhaps X assigns a
621 ;; duplicate ID for a pixmap and a window.
a831cd9 workaround the clx pixmap/window error
Shawn authored
622 (when (and win (not (xlib:window-p win)))
623 (dformat 10 "Pixmap Workaround! ~s should be a window!~%" win)
624 (setf (getf event-slots :window) (make-xlib-window win)))
c81a732 restructure almost all the code in core.lisp into seperate files.
Shawn authored
625 (handler-case
626 (progn
627 ;; This is not the stumpwm top level, but if the restart
628 ;; is in the top level then it seems the event being
629 ;; processed isn't popped off the stack and is immediately
630 ;; reprocessed after restarting to the top level. So fake
631 ;; it, and put the restart here.
632 (with-simple-restart (top-level "Return to stumpwm's top level")
9ff9e45 interactive-command renamed to eval-command; new argument "interactivep"
Lionel Flandrin authored
633 (apply eventfn event-slots))
c81a732 restructure almost all the code in core.lisp into seperate files.
Shawn authored
634 (xlib:display-finish-output *display*))
635 ((or xlib:window-error xlib:drawable-error) (c)
636 ;; Asynchronous errors are handled in the error
637 ;; handler. Synchronous errors like trying to get the window
638 ;; hints on a deleted window are caught and ignored here. We
639 ;; do this inside the event handler so that the event is
640 ;; handled. If we catch it higher up the event will not be
641 ;; flushed from the queue and we'll get ourselves into an
642 ;; infinite loop.
643 (dformat 4 "ignore synchronous ~a~%" c))))
644 (dformat 2 "<<< ~S~%" event-key)
645 t))
Something went wrong with that request. Please try again.