1 ;;; --------------------------------------------------------------------------
2 ;;; CLFSWM - FullScreen Window Manager
4 ;;; --------------------------------------------------------------------------
5 ;;; Documentation: Main functions
6 ;;; --------------------------------------------------------------------------
8 ;;; (C) 2012 Philippe Brochard <pbrochard@common-lisp.net>
10 ;;; This program is free software; you can redistribute it and/or modify
11 ;;; it under the terms of the GNU General Public License as published by
12 ;;; the Free Software Foundation; either version 3 of the License, or
13 ;;; (at your option) any later version.
15 ;;; This program is distributed in the hope that it will be useful,
16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;;; GNU General Public License for more details.
20 ;;; You should have received a copy of the GNU General Public License
21 ;;; along with this program; if not, write to the Free Software
22 ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
24 ;;; --------------------------------------------------------------------------
29 (define-handler main-mode
:key-press
(code state
)
30 (funcall-key-from-code *main-keys
* code state
))
32 (define-handler main-mode
:button-press
(code state window root-x root-y
)
33 (unless (funcall-button-from-code *main-mouse
* code state window root-x root-y
*fun-press
*)
34 (replay-button-event)))
36 (define-handler main-mode
:button-release
(code state window root-x root-y
)
37 (unless (funcall-button-from-code *main-mouse
* code state window root-x root-y
*fun-release
*)
38 (replay-button-event)))
40 (define-handler main-mode
:motion-notify
(window root-x root-y
)
41 (unless (compress-motion-notify)
42 (funcall-button-from-code *main-mouse
* 'motion
43 (modifiers->state
*default-modifiers
*)
44 window root-x root-y
*fun-press
*)))
47 (define-handler main-mode
:configure-request
(stack-mode window x y width height border-width value-mask
)
49 (labels ((has-x (mask) (= 1 (logand mask
1)))
50 (has-y (mask) (= 2 (logand mask
2)))
51 (has-w (mask) (= 4 (logand mask
4)))
52 (has-h (mask) (= 8 (logand mask
8)))
53 (has-bw (mask) (= 16 (logand mask
16)))
54 (has-stackmode (mask) (= 64 (logand mask
64)))
55 (adjust-from-request ()
56 (when (has-x value-mask
) (setf (x-drawable-x window
) x
58 (when (has-y value-mask
) (setf (x-drawable-y window
) y
60 (when (has-h value-mask
) (setf (x-drawable-height window
) height
62 (when (has-w value-mask
) (setf (x-drawable-width window
) width
65 (xlib:with-state
(window)
66 (let ((current-root (find-current-root)))
67 (if (find-child window current-root
)
68 (let ((parent (find-parent-frame window current-root
)))
69 (if (and parent
(managed-window-p window parent
))
70 (setf change
(adapt-child-to-parent window parent
))
71 (adjust-from-request)))
72 (adjust-from-request)))
73 (when (has-bw value-mask
)
74 (setf (x-drawable-border-width window
) border-width
76 (when (has-stackmode value-mask
)
79 (when (or (child-equal-p window
(current-child))
80 (is-in-current-child-p window
))
81 (setf change
(or change
:moved
))
83 (focus-all-children window
(find-parent-frame window
(find-current-root)))
84 (show-all-children))))))
85 (unless (eq change
:resized
)
86 ;; To be ICCCM compliant, send a fake configuration notify event only when
87 ;; the window has moved and not when it has been resized or the border width has changed.
88 (send-configuration-notify window
(x-drawable-x window
) (x-drawable-y window
)
89 (x-drawable-width window
) (x-drawable-height window
)
90 (x-drawable-border-width window
)))))))
93 (define-handler main-mode
:map-request
(window send-event-p
)
95 (unless (find-child window
*root-frame
*)
96 (unhide-window window
)
97 (process-new-window window
)
99 (multiple-value-bind (never-managed raise
)
100 (never-managed-window-p window
)
101 (unless (and never-managed raise
)
102 (show-all-children))))))
106 (define-handler main-mode
:unmap-notify
(send-event-p event-window window
)
107 (unless (and (not send-event-p
)
108 (not (xlib:window-equal window event-window
)))
109 (when (find-child window
*root-frame
*)
110 (setf (window-state window
) +withdrawn-state
+)
111 (remove-child-in-all-frames window
)
112 (show-all-children))))
115 (define-handler main-mode
:destroy-notify
(send-event-p event-window window
)
116 (unless (or send-event-p
117 (xlib:window-equal window event-window
))
118 (when (find-child window
*root-frame
*)
119 (delete-child-in-all-frames window
)
120 (show-all-children))))
123 (define-handler main-mode
:enter-notify
(window root-x root-y
)
124 (unless (and (> root-x
(- (xlib:screen-width
*screen
*) 3))
125 (> root-y
(- (xlib:screen-height
*screen
*) 3)))
126 (case (if (frame-p (current-child))
127 (frame-focus-policy (current-child))
128 *default-focus-policy
*)
129 (:sloppy
(focus-window window
))
130 (:sloppy-strict
(when (and (frame-p (current-child))
131 (child-member window
(frame-child (current-child))))
132 (focus-window window
)))
133 (:sloppy-select
(let* ((child (find-child-under-mouse root-x root-y
))
134 (parent (find-parent-frame child
)))
135 (unless (or (child-root-p child
)
136 (child-equal-p (typecase child
140 (focus-all-children child parent
)
141 (show-all-children))))
142 (:sloppy-select-window
(let* ((child (find-child-under-mouse root-x root-y
))
143 (parent (find-parent-frame child
))
144 (need-warp-pointer (not (or (frame-p child
)
145 (child-equal-p child
(frame-selected-child parent
))))))
146 (unless (child-root-p child
)
147 (when (focus-all-children child parent
)
149 (when need-warp-pointer
151 (xlib:window
(xlib:warp-pointer
*root
*
152 (truncate (+ (x-drawable-x child
)
153 (/ (x-drawable-width child
) 2)))
154 (truncate (+ (x-drawable-y child
)
155 (/ (x-drawable-height child
) 2)))))
156 (frame (xlib:warp-pointer
*root
*
157 (+ (frame-rx child
) 10)
158 (+ (frame-ry child
) 10))))))))))))
160 (define-handler main-mode
:exposure
(window)
161 (awhen (find-frame-window window
)
162 (display-frame-info it
)))
165 (define-handler main-mode
:configure-notify
(window)
166 (when (child-equal-p window
*root
*)
167 (unless (eql (place-frames-from-xinerama-infos) :update
)
168 (finish-configuring-root))
170 (call-hook *root-size-change-hook
*)))
173 (defun error-handler (display error-key
&rest key-vals
&key asynchronous
&allow-other-keys
)
176 ;; ignore asynchronous window errors
178 (find error-key
'(xlib:window-error xlib
:drawable-error xlib
:match-error
)))
179 #+:xlib-debug
(format t
"~&Ignoring XLib asynchronous error: ~s~%" error-key
))
180 ((eq error-key
'xlib
:access-error
)
181 (write-line "~&Another window manager is running.")
182 (throw 'exit-clfswm nil
))
183 ;; all other asynchronous errors are printed.
185 #+:xlib-debug
(format t
"~&Caught Asynchronous X Error: ~s ~s" error-key key-vals
))
186 ;;((find error-key '(xlib:window-error xlib:drawable-error xlib:match-error))
187 ;; (format t "~&Ignoring Xlib error: ~S ~S~%" error-key key-vals))
189 (apply 'error error-key
:display display
:error-key error-key key-vals
))))
194 (with-xlib-protect (:main-loop nil
)
195 (call-hook *loop-hook
*)
197 (when (xlib:event-listen
*display
* *loop-timeout
*)
198 (xlib:process-event
*display
* :handler
#'handle-event
))
199 (xlib:display-finish-output
*display
*)
200 (setf *x-error-count
* 0))))
205 (defun open-display (display-str protocol
)
206 (multiple-value-bind (host display-num
) (parse-display-string display-str
)
207 (setf *display
* (xlib:open-display host
:display display-num
:protocol protocol
)
208 (xlib:display-error-handler
*display
*) 'error-handler
209 (getenv "DISPLAY") display-str
)))
213 (defun default-init-hook ()
214 (place-frames-from-xinerama-infos)
215 (finish-configuring-root))
218 (defun init-display ()
220 (reset-last-head-size)
221 (reset-bind-or-jump-slots)
223 (fill-handle-event-fun-symbols)
224 (assoc-keyword-handle-event 'main-mode
)
225 (setf *screen
* (first (xlib:display-roots
*display
*))
226 *root
* (xlib:screen-root
*screen
*)
227 *no-focus-window
* (xlib:create-window
:parent
*root
* :x
0 :y
0 :width
1 :height
1)
228 *default-font
* (xlib:open-font
*display
* *default-font-string
*)
229 *pixmap-buffer
* (xlib:create-pixmap
:width
(xlib:screen-width
*screen
*)
230 :height
(xlib:screen-height
*screen
*)
231 :depth
(xlib:screen-root-depth
*screen
*)
235 (store-root-background)
238 (xgrab-init-keyboard)
240 (call-hook *binding-hook
*)
242 (map-window *no-focus-window
*)
244 (setf (xlib:window-event-mask
*root
*) (xlib:make-event-mask
:substructure-redirect
253 (xlib:display-finish-output
*display
*)
254 ;;(intern-atoms *display*)
255 (netwm-set-properties)
256 (xlib:display-force-output
*display
*)
257 (setf *child-selection
* nil
)
258 (setf *root-frame
* (create-frame :name
"Root" :number
0)
259 (current-child) *root-frame
*)
260 (call-hook *init-hook
*)
261 (process-existing-windows *screen
*)
264 (xlib:display-finish-output
*display
*)
265 (optimize-event-hook))
270 (defun read-conf-file ()
271 (let* ((conf (conf-file-name)))
273 (handler-case (load conf
)
275 (format t
"~2%*** Error loading configuration file: ~A ***~&~A~%" conf c
)
276 (values nil
(format nil
"~s" c
) conf
))
277 (:no-error
(&rest args
)
278 (declare (ignore args
))
279 (values t nil conf
)))
280 (values t nil nil
))))
287 (defun exit-clfswm ()
289 (throw 'exit-clfswm nil
))
291 (defun reset-clfswm ()
293 (throw 'exit-main-loop nil
))
298 (defun main-unprotected (&key
(display (or (getenv "DISPLAY") ":0")) protocol
299 (read-conf-file-p t
) (alternate-conf nil
)
301 (conf-file-name alternate-conf
)
302 (when read-conf-file-p
304 (create-configuration-menu :clear t
)
305 (call-hook *main-entrance-hook
*)
307 (open-display display protocol
)
308 (xlib:access-error
(c)
309 (format t
"~&~A~&Maybe another window manager is running. [1]~%" c
)
314 (xlib:access-error
(c)
316 (xlib:destroy-window
*no-focus-window
*)
317 (xlib:close-display
*display
*)
318 (format t
"~&~A~&Maybe another window manager is running. [2]~%" c
)
322 (info-mode error-msg
))
323 (catch 'exit-main-loop
328 (xlib:destroy-window
*no-focus-window
*)
329 (xlib:free-pixmap
*pixmap-buffer
*)
330 (destroy-all-frames-window)
331 (call-hook *close-hook
*)
333 (xlib:close-display
*display
*)
335 (format t
"~2&Unhandled events: ~A~%" *unhandled-events
*)))))
339 (defun main (&key
(display (or (getenv "DISPLAY") ":0")) protocol
341 (alternate-conf nil
))
346 (if *other-window-manager
*
347 (run-other-window-manager)
348 (main-unprotected :display display
:protocol protocol
349 :read-conf-file-p read-conf-file-p
350 :alternate-conf alternate-conf
351 :error-msg error-msg
))
353 (let ((msg (format nil
"CLFSWM Error: ~A." c
)))
354 (format t
"~&~A~%Reinitializing...~%" msg
)
355 (setf error-msg
(list (list msg
*info-color-title
*)
356 "Reinitializing...")))))))))