/[eclipse]/eclipse/wm.lisp
ViewVC logotype

Contents of /eclipse/wm.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.62 - (show annotations)
Fri Apr 23 14:42:43 2010 UTC (3 years, 11 months ago) by ihatchondo
Branch: MAIN
CVS Tags: HEAD
Changes since 1.61: +29 -30 lines
Fix: cosmetic & cleanup changes in the way of handling EOF on the xlib:display object.
1 ;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
2 ;;; $Id: wm.lisp,v 1.62 2010/04/23 14:42:43 ihatchondo Exp $
3 ;;;
4 ;;; ECLIPSE. The Common Lisp Window Manager.
5 ;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
6 ;;; Copyright (C) 2000
7 ;;; Julien BONINFANTE,
8 ;;; Aymeric LACORTE,
9 ;;; Jocelyn FRECHOT
10 ;;; contact : hatchond@yahoo.fr
11 ;;;
12 ;;; This program is free software; you can redistribute it and/or
13 ;;; modify it under the terms of the GNU General Public License
14 ;;; as published by the Free Software Foundation.
15 ;;;
16 ;;; This program is distributed in the hope that it will be useful,
17 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;;; GNU General Public License for more details.
20 ;;;
21 ;;; You should have received a copy of the GNU General Public License
22 ;;; along with this program; if not, write to the Free Software
23 ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
24
25 ;; usefull for having a quick and short garbage collection.
26 #+:cmu (setf extensions:*bytes-consed-between-gcs* 400000
27 extensions:*gc-verbose* nil)
28
29 (in-package :ECLIPSE-INTERNALS)
30
31 ;;;; Decoration
32
33 (defclass decoration (base-widget)
34 ((children :initarg :children :accessor decoration-children)
35 (active-p :initform nil :accessor decoration-active-p)
36 (wm-size-hints :initarg :wm-size-hints :reader decoration-wm-size-hints)
37 (frame-style :initarg :frame-style :accessor decoration-frame-style)
38 (old-frame-style :initform nil :initarg :old-frame-style)
39 (application-gravity
40 :initarg :application-gravity
41 :initform :north-west
42 :accessor decoration-application-gravity))
43 (:documentation "Top level widget for application that will have a set of
44 decoration (e.g: those for which window-not-decorable-p will return NIL)."))
45
46 (defun decoration-p (widget)
47 (typep widget 'decoration))
48
49 (defun title-bar-horizontal-p (master)
50 (eq :horizontal (style-title-bar-direction (decoration-frame-style master))))
51
52 (defconstant +decoration-event-mask+
53 '(:substructure-redirect :substructure-notify
54 :visibility-change :enter-window :owner-grab-button))
55
56 (defmethod get-child ((master decoration) label &key window)
57 "Returns the child widget/window labeled `label' or nil if no such
58 child exists. label is a keyword."
59 (let ((widget (getf (decoration-children master) label)))
60 (if (and widget window) (widget-window widget) widget)))
61
62 (defmethod decoration-wm-hints ((master decoration))
63 "Returns as a multiple value: minw minh maxw maxh incw inch basew baseh."
64 (with-slots (frame-style (wmsh wm-size-hints)) master
65 (declare (type (vector integer 8) wmsh))
66 (with-slots ((hm hmargin) (vm vmargin)) frame-style
67 (values (+ hm (svref wmsh 0)) (+ vm (svref wmsh 1))
68 (+ hm (svref wmsh 2)) (+ vm (svref wmsh 3))
69 (svref wmsh 4) (svref wmsh 5)
70 (+ hm (svref wmsh 6)) (+ vm (svref wmsh 7))))))
71
72 (defmethod focus-widget ((master decoration) timestamp)
73 (with-slots (window input-model) (get-child master :application)
74 (set-focus input-model window timestamp)))
75
76 (defmethod focused-p ((master decoration))
77 (focused-p (get-child master :application)))
78
79 (defmethod widget-position-fix-p ((master decoration))
80 (widget-position-fix-p (get-child master :application)))
81
82 (defmethod shaded-p ((widget decoration))
83 (with-slots (window) (get-child widget :application)
84 (member :_net_wm_state_shaded (netwm:net-wm-state window))))
85
86 (defmethod shade ((master decoration))
87 (with-slots (window frame-style) master
88 (let* ((app-win (get-child master :application :window t))
89 (netwm-prop (netwm:net-wm-state app-win))
90 (gnome-prop (or (gnome:win-state app-win :result-type t) 0)))
91 (setf gnome-prop (logand gnome-prop #x3DF)) ; supress :win_state_shaded
92 (if (member :_net_wm_state_shaded netwm-prop)
93 (with-event-mask (window)
94 ;; unshade.
95 (xlib:map-window app-win)
96 (xlib:map-window window)
97 (resize-from (get-child master :application))
98 (setf netwm-prop (remove :_net_wm_state_shaded netwm-prop))
99 (setf netwm-prop (remove :_net_wm_state_hidden netwm-prop))
100 (unless (stick-p app-win)
101 (setf (window-desktop-num app-win) (current-desk))))
102 (with-event-mask (window)
103 ;; shade.
104 (with-slots ((vm vmargin) (hm hmargin)) frame-style
105 (if (title-bar-horizontal-p master)
106 (unless (= 0 vm) (setf (xlib:drawable-height window) vm))
107 (unless (= 0 hm) (setf (xlib:drawable-width window) hm))))
108 (xlib:unmap-window app-win)
109 (pushnew :_net_wm_state_shaded netwm-prop)
110 (pushnew :_net_wm_state_hidden netwm-prop)
111 (incf gnome-prop 32))) ; add win_state_shaded
112 (setf (netwm:net-wm-state app-win) netwm-prop
113 (gnome:win-state app-win) gnome-prop))))
114
115 (defmethod close-widget ((widget decoration))
116 (close-widget (get-child widget :application)))
117
118 (defmethod put-on-top ((widget decoration))
119 (put-on-top (get-child widget :application)))
120
121 (defmethod put-on-bottom ((widget decoration))
122 (put-on-bottom (get-child widget :application)))
123
124 (defmethod maximize ((widget decoration) code &key (fill-p *maximize-fill*))
125 (maximize (get-child widget :application) code :fill-p fill-p))
126
127 (defmethod (setf decoration-frame-style) :after (astyle (master decoration))
128 (with-slots (window children wm-size-hints) master
129 (with-slots (left-margin top-margin (hm hmargin) (vm vmargin)) astyle
130 (with-event-mask (window)
131 (let* ((application (getf children :application))
132 (icon (slot-value application 'icon))
133 (app-win (slot-value application 'window)))
134 (loop for (key val) on children by #'cddr
135 unless (or (eq key :application) (eq key :icon))
136 do (when (typep val 'edge)
137 (xlib:destroy-window (widget-window val)))
138 (remove-widget val))
139 (setf children (list :application application :icon icon)
140 wm-size-hints (recompute-wm-normal-hints app-win hm vm))
141 (let ((width (+ (xlib:drawable-width app-win) hm))
142 (height (+ (xlib:drawable-height app-win) vm)))
143 (setf (xlib:window-background window) (style-background astyle)
144 (window-position app-win) (values left-margin top-margin)
145 (drawable-sizes window) (values width height))
146 (make-frame-parts master)
147 (make-title-bar master (wm-name app-win))
148 (update-edges-geometry master)
149 (xlib:map-subwindows window))
150 (setf (application-frame-style application) astyle)
151 (cond ((shaded-p application)
152 (if (title-bar-horizontal-p master)
153 (unless (= 0 vm) (setf (xlib:drawable-height window) vm))
154 (unless (= 0 hm) (setf (xlib:drawable-width window) hm)))
155 (xlib:unmap-window app-win))
156 ((application-iconic-p application)
157 (xlib:unmap-window app-win))))))))
158
159 (defmethod dispatch-repaint ((master decoration)
160 &key (focus (focused-p master)))
161 (declare (optimize (speed 3) (safety 1)))
162 (with-slots (parts-to-redraw-on-focus theme) (decoration-frame-style master)
163 (declare (type theme theme))
164 (mapc #'(lambda (k) (repaint (get-child master k) theme focus))
165 parts-to-redraw-on-focus)))
166
167 (defun recompute-wm-normal-hints (window hmargin vmargin)
168 "Returns two value: a vector representing the wm-normal-hints property and
169 the window gravity of the designed window. The wm-normal-hints property is
170 recomputed in order to reflect the margin that a top level decoration widget
171 (aka master) might introduce."
172 (let ((hints (or (ignore-errors (wm-normal-hints window))
173 (xlib:make-wm-size-hints)))
174 (max-ww (screen-width))
175 (max-hh (screen-height)))
176 (symbol-macrolet ((min-w (xlib:wm-size-hints-min-width hints))
177 (min-h (xlib:wm-size-hints-min-height hints))
178 (max-w (xlib:wm-size-hints-max-width hints))
179 (max-h (xlib:wm-size-hints-max-height hints))
180 (inc-w (xlib:wm-size-hints-width-inc hints))
181 (inc-h (xlib:wm-size-hints-height-inc hints))
182 (base-w (xlib:wm-size-hints-base-width hints))
183 (base-h (xlib:wm-size-hints-base-height hints))
184 (g (xlib:wm-size-hints-win-gravity hints)))
185 (unless (eq g :static)
186 (decf max-ww hmargin)
187 (decf max-hh vmargin))
188 (setf min-w (max (or (or min-w base-w) 1) 1)
189 min-h (max (or (or min-h base-h) 1) 1)
190 base-w (max (or (or base-w min-w) 1) 1)
191 base-h (max (or (or base-h min-h) 1) 1)
192 inc-w (or inc-w 1)
193 inc-h (or inc-h 1))
194 (setf max-ww (- max-ww (mod (- max-ww base-w) inc-w))
195 max-hh (- max-hh (mod (- max-hh base-h) inc-h)))
196 (unless (and max-w (<= min-w max-w max-ww)) (setf max-w max-ww))
197 (unless (and max-h (<= min-h max-h max-hh)) (setf max-h max-hh))
198 (setf min-w (min min-w max-w)
199 min-h (min min-h max-h)
200 base-w (min base-w max-w)
201 base-h (min base-h max-h))
202 (multiple-value-bind (w h) (drawable-sizes window)
203 (unless (<= min-w w max-w)
204 (setf (xlib:drawable-width window) (min (max min-w w) max-w)))
205 (unless (<= min-h h max-h)
206 (setf (xlib:drawable-height window) (min (max min-h h) max-h))))
207 (values (vector min-w min-h max-w max-h inc-w inc-h base-w base-h) g))))
208
209 ;;;; Decoration creation tools.
210
211 (defun make-menu-button (master parent-window)
212 (with-slots (children frame-style) master
213 (when (frame-item-exist-p frame-style :menu-button)
214 (let ((pixmaps (frame-item-pixmaps frame-style :menu-button))
215 (horizontal-p (title-bar-horizontal-p master)))
216 (declare (type pixmaps pixmaps))
217 (multiple-value-bind (width height) (drawable-sizes (aref pixmaps 0))
218 (multiple-value-bind (tw th) (drawable-sizes parent-window)
219 (setf (getf children :menu-button)
220 (create-button 'menu-button
221 :parent parent-window :master master
222 :background (aref pixmaps 0)
223 :item (aref pixmaps 1)
224 :width width :height height
225 :event-mask '(:owner-grab-button . #.+push-button-mask+)
226 :y (if horizontal-p (ash (- th height) -1) (- th height))
227 :x (if horizontal-p 0 (ash (- tw width) -1))))))))))
228
229 (defun make-buttons-bar (master parent-window)
230 (with-slots (children (astyle frame-style)) master
231 (flet ((make-container (horizontal-p)
232 (xlib:create-window
233 :parent parent-window
234 :x 0 :y 0 :width 1 :height 1
235 :background :parent-relative
236 :gravity (if horizontal-p :north-east :north-west))))
237 (loop initially (when (zerop (style-nb-buttons astyle)) (return))
238 with horizontal-p = (title-bar-horizontal-p master)
239 with container = (make-container horizontal-p)
240 and (x y width height) = '(0 0 0 0)
241 for type in '(iconify-button maximize-button close-button)
242 for child in '(:icon-b :maximize :close)
243 for pixmaps of-type pixmaps = (frame-item-pixmaps astyle child)
244 for bkgrd = (aref pixmaps 0)
245 when (frame-item-exist-p astyle child)
246 do (multiple-value-setq (width height) (drawable-sizes bkgrd))
247 (setf (getf children child)
248 (create-button type
249 :parent container :master master
250 :background bkgrd :item (aref pixmaps 1)
251 :x x :y y :width width :height height
252 :event-mask +push-button-mask+))
253 (if horizontal-p (incf x width) (incf y height))
254 finally
255 (multiple-value-bind (w h) (drawable-sizes parent-window)
256 (if (zerop x) (incf x width) (incf y height))
257 (setf (drawable-sizes container) (values x y)
258 (window-position container)
259 (if horizontal-p
260 (values (- w x) (ash (- h y) -1))
261 (values (ash (- w x) -1) 0)))
262 (xlib:map-subwindows container)
263 (return container))))))
264
265 (defun make-title-bar (master name)
266 (with-slots (children frame-style) master
267 (unless (eq :none (style-title-bar-position frame-style))
268 (let* ((title-pos (style-title-bar-position frame-style))
269 (horizontal-p (case title-pos ((:top :bottom) t)))
270 (parent-widget (getf children title-pos))
271 (parent-window (widget-window parent-widget))
272 (button-container (make-buttons-bar master parent-window))
273 (menu-button (make-menu-button master parent-window))
274 (pixmaps (frame-item-pixmaps frame-style title-pos))
275 (bcw 0) (bch 0) (mbw 0) (mbh 0) (title))
276 (declare (type pixmaps pixmaps))
277 (when button-container
278 (multiple-value-setq (bcw bch) (drawable-sizes button-container)))
279 (when menu-button
280 (multiple-value-setq (mbw mbh)
281 (drawable-sizes (widget-window menu-button))))
282 (setf title
283 (create-button 'title-bar
284 :parent parent-window :master master
285 :width 1 :height 1
286 :x (if horizontal-p mbw 0) :y (if horizontal-p 0 bch)
287 :event-mask +push-button-mask+
288 :background (aref pixmaps 0) :item name)
289 (slot-value title 'parent) parent-window
290 (getf children :title-bar) title
291 (xlib:window-background parent-window) :parent-relative
292 (xlib:window-event-mask parent-window) 0)
293 (if horizontal-p
294 (setf (slot-value title 'hmargin) (+ bcw mbw))
295 (setf (slot-value title 'vmargin) (+ bch mbh)))
296 (xlib:map-subwindows parent-window)
297 title))))
298
299 (defun edge-position (style edge-key width height)
300 (with-slots (top-left-w top-left-h top-right-h bottom-left-w) style
301 (multiple-value-bind (w h) (frame-item-sizes style edge-key)
302 (case edge-key
303 (:top (values top-left-w 0))
304 (:right (values (- width w) top-right-h))
305 (:bottom (values bottom-left-w (- height h)))
306 (:left (values 0 top-left-h))
307 (:top-left (values 0 0))
308 (:top-right (values (- width w) 0))
309 (:bottom-right (values (- width w) (- height h)))
310 (:bottom-left (values 0 (- height h)))))))
311
312 (defvar *frame-parts*
313 '(:right :left :top :bottom :top-left :top-right :bottom-left :bottom-right))
314
315 (defun make-frame-parts (master)
316 (with-slots (children window (astyle frame-style)) master
317 (multiple-value-bind (width height) (drawable-sizes window)
318 (loop for child in *frame-parts*
319 for pixmaps of-type pixmaps = (frame-item-pixmaps astyle child)
320 for hilighted = (aref pixmaps 1)
321 for event-mask = (if hilighted +std-button-mask+ +edge-event-mask+)
322 when (frame-item-exist-p astyle child) do
323 (multiple-value-bind (x y)
324 (edge-position astyle child width height)
325 (multiple-value-bind (w h) (frame-item-sizes astyle child)
326 (setf (getf children child)
327 (create-button (intern (symbol-name child) :eclipse)
328 :parent window :master master
329 :background (aref pixmaps 0) :item hilighted
330 :event-mask event-mask
331 :x x :y y :width w :height h))))))))
332
333 ;; Public.
334
335 (defun update-edges-geometry (master)
336 (declare (optimize (speed 3) (safety 0)))
337 (declare (inline update-edges-geometry))
338 (macrolet
339 ((update (edge size &rest frame-style-slots-size)
340 `(when ,edge
341 (setf (,(intern (format nil "DRAWABLE-~a" (symbol-name size)) :xlib)
342 (widget-window ,edge))
343 (with-slots (,@frame-style-slots-size) frame-style
344 (declare (type xlib:card16 ,@frame-style-slots-size))
345 (max 1 (- ,size ,@frame-style-slots-size)))))))
346 (with-slots (frame-style window) master
347 (multiple-value-bind (width height) (drawable-sizes window)
348 (declare (type xlib:card16 width height))
349 (update (get-child master :top) width top-left-w top-right-w)
350 (update (get-child master :left) height top-left-h bottom-left-h)
351 (update (get-child master :right) height top-right-h bottom-right-h)
352 (update (get-child master :bottom) width bottom-left-w bottom-right-w)
353 (update-title-bar-sizes (get-child master :title-bar))))))
354
355 (defun update-title-bar-sizes (title-bar)
356 (declare (optimize (speed 3) (safety 0)))
357 (when title-bar
358 (with-slots (parent window (vm vmargin) (hm hmargin)) title-bar
359 (declare (type xlib:card16 vm hm))
360 (multiple-value-bind (width height) (drawable-sizes parent)
361 (declare (type xlib:card16 width height))
362 (setf (drawable-sizes window)
363 (values (max 1 (- width hm)) (max 1 (- height vm))))))))
364
365 (defun initial-coordinates (window frame-style)
366 "Returns as multiple values the decoration initial coordinates."
367 (let ((hint (ignore-errors (wm-normal-hints window))))
368 (with-slots (top-margin left-margin vmargin hmargin) frame-style
369 (flet ((default-coordinates ()
370 (let* ((n (or (window-desktop-num window) 0))
371 (k (if (= +any-desktop+ n) 0 (* 4 n)))
372 (areas (netwm:net-workarea (xlib:drawable-root window)))
373 (ax (aref areas k)) (ay (aref areas (1+ k))))
374 (multiple-value-bind (x y) (window-position window)
375 (values (max ax (- x left-margin))
376 (max ay (- y top-margin)))))))
377 (if (and hint (xlib:wm-size-hints-user-specified-position-p hint))
378 (let ((x (xlib:wm-size-hints-x hint))
379 (y (xlib:wm-size-hints-y hint)))
380 (if (and x y)
381 (case (xlib:wm-size-hints-win-gravity hint)
382 (:north-east (values (- x hmargin) y))
383 (:south-east (values (- x hmargin) (- y vmargin)))
384 (:south-west (values x (- y vmargin)))
385 (:static (values (- x left-margin) (- y top-margin)))
386 (t (values x y)))
387 (progn
388 (format t "user-specified-position-p t but x or y isn't.")
389 (default-coordinates))))
390 (default-coordinates))))))
391
392 (defun make-decoration (app-window application &key theme)
393 "Returns a newly initialized decoration to hold the given application."
394 (unless theme (setf theme (root-decoration-theme *root*)))
395 (let* ((netwm-states (ignore-errors (netwm:net-wm-state app-window)))
396 (dstyle (find-decoration-frame-style theme app-window))
397 (style dstyle)
398 (fullscreen-p (member :_net_wm_state_fullscreen netwm-states)))
399 (when fullscreen-p
400 (setf style (theme-default-style (lookup-theme "no-decoration"))))
401 (with-slots (hmargin vmargin left-margin top-margin background) style
402 (multiple-value-bind (wm-sizes gravity)
403 (recompute-wm-normal-hints app-window hmargin vmargin)
404 (multiple-value-bind (width height) (drawable-sizes app-window)
405 (multiple-value-bind (x y) (initial-coordinates app-window style)
406 (let* ((window (xlib:create-window
407 :parent (xlib:drawable-root app-window)
408 :x x :y y
409 :width (+ width hmargin)
410 :height (+ height vmargin)
411 :background background
412 :event-mask +decoration-event-mask+
413 :do-not-propagate-mask
414 '(:button-press :button-release)))
415 (master (make-instance 'decoration
416 :window window
417 :old-frame-style dstyle :frame-style style
418 :children (list :application application)
419 :application-gravity gravity
420 :wm-size-hints wm-sizes)))
421 (make-frame-parts master)
422 (make-title-bar master (wm-name app-window))
423 (update-edges-geometry master)
424 (with-slots (icon (fgeometry full-geometry)) application
425 (setf (getf (decoration-children master) :icon) icon
426 (slot-value icon 'master) master
427 (slot-value application 'master) master
428 (xlib:drawable-border-width app-window) 0)
429 (when fullscreen-p
430 (multiple-value-bind (x y w h)
431 (fullscreen-sizes (xlib:window-display app-window))
432 (configure-window app-window :x x :y y :width w :height h))
433 (setf (geometry fgeometry) (values x y width height))))
434 master)))))))
435
436 (defun decore-application (window application &key (map t) theme)
437 "Decores an application and map the resulting decoration as indicated
438 by the :map keyword argument. (default value is T).
439 Returns the newly created decoration instance."
440 (let* ((master (make-decoration window application :theme theme))
441 (master-window (widget-window master))
442 (left-margin (style-left-margin (decoration-frame-style master)))
443 (top-margin (style-top-margin (decoration-frame-style master))))
444 (with-event-mask (master-window)
445 (xlib:map-subwindows master-window))
446 (with-event-mask (master-window (when map +decoration-event-mask+))
447 (xlib:reparent-window window master-window left-margin top-margin)
448 (send-configuration-notify window))
449 (setf (application-frame-style application) (decoration-frame-style master))
450 ;; handle maximized states.
451 (let* ((prop (netwm:net-wm-state window))
452 (vert-p (member :_net_wm_state_maximized_vert prop))
453 (horz-p (member :_net_wm_state_maximized_horz prop)))
454 (when (or vert-p horz-p)
455 (setf prop (delete :_net_wm_state_maximized_vert prop))
456 (setf prop (delete :_net_wm_state_maximized_horz prop))
457 (setf (netwm:net-wm-state window) prop)
458 (maximize application (if (and horz-p vert-p) 1 (if horz-p 3 2)))))
459 (when map (xlib:map-window window))
460 master))
461
462 ;;;; Focus management. According to ICCCM
463
464 (defgeneric set-focus (input-model window timestamp)
465 (:documentation
466 "Set focus to the given window according to the input model.
467 Input model can be :globally-active :locally-active :passive :no-input.
468 For more information on the input-model sementic see ICCCM 4.1.7"))
469
470 (defmethod set-focus :around (input-model window timestamp)
471 ;; If we have a valid timestamp then assign focus directly
472 ;; otherwise set the net-active-window to provoke a property-notify event
473 ;; on the root-property-holder. Then the property-notify event will handled
474 ;; and will assign the focus with a valid timestamp.
475 ;; It seems a bit complicated but this is the bettter way I found to not
476 ;; violate the ICCCM (section 4.1.7).
477 (if (and timestamp (> timestamp 0))
478 (and (next-method-p) (call-next-method))
479 (with-slots ((ww window)) (root-property-holder *root*)
480 (setf (netwm:net-active-window ww) window))))
481
482 (defmethod set-focus ((input-model (eql :globally-active)) window time)
483 (send-wm-protocols-client-message window :wm_take_focus (or time 0)))
484
485 (defmethod set-focus ((input-model (eql :locally-active)) window time)
486 (when (eql (xlib:window-map-state window) :viewable)
487 (xlib:set-input-focus *display* window :pointer-root)
488 (send-wm-protocols-client-message window :wm_take_focus (or time 0))))
489
490 (defmethod set-focus ((input-model (eql :passive)) window timestamp)
491 (declare (ignorable timestamp))
492 (when (eql (xlib:window-map-state window) :viewable)
493 (xlib:set-input-focus *display* window :pointer-root)))
494
495 (defmethod set-focus ((input-model (eql :no-input)) window timestamp)
496 (declare (ignorable window timestamp))
497 (values))
498
499 (defmethod set-focus :after (input-model window timestamp)
500 (declare (ignorable timestamp))
501 (let ((states (netwm:net-wm-state window)))
502 (when (member :_net_wm_state_demands_attention states)
503 (setf (netwm:net-wm-state window)
504 (remove :_net_wm_state_demands_attention states)))))
505
506 ;; Next is methods for menu-3 who permit to manage any window :
507 ;; choose an action in the menu and click on a window
508 ;; to perform this action.
509
510 ;; protocol for treating events
511 (defgeneric menu-3-process (event widget &rest rest))
512
513 (defmethod menu-3-process (event widget &rest rest)
514 (declare (ignorable rest))
515 (event-process event widget)
516 nil)
517
518 (defmethod menu-3-process ((event pointer-event) (w base-widget) &rest rest)
519 (declare (ignorable event w rest))
520 (xlib:ungrab-pointer *display*)
521 t)
522
523 (defmethod menu-3-process ((event button-release) (app application) &key key)
524 (declare (ignorable event))
525 (cond ((eql key :move) (finish-move app *verbose-move* *move-mode*)))
526 (call-next-method))
527
528 (defmethod menu-3-process ((ev button-release) (dec decoration) &key key)
529 (cond ((eql key :resize) (finish-resize dec *verbose-resize* *resize-mode*))
530 ((eql key :move) (finish-move dec *verbose-resize* *resize-mode*)))
531 (call-next-method))
532
533 (defmethod menu-3-process ((ev motion-notify) (app application) &key key)
534 (when (eql key :move)
535 (activate-move-resize app *root* 'move-status *move-mode* *verbose-move*)
536 (application-active-p app)))
537
538 (defmethod menu-3-process ((ev motion-notify) (master decoration) &key key)
539 (when (or (eql key :resize) (eql key :move))
540 (multiple-value-call #'activate-move-resize
541 master *root*
542 (cond ((eql key :resize)
543 (values 'resize-status *resize-mode* *verbose-resize*))
544 ((eql key :move)
545 (values 'move-status *move-mode* *verbose-move*))))
546 (decoration-active-p master)))
547
548 (defmethod menu-3-process ((event enter-notify) (app application) &rest rest)
549 (declare (ignorable event rest))
550 (with-slots (window) (or (application-master app) app)
551 (xlib:grab-pointer window +pointer-event-mask+ :cursor *cursor-2*))
552 nil)
553
554 (defmethod menu-3-process ((event enter-notify) (master decoration) &rest rest)
555 (declare (ignorable event rest))
556 (with-slots (window) master
557 (xlib:grab-pointer window +pointer-event-mask+ :cursor *cursor-2*))
558 nil)
559
560 (defmethod menu-3-process ((event leave-notify) (app application) &rest rest)
561 (declare (ignore event rest))
562 (unless (application-master app) (xlib:ungrab-pointer *display*))
563 nil)
564
565 (defmethod menu-3-process ((event leave-notify) (master decoration) &rest rest)
566 (declare (ignore event master rest))
567 (xlib:ungrab-pointer *display*)
568 nil)
569
570 (defmethod menu-3-process ((ev button-press) (app application) &key key)
571 (with-slots (master window) app
572 (case key
573 (:kill (kill-client-window window))
574 (:close (close-widget app))
575 (:resize (when master (initialize-resize master nil ev)))
576 (:move (initialize-move (or master app) ev)))
577 (when (member key '(:close :kill)) (xlib:ungrab-pointer *display*))))
578
579 (defmethod menu-3-process ((ev button-press) (master decoration) &key key)
580 (menu-3-process ev (get-child master :application) :key key))
581
582 (defun define-menu-3 (action)
583 (lambda ()
584 (with-root-cursor (*cursor-2*)
585 (destroy-substructure (slot-value *root* 'menu3))
586 (loop for event = (get-next-event *display* :force-output-p t)
587 for widget = (lookup-widget (event-event-window event))
588 until (menu-3-process event widget :key action)))))
589
590 ;;;; Misc.
591
592 (defun make-desktop-menu (root callback-maker &key realize)
593 "Realize a root pop-up menu with as many entry as existing desktop. It attach
594 to each entry a callback realized with the given `callback-maker' function.
595 The callback-maker function should be a function of one argument of type
596 integer that will be the index of the desktop entry. It may return a lambda
597 or sub menu entries. If :realize is nil (the default value) it returns the
598 menu entries otherwise a pop-up-menu object is return."
599 (declare (type function callback-maker))
600 (loop with root-window = (widget-window root)
601 with names = (workspace-names root-window)
602 for i from 0 below (number-of-virtual-screens root-window)
603 for name = (or (pop names) (format nil "workspace ~D" i))
604 collect (cons name (funcall callback-maker i)) into entries
605 finally
606 (return (if realize (apply #'make-pop-up root entries) entries))))
607
608 (defun make-running-menu (root)
609 "Realize the root pop-up menu that shows all applications ordered by desktop."
610 (labels
611 ((raise (window index)
612 (lambda ()
613 (case (first (wm-state window))
614 (1 (change-vscreen root :n index))
615 (3 (uniconify (slot-value (lookup-widget window) 'icon))))
616 (put-on-top (lookup-widget window))))
617 (make-desktop-entries (i)
618 (loop for w in (screen-content i :iconify-p t)
619 for state = (= 1 (first (wm-state w)))
620 for name = (format nil "~:[[ ~A ]~;~A~]" state (wm-name w))
621 collect (cons name (raise w i)) into entries
622 finally
623 (return (or entries (lambda () (change-vscreen root :n i)))))))
624 (make-desktop-menu root #'make-desktop-entries :realize t)))
625
626 (defun make-menu-button-menu (master)
627 (let* ((app (get-child master :application))
628 (appw (widget-window app))
629 (net-wm-state (netwm:net-wm-state appw))
630 (data (make-array 1 :element-type 'xlib:card32))
631 (xc-msg (make-event :client-message :data data :type :_net_wm_desktop))
632 (shade-str (if (shaded-p app) "Un-shade" "Shade"))
633 (max-str (if (or (member :_net_wm_state_maximized_vert net-wm-state)
634 (member :_net_wm_state_maximized_horz net-wm-state))
635 "Un-maximize" "Maximize")))
636 (declare (type (simple-array xlib:card32 (1)) data))
637 (flet ((send-message (n)
638 (lambda ()
639 (setf (aref data 0) n)
640 (event-process xc-msg app))))
641 (make-pop-up
642 *root*
643 (cons "Send to" (make-desktop-menu *root* #'send-message))
644 (if (stick-p appw)
645 (cons "Un-pin" (send-message (current-desk)))
646 (cons "Pin " (send-message +any-desktop+)))
647 (cons max-str (lambda () (maximize app 1)))
648 (cons shade-str (lambda () (shade master)))
649 (cons "Close " (lambda () (close-widget app)))
650 (cons "Destroy" (lambda () (kill-client-window appw)))
651 (cons "Iconify" (lambda () (iconify app)))))))
652
653 (defun remove-window-from-client-lists (window root)
654 "Removes a window from the client lists root properties."
655 (with-slots ((rw window) client-list) root
656 (remwinhash window client-list)
657 (setf (netwm:net-client-list-stacking rw :mode :remove) window
658 (gnome:win-client-list rw :mode :remove) window
659 (netwm:net-client-list rw :mode :remove) window)))
660
661 (defun add-window-in-client-lists (window root)
662 "Add a window in the client lists root properties."
663 (with-slots ((rw window) client-list) root
664 (let ((up2date (getwinhash window client-list)))
665 (setf (getwinhash window client-list) window)
666 (update-client-list-stacking root)
667 (unless up2date
668 (setf (netwm:net-client-list rw :mode :append) window))
669 (if (member :win_hints_skip_winlist (gnome:win-hints window))
670 (setf (gnome:win-client-list rw :mode :remove) window)
671 (unless up2date
672 (setf (gnome:win-client-list rw :mode :append) window))))))
673
674 (defun update-client-list-stacking (root)
675 "Recompute and set the root property net_client_list_stacking."
676 (with-slots (window client-list) root
677 (loop for win in (query-application-tree window)
678 when (getwinhash win client-list) collect win into wins
679 finally (setf (netwm:net-client-list-stacking window) wins))))
680
681 (defun update-lists (app state root)
682 "Update root properties win_client_list, net_client_list(_stacking),
683 by adjoining or removing the given application depending of state."
684 (with-slots ((appw window) iconic-p) app
685 (case (if (and (= state 3) (not iconic-p)) 0 state)
686 (0 (remove-window-from-client-lists appw root))
687 (1 (add-window-in-client-lists appw root)))))
688
689 (defun window-not-decorable-p (window &optional type)
690 "Returns T if a window `should' not be decorated. Typically, a splash screen,
691 a desktop (e.g. nautilus) or a dock (e.g. gnome panels) will be assumed as
692 non-decorable windows, as well as windows holding the motif_wm_hints with the
693 flag `no decoration at all'."
694 (let ((netwm-type (or type (netwm:net-wm-window-type window))))
695 (or (eql (motif-wm-decoration window) :OFF)
696 (member :_net_wm_window_type_splash netwm-type)
697 (member :_net_wm_window_type_desktop netwm-type)
698 (member :_net_wm_window_type_dock netwm-type))))
699
700 (defun procede-decoration (window)
701 "Decore, if necessary, add/update properties, map or not, etc a window."
702 (let* ((time (or (ignore-errors (net-wm-user-time window)) 1))
703 (rw (xlib:drawable-root window))
704 (scr-num (current-vscreen rw))
705 (application (create-application window nil))
706 (win-workspace (or (window-desktop-num window) +any-desktop+))
707 (stick-p (stick-p window)))
708 (xlib:add-to-save-set window)
709 (unless (or stick-p (< -1 win-workspace (number-of-virtual-screens rw)))
710 (setf win-workspace scr-num))
711 (setf (window-desktop-num window) win-workspace)
712 (cond ((not (or (= win-workspace scr-num) stick-p))
713 (with-event-mask (rw)
714 (setf (wm-state window) 1)
715 (xlib:unmap-window window)
716 (unless (window-not-decorable-p window)
717 (decore-application window application :map nil))
718 (update-lists application 1 *root*)))
719 ((window-not-decorable-p window (application-type application))
720 (setf (netwm:net-frame-extents window) (values 0 0 0 0))
721 (setf (wm-state window) 1)
722 (xlib:map-window window))
723 (t (decore-application window application :map t)))
724 (with-slots (wants-focus-p input-model type) application
725 (unless (member :_net_wm_window_type_desktop type)
726 (unless (or (zerop time) (eq input-model :no-input))
727 (setf wants-focus-p *focus-new-mapped-window*)))
728 (when (member :_net_wm_window_type_dock type)
729 (update-workarea-property *root*)))))
730
731 ;;;; The main loop.
732
733 (define-condition exit-eclipse (error)
734 ((close-application-p
735 :initform nil :initarg :close-application-p
736 :type boolean :reader close-application-p)))
737
738 (defun eclipse-internal-loop ()
739 (let ((close-display-p t)
740 (exit 0))
741
742 ;; Sets the root window pop-up menu
743 (when *menu-1-exit-p*
744 (nconc *menu-1-items* (acons "Exit" (lambda () (setf exit 1)) '())))
745 (with-slots (menu1 menu3) *root*
746 (setf menu1 (apply #'make-pop-up *root* *menu-1-items*)
747 menu3 (make-pop-up *root*
748 (cons "Move" (define-menu-3 :move))
749 (cons "Resize" (define-menu-3 :resize))
750 (cons "Close" (define-menu-3 :close))
751 (cons "Kill" (define-menu-3 :kill)))))
752
753 ;; Dress windows already displayed at start time.
754 (flet ((ignorable-window-p (window)
755 (let* ((wmh (xlib:get-property window :WM_HINTS))
756 (initial-state (and wmh (logbitp 1 (car wmh)) (third wmh)))
757 (wm-state (car (wm-state window))))
758 (or
759 (eql (xlib:window-override-redirect window) :ON)
760 (when (or (eq initial-state 0) (eq wm-state 0))
761 (xlib:unmap-window window)
762 t)
763 (and (not wm-state)
764 (eq (xlib:window-map-state window) :unmapped))))))
765
766 (xlib:with-server-grabbed (*display*)
767 (mapc (lambda (w)
768 (unless (ignore-errors (ignorable-window-p w))
769 (procede-decoration w)))
770 (xlib:query-tree *root-window*))))
771 ;; Main loop
772 (loop
773 (handler-case
774 (let ((event (get-next-event *display* :discard-p t :timeout 2)))
775 (when event
776 (with-slots (event-window) event
777 (event-process event (lookup-widget event-window)))
778 (xlib:display-finish-output *display*))
779 (when pt:preprogrammed-tasks (pt:execute-preprogrammed-tasks))
780 (with-slots (sm-conn) *root*
781 (when sm-conn (handle-session-manager-request sm-conn *root*)))
782 (case exit
783 (1 (loop for val being each hash-value in *widget-table*
784 when (application-p val)
785 if close-display-p do (close-widget val)
786 else do (undecore-application val))
787 (setf exit 2))
788 (2 (when (root-sm-conn *root*)
789 (close-sm-connection *root* :exit-p nil))
790 (xlib:display-finish-output *display*)
791 (setf (xlib:window-event-mask *root-window*) 0)
792 (let ((win (netwm:net-supporting-wm-check *root-window*)))
793 (xlib:destroy-window win))
794 (xlib:display-finish-output *display*)
795 (return))))
796 (exit-eclipse (c)
797 (setf close-display-p (close-application-p c))
798 (setf exit 1))
799 (end-of-file (c) (error c))
800 (already-handled-xerror () nil)
801 (error (c) (handle-error-condition c))))
802 (format t "~%Main loop exited~%")))

  ViewVC Help
Powered by ViewVC 1.1.5