1 ;;; --------------------------------------------------------------------------
2 ;;; CLFSWM - FullScreen Window Manager
4 ;;; --------------------------------------------------------------------------
5 ;;; Documentation: Main functions
6 ;;; --------------------------------------------------------------------------
8 ;;; (C) 2010 Philippe Brochard <hocwp@free.fr>
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
*)))
46 (define-handler main-mode
:configure-request
(stack-mode window x y width height border-width value-mask
)
47 (labels ((has-x (mask) (= 1 (logand mask
1)))
48 (has-y (mask) (= 2 (logand mask
2)))
49 (has-w (mask) (= 4 (logand mask
4)))
50 (has-h (mask) (= 8 (logand mask
8)))
51 (has-bw (mask) (= 16 (logand mask
16)))
52 (has-stackmode (mask) (= 64 (logand mask
64)))
53 (adjust-from-request ()
54 (when (has-x value-mask
) (setf (xlib:drawable-x window
) x
))
55 (when (has-y value-mask
) (setf (xlib:drawable-y window
) y
))
56 (when (has-h value-mask
) (setf (xlib:drawable-height window
) height
))
57 (when (has-w value-mask
) (setf (xlib:drawable-width window
) width
))))
59 (xlib:with-state
(window)
60 (when (has-bw value-mask
)
61 (setf (xlib:drawable-border-width window
) border-width
))
62 (if (find-child window
*current-root
*)
63 (let ((parent (find-parent-frame window
*current-root
*)))
64 (if (and parent
(managed-window-p window parent
))
65 (adapt-child-to-parent window parent
)
66 (adjust-from-request)))
67 (adjust-from-request))
68 (send-configuration-notify window
(xlib:drawable-x window
) (xlib:drawable-y window
)
69 (xlib:drawable-width window
) (xlib:drawable-height window
)
70 (xlib:drawable-border-width window
))
71 (when (has-stackmode value-mask
)
73 (:above
(raise-window window
))))))))
75 (define-handler main-mode
:map-request
(window send-event-p
)
77 (unhide-window window
)
78 (process-new-window window
)
80 (unless (null-size-window-p window
)
81 (show-all-children))))
83 (define-handler main-mode
:unmap-notify
(send-event-p event-window window
)
84 (unless (and (not send-event-p
)
85 (not (xlib:window-equal window event-window
)))
86 (when (find-child window
*root-frame
*)
87 (delete-child-in-all-frames window
)
88 (show-all-children))))
90 (define-handler main-mode
:destroy-notify
(send-event-p event-window window
)
91 (unless (or send-event-p
92 (xlib:window-equal window event-window
))
93 (when (find-child window
*root-frame
*)
94 (delete-child-in-all-frames window
)
95 (show-all-children))))
97 (define-handler main-mode
:enter-notify
(window root-x root-y
)
98 (unless (and (> root-x
(- (xlib:screen-width
*screen
*) 3))
99 (> root-y
(- (xlib:screen-height
*screen
*) 3)))
100 (case (if (frame-p *current-child
*)
101 (frame-focus-policy *current-child
*)
102 *default-focus-policy
*)
103 (:sloppy
(focus-window window
))
104 (:sloppy-strict
(when (and (frame-p *current-child
*)
105 (member window
(frame-child *current-child
*)))
106 (focus-window window
)))
107 (:sloppy-select
(let* ((child (find-child-under-mouse root-x root-y
))
108 (parent (find-parent-frame child
)))
109 (unless (or (equal child
*current-root
*)
110 (equal (typecase child
114 (focus-all-children child parent
)
115 (show-all-children)))))))
117 (define-handler main-mode
:exposure
(window)
118 (awhen (find-frame-window window
*current-root
*)
119 (display-frame-info it
)))
125 (call-hook *loop-hook
*)
126 (xlib:display-finish-output
*display
*)
127 (xlib:process-event
*display
* :handler
#'handle-event
:timeout
*loop-timeout
*))))
128 ;;(dbg "Main loop finish" c)))))
131 (defun open-display (display-str protocol
)
132 (multiple-value-bind (host display-num
) (parse-display-string display-str
)
133 (setf *display
* (xlib:open-display host
:display display-num
:protocol protocol
)
134 (getenv "DISPLAY") display-str
)))
138 (defun default-init-hook ()
139 (let ((frame (add-frame (create-frame :name
"Default"
140 :layout nil
:x
0.05 :y
0.05
141 :w
0.9 :h
0.9) *root-frame
*)))
142 (setf *current-child
* frame
)))
145 (defun init-display ()
146 (assoc-keyword-handle-event 'main-mode
)
147 (setf *screen
* (first (xlib:display-roots
*display
*))
148 *root
* (xlib:screen-root
*screen
*)
149 *no-focus-window
* (xlib:create-window
:parent
*root
* :x
0 :y
0 :width
1 :height
1)
150 *default-font
* (xlib:open-font
*display
* *default-font-string
*)
151 *pixmap-buffer
* (xlib:create-pixmap
:width
(xlib:screen-width
*screen
*)
152 :height
(xlib:screen-height
*screen
*)
153 :depth
(xlib:screen-root-depth
*screen
*)
156 *clfswm-terminal
* nil
157 *vt-keyboard-on
* nil
)
160 (xgrab-init-keyboard)
162 (call-hook *binding-hook
*)
163 (map-window *no-focus-window
*)
165 (setf (xlib:window-event-mask
*root
*) (xlib:make-event-mask
:substructure-redirect
172 ;;(intern-atoms *display*)
173 (netwm-set-properties)
174 (xlib:display-force-output
*display
*)
175 (setf *child-selection
* nil
)
176 (setf *root-frame
* (create-frame :name
"Root" :number
0) ;; :layout #'tile-space-layout)
177 *current-root
* *root-frame
*
178 *current-child
* *current-root
*)
179 (call-hook *init-hook
*)
180 (process-existing-windows *screen
*)
181 (show-all-children *current-root
*)
183 (xlib:display-finish-output
*display
*))
188 (defun read-conf-file ()
189 (let* ((conf (conf-file-name)))
191 (handler-case (load conf
)
193 (format t
"~2%*** Error loading configurtion file: ~A ***~&~A~%" conf c
)
194 (values nil
(format nil
"~s" c
) conf
))
195 (:no-error
(&rest args
)
196 (declare (ignore args
))
197 (values t nil conf
)))
198 (values t nil nil
))))
205 (defun exit-clfswm ()
207 (throw 'exit-clfswm nil
))
209 (defun reset-clfswm ()
211 (throw 'exit-main-loop nil
))
216 (defun main-unprotected (&key
(display (or (getenv "DISPLAY") ":0")) protocol
217 (base-dir (directory-namestring (or *load-truename
* "")))
218 (read-conf-file-p t
) (alternate-conf nil
)
220 (setf *contrib-dir
* base-dir
)
221 (conf-file-name alternate-conf
)
222 (when read-conf-file-p
225 (open-display display protocol
)
226 (xlib:access-error
(c)
227 (format t
"~&~A~&Maybe another window manager is running. [1]~%" c
)
232 (xlib:access-error
(c)
234 (xlib:destroy-window
*no-focus-window
*)
235 (xlib:close-display
*display
*)
236 (format t
"~&~A~&Maybe another window manager is running. [2]~%" c
)
240 (info-mode error-msg
))
242 (catch 'exit-main-loop
245 (xlib:destroy-window
*no-focus-window
*)
246 (xlib:free-pixmap
*pixmap-buffer
*)
247 (xlib:close-display
*display
*)
249 (format t
"~2&Unhandled events: ~A~%" *unhandled-events
*)))
252 (defun main (&key
(display (or (getenv "DISPLAY") ":0")) protocol
253 (base-dir (directory-namestring (or *load-truename
* "")))
255 (alternate-conf nil
))
260 (if *other-window-manager
*
261 (run-other-window-manager)
262 (main-unprotected :display display
:protocol protocol
:base-dir base-dir
263 :read-conf-file-p read-conf-file-p
264 :alternate-conf alternate-conf
265 :error-msg error-msg
))
267 (let ((msg (format nil
"CLFSWM Error: ~A." c
)))
268 (format t
"~&~A~%Reinitializing...~%" msg
)
269 (setf error-msg
(list (list msg
*info-color-title
*)
270 "Reinitializing...")))))))))