wm.lisp 35.1 KB
Newer Older
1
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
2
;;; $Id: wm.lisp,v 1.61 2010-04-02 09:57:53 ihatchondo Exp $
3
;;;
james's avatar
james committed
4
5
6
7
8
9
10
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
;;; Copyright (C) 2000
;;;          Julien BONINFANTE,
;;;          Aymeric LACORTE,
;;;          Jocelyn FRECHOT
;;; contact : hatchond@yahoo.fr
11
;;;
james's avatar
james committed
12
13
14
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation.
15
;;;
james's avatar
james committed
16
17
18
19
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
20
;;;
james's avatar
james committed
21
22
23
24
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

25
;; usefull for having a quick and short garbage collection.
james's avatar
james committed
26
27
28
#+:cmu (setf extensions:*bytes-consed-between-gcs* 400000
	     extensions:*gc-verbose* nil)

29
(in-package :ECLIPSE-INTERNALS)
james's avatar
james committed
30
31
32

;;;; Decoration

33
(defclass decoration (base-widget)
james's avatar
james committed
34
35
36
  ((children :initarg :children :accessor decoration-children)
   (active-p :initform nil :accessor decoration-active-p)
   (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
40
41
   (application-gravity 
     :initarg :application-gravity
     :initform :north-west
Iban Hatchondo's avatar
Iban Hatchondo committed
42
43
44
     :accessor decoration-application-gravity))
  (:documentation "Top level widget for application that will have a set of 
   decoration (e.g: those for which window-not-decorable-p will return NIL)."))
james's avatar
james committed
45

hatchond's avatar
hatchond committed
46
47
48
(defun decoration-p (widget)
  (typep widget 'decoration))

Iban Hatchondo's avatar
Iban Hatchondo committed
49
50
51
(defun title-bar-horizontal-p (master)
  (eq :horizontal (style-title-bar-direction (decoration-frame-style master))))

james's avatar
james committed
52
(defconstant +decoration-event-mask+
Iban Hatchondo's avatar
Iban Hatchondo committed
53
54
  '(:substructure-redirect :substructure-notify
    :visibility-change :enter-window :owner-grab-button))
james's avatar
james committed
55
56

(defmethod get-child ((master decoration) label &key window)
Iban Hatchondo's avatar
Iban Hatchondo committed
57
  "Returns the child widget/window labeled `label' or nil if no such
Iban Hatchondo's avatar
Iban Hatchondo committed
58
  child exists. label is a keyword."
59
60
  (let ((widget (getf (decoration-children master) label)))
    (if (and widget window) (widget-window widget) widget)))
james's avatar
james committed
61
62

(defmethod decoration-wm-hints ((master decoration))
Iban Hatchondo's avatar
Iban Hatchondo committed
63
  "Returns as a multiple value: minw minh maxw maxh incw inch basew baseh."
Iban Hatchondo's avatar
Iban Hatchondo committed
64
  (with-slots (frame-style (wmsh wm-size-hints)) master
Iban Hatchondo's avatar
Iban Hatchondo committed
65
    (declare (type (vector integer 8) wmsh))
Iban Hatchondo's avatar
Iban Hatchondo committed
66
    (with-slots ((hm hmargin) (vm vmargin)) frame-style
Iban Hatchondo's avatar
Iban Hatchondo committed
67
68
69
70
      (values (+ hm (svref wmsh 0)) (+ vm (svref wmsh 1))
	      (+ hm (svref wmsh 2)) (+ vm (svref wmsh 3))
	      (svref wmsh 4) (svref wmsh 5)
	      (+ hm (svref wmsh 6)) (+ vm (svref wmsh 7))))))
james's avatar
james committed
71

hatchond's avatar
hatchond committed
72
73
74
(defmethod focus-widget ((master decoration) timestamp)
  (with-slots (window input-model) (get-child master :application)
    (set-focus input-model window timestamp)))
james's avatar
james committed
75

76
77
78
79
80
81
(defmethod focused-p ((master decoration))
  (focused-p (get-child master :application)))

(defmethod widget-position-fix-p ((master decoration))
  (widget-position-fix-p (get-child master :application)))

hatchond's avatar
hatchond committed
82
83
84
85
86
87
88
89
(defmethod shaded-p ((widget decoration))
  (with-slots (window) (get-child widget :application)
    (member :_net_wm_state_shaded (netwm:net-wm-state window))))

(defmethod shade ((master decoration))
  (with-slots (window frame-style) master
    (let* ((app-win (get-child master :application :window t))
	   (netwm-prop (netwm:net-wm-state app-win))
90
	   (gnome-prop (or (gnome:win-state app-win :result-type t) 0)))
hatchond's avatar
hatchond committed
91
      (setf gnome-prop (logand gnome-prop #x3DF)) ; supress :win_state_shaded
92
      (if (member :_net_wm_state_shaded netwm-prop)
hatchond's avatar
hatchond committed
93
94
95
	  (with-event-mask (window) 
	    ;; unshade.
	    (xlib:map-window app-win)
Iban Hatchondo's avatar
Iban Hatchondo committed
96
	    (xlib:map-window window)
hatchond's avatar
hatchond committed
97
98
99
100
101
102
103
	    (resize-from (get-child master :application))
	    (setf netwm-prop (remove :_net_wm_state_shaded netwm-prop))
	    (setf netwm-prop (remove :_net_wm_state_hidden netwm-prop))
	    (unless (stick-p app-win)
	      (setf (window-desktop-num app-win) (current-desk))))
	  (with-event-mask (window)	    
	    ;; shade.
104
	    (with-slots ((vm vmargin) (hm hmargin)) frame-style
hatchond's avatar
hatchond committed
105
	      (if (title-bar-horizontal-p master)
106
107
		  (unless (= 0 vm) (setf (xlib:drawable-height window) vm))
		  (unless (= 0 hm) (setf (xlib:drawable-width window) hm))))
hatchond's avatar
hatchond committed
108
109
110
	    (xlib:unmap-window app-win)
	    (pushnew :_net_wm_state_shaded netwm-prop)
	    (pushnew :_net_wm_state_hidden netwm-prop)
111
	    (incf gnome-prop 32)))	; add win_state_shaded
hatchond's avatar
hatchond committed
112
113
114
      (setf (netwm:net-wm-state app-win) netwm-prop
	    (gnome:win-state app-win) gnome-prop))))

Iban Hatchondo's avatar
Iban Hatchondo committed
115
116
117
118
119
120
121
122
123
124
125
126
(defmethod close-widget ((widget decoration))
  (close-widget (get-child widget :application)))

(defmethod put-on-top ((widget decoration))
  (put-on-top (get-child widget :application)))

(defmethod put-on-bottom ((widget decoration))
  (put-on-bottom (get-child widget :application)))

(defmethod maximize ((widget decoration) code &key (fill-p *maximize-fill*))
  (maximize (get-child widget :application) code :fill-p fill-p))

Iban Hatchondo's avatar
Iban Hatchondo committed
127
(defmethod (setf decoration-frame-style) :after (astyle (master decoration))
128
  (with-slots (window children wm-size-hints) master
Iban Hatchondo's avatar
Iban Hatchondo committed
129
    (with-slots (left-margin top-margin (hm hmargin) (vm vmargin)) astyle
130
      (with-event-mask (window)
hatchond's avatar
hatchond committed
131
	(let* ((application (getf children :application))
132
133
134
135
136
137
138
139
140
141
142
	       (icon (slot-value application 'icon))
	       (app-win (slot-value application 'window)))
	  (loop for (key val) on children by #'cddr
		unless (or (eq key :application) (eq key :icon))
		do (when (typep val 'edge)
		     (xlib:destroy-window (widget-window val)))
		   (remove-widget val))
	  (setf children (list :application application :icon icon)
		wm-size-hints (recompute-wm-normal-hints app-win hm vm))
	  (let ((width (+ (xlib:drawable-width app-win) hm))
		(height (+ (xlib:drawable-height app-win) vm)))
Iban Hatchondo's avatar
Iban Hatchondo committed
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
148
149
	    (make-title-bar master (wm-name app-win))
	    (update-edges-geometry master)
	    (xlib:map-subwindows window))
150
	  (setf (application-frame-style application) astyle)
151
152
	  (cond ((shaded-p application)
		 (if (title-bar-horizontal-p master)
153
154
		     (unless (= 0 vm) (setf (xlib:drawable-height window) vm))
		     (unless (= 0 hm) (setf (xlib:drawable-width window) hm)))
155
		 (xlib:unmap-window app-win))
hatchond's avatar
hatchond committed
156
157
		((application-iconic-p application)
		 (xlib:unmap-window app-win))))))))
158

159
160
161
(defmethod dispatch-repaint ((master decoration) 
			     &key (focus (focused-p master)))
  (declare (optimize (speed 3) (safety 1)))
162
163
164
  (with-slots (parts-to-redraw-on-focus theme) (decoration-frame-style master)
    (declare (type theme theme))
    (mapc #'(lambda (k) (repaint (get-child master k) theme focus))
165
	  parts-to-redraw-on-focus)))
166

Iban Hatchondo's avatar
Iban Hatchondo committed
167
(defun recompute-wm-normal-hints (window hmargin vmargin)
Iban Hatchondo's avatar
Iban Hatchondo committed
168
169
170
171
  "Returns two value: a vector representing the wm-normal-hints property and
  the window gravity of the designed window. The wm-normal-hints property is
  recomputed in order to reflect the margin that a top level decoration widget
  (aka master) might introduce."
172
  (let ((hints (or (ignore-errors (wm-normal-hints window))
Iban Hatchondo's avatar
Iban Hatchondo committed
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
		   (xlib:make-wm-size-hints)))
	(max-ww (screen-width))
	(max-hh (screen-height)))
    (symbol-macrolet ((min-w (xlib:wm-size-hints-min-width hints))
		      (min-h (xlib:wm-size-hints-min-height hints))
		      (max-w (xlib:wm-size-hints-max-width hints))
		      (max-h (xlib:wm-size-hints-max-height hints))
		      (inc-w (xlib:wm-size-hints-width-inc hints))
		      (inc-h (xlib:wm-size-hints-height-inc hints))
		      (base-w (xlib:wm-size-hints-base-width hints))
		      (base-h (xlib:wm-size-hints-base-height hints))
		      (g (xlib:wm-size-hints-win-gravity hints)))
       (unless (eq g :static)
	 (decf max-ww hmargin)
	 (decf max-hh vmargin))
       (setf min-w (max (or (or min-w base-w) 1) 1)
	     min-h (max (or (or min-h base-h) 1) 1)
	     base-w (max (or (or base-w min-w) 1) 1)
	     base-h (max (or (or base-h min-h) 1) 1)
	     inc-w (or inc-w 1) 
	     inc-h (or inc-h 1))
      (setf max-ww (- max-ww (mod (- max-ww base-w) inc-w))
	    max-hh (- max-hh (mod (- max-hh base-h) inc-h)))
      (unless (and max-w (<= min-w max-w max-ww)) (setf max-w max-ww))
      (unless (and max-h (<= min-h max-h max-hh)) (setf max-h max-hh))
      (setf min-w (min min-w max-w)
	    min-h (min min-h max-h)
	    base-w (min base-w max-w)
	    base-h (min base-h max-h))
      (multiple-value-bind (w h) (drawable-sizes window)
	(unless (<= min-w w max-w) 
	  (setf (xlib:drawable-width window) (min (max min-w w) max-w)))
	(unless (<= min-h h max-h) 
	  (setf (xlib:drawable-height window) (min (max min-h h) max-h))))
      (values (vector min-w min-h max-w max-h inc-w inc-h base-w base-h) g))))

;;;; Decoration creation tools.

211
(defun make-menu-button (master parent-window)
212
  (with-slots (children frame-style) master
213
214
215
    (when (frame-item-exist-p frame-style :menu-button)
      (let ((pixmaps (frame-item-pixmaps frame-style :menu-button))
	    (horizontal-p (title-bar-horizontal-p master)))
Iban Hatchondo's avatar
Iban Hatchondo committed
216
	(declare (type pixmaps pixmaps))
217
218
219
	(multiple-value-bind (width height) (drawable-sizes (aref pixmaps 0))
	  (multiple-value-bind (tw th) (drawable-sizes parent-window)
	    (setf (getf children :menu-button)
220
221
222
223
224
225
226
227
		  (create-button 'menu-button
		    :parent parent-window :master master
		    :background (aref pixmaps 0) 
		    :item (aref pixmaps 1)
		    :width width :height height
		    :event-mask '(:owner-grab-button . #.+push-button-mask+)
		    :y (if horizontal-p (ash (- th height) -1) (- th height))
		    :x (if horizontal-p 0 (ash (- tw width) -1))))))))))
228
229

(defun make-buttons-bar (master parent-window)
Iban Hatchondo's avatar
Iban Hatchondo committed
230
  (with-slots (children (astyle frame-style)) master
231
232
233
234
235
236
    (flet ((make-container (horizontal-p)
	     (xlib:create-window 
	        :parent parent-window
		:x 0 :y 0 :width 1 :height 1 
		:background :parent-relative 
		:gravity (if horizontal-p :north-east :north-west))))
Iban Hatchondo's avatar
Iban Hatchondo committed
237
      (loop initially (when (zerop (style-nb-buttons astyle)) (return))
238
239
240
241
242
	    with horizontal-p = (title-bar-horizontal-p master)
	    with container = (make-container horizontal-p)
	    and (x y width height) = '(0 0 0 0)
	    for type in '(iconify-button maximize-button close-button)
	    for child in '(:icon-b :maximize :close)
Iban Hatchondo's avatar
Iban Hatchondo committed
243
	    for pixmaps of-type pixmaps = (frame-item-pixmaps astyle child)
244
	    for bkgrd = (aref pixmaps 0)
Iban Hatchondo's avatar
Iban Hatchondo committed
245
	    when (frame-item-exist-p astyle child)
246
247
248
	    do (multiple-value-setq (width height) (drawable-sizes bkgrd))
	       (setf (getf children child)
		     (create-button type
249
250
251
252
		       :parent container :master master
		       :background bkgrd :item (aref pixmaps 1)
		       :x x :y y :width width :height height
		       :event-mask +push-button-mask+))
253
254
255
256
257
258
259
260
261
262
263
264
265
	       (if horizontal-p (incf x width) (incf y height))
	    finally 
	      (multiple-value-bind (w h) (drawable-sizes parent-window)
		(if (zerop x) (incf x width) (incf y height))
		(setf (drawable-sizes container) (values x y)
		      (window-position container)
		      (if horizontal-p
			  (values (- w x) (ash (- h y) -1))
			  (values (ash (- w x) -1) 0)))
		(xlib:map-subwindows container)
		(return container))))))	    

(defun make-title-bar (master name)
266
  (with-slots (children frame-style) master
267
268
269
270
271
272
273
274
275
    (unless (eq :none (style-title-bar-position frame-style))
      (let* ((title-pos (style-title-bar-position frame-style))
	     (horizontal-p (case title-pos ((:top :bottom) t)))
	     (parent-widget (getf children title-pos))
	     (parent-window (widget-window parent-widget))
	     (button-container (make-buttons-bar master parent-window))
	     (menu-button (make-menu-button master parent-window))
	     (pixmaps (frame-item-pixmaps frame-style title-pos))
	     (bcw 0) (bch 0) (mbw 0) (mbh 0) (title))
Iban Hatchondo's avatar
Iban Hatchondo committed
276
	(declare (type pixmaps pixmaps))
277
278
279
280
281
282
	(when button-container
	  (multiple-value-setq (bcw bch) (drawable-sizes button-container)))
	(when menu-button
	  (multiple-value-setq (mbw mbh)
	    (drawable-sizes (widget-window menu-button))))
	(setf title
283
284
285
286
287
288
	      (create-button 'title-bar
		:parent parent-window :master master
		:width 1 :height 1
		:x (if horizontal-p mbw 0) :y (if horizontal-p 0 bch)
		:event-mask +push-button-mask+
		:background (aref pixmaps 0) :item name)
289
290
291
	      (slot-value title 'parent) parent-window
	      (getf children :title-bar) title
	      (xlib:window-background parent-window) :parent-relative
292
	      (xlib:window-event-mask parent-window) 0)
293
294
295
296
297
	(if horizontal-p 
	    (setf (slot-value title 'hmargin) (+ bcw mbw))
	    (setf (slot-value title 'vmargin) (+ bch mbh)))
	(xlib:map-subwindows parent-window)
	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
302
303
304
305
306
307
308
309
310
311
312
313
314
315
    (multiple-value-bind (w h) (frame-item-sizes style edge-key)
      (case edge-key
	(:top (values top-left-w 0))
	(:right (values (- width w) top-right-h))
	(:bottom (values bottom-left-w (- height h)))
	(:left (values 0 top-left-h))
	(:top-left (values 0 0))
	(:top-right (values (- width w) 0))
	(:bottom-right (values (- width w) (- height h)))
	(:bottom-left (values 0 (- height h)))))))

(defvar *frame-parts*
  '(:right :left :top :bottom :top-left :top-right :bottom-left :bottom-right))

(defun make-frame-parts (master)
Iban Hatchondo's avatar
Iban Hatchondo committed
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*
Iban Hatchondo's avatar
Iban Hatchondo committed
319
	    for pixmaps of-type pixmaps = (frame-item-pixmaps astyle child)
320
321
	    for hilighted = (aref pixmaps 1)
	    for event-mask = (if hilighted +std-button-mask+ +edge-event-mask+)
Iban Hatchondo's avatar
Iban Hatchondo committed
322
	    when (frame-item-exist-p astyle child) do
Iban Hatchondo's avatar
Iban Hatchondo committed
323
	     (multiple-value-bind (x y)
Iban Hatchondo's avatar
Iban Hatchondo committed
324
325
		 (edge-position astyle child width height)
	       (multiple-value-bind (w h) (frame-item-sizes astyle child)
Iban Hatchondo's avatar
Iban Hatchondo committed
326
327
328
329
330
331
		 (setf (getf children child)
		       (create-button (intern (symbol-name child) :eclipse)
			 :parent window :master master
			 :background (aref pixmaps 0) :item hilighted
			 :event-mask event-mask
			 :x x :y y :width w :height h))))))))
james's avatar
james committed
332

Iban Hatchondo's avatar
Iban Hatchondo committed
333
334
;; Public.

james's avatar
james committed
335
(defun update-edges-geometry (master)
336
337
  (declare (optimize (speed 3) (safety 0)))
  (declare (inline update-edges-geometry))
hatchond's avatar
hatchond committed
338
339
340
341
342
343
344
  (macrolet
      ((update (edge size &rest frame-style-slots-size)
	 `(when ,edge
	    (setf (,(intern (format nil "DRAWABLE-~a" (symbol-name size)) :xlib)
		   (widget-window ,edge))
	          (with-slots (,@frame-style-slots-size) frame-style
		    (declare (type xlib:card16 ,@frame-style-slots-size))
345
		    (max 1 (- ,size ,@frame-style-slots-size)))))))
hatchond's avatar
hatchond committed
346
347
348
349
350
351
352
353
354
355
356
    (with-slots (frame-style window) master
      (multiple-value-bind (width height) (drawable-sizes window)
	(declare (type xlib:card16 width height))
	(update (get-child master :top) width top-left-w top-right-w)
	(update (get-child master :left) height top-left-h bottom-left-h)
	(update (get-child master :right) height top-right-h bottom-right-h)
	(update (get-child master :bottom) width bottom-left-w bottom-right-w)
	(update-title-bar-sizes (get-child master :title-bar))))))

(defun update-title-bar-sizes (title-bar)
  (declare (optimize (speed 3) (safety 0)))
357
  (when title-bar
358
359
    (with-slots (parent window (vm vmargin) (hm hmargin)) title-bar
      (declare (type xlib:card16 vm hm))
360
361
362
      (multiple-value-bind (width height) (drawable-sizes parent)
	(declare (type xlib:card16 width height))
	(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
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
                   (values (max ax (- x left-margin))
                           (max ay (- y top-margin)))))))
        (if (and hint (xlib:wm-size-hints-user-specified-position-p hint))
            (let ((x (xlib:wm-size-hints-x hint))
                  (y (xlib:wm-size-hints-y hint)))
              (if (and x y)
                  (case (xlib:wm-size-hints-win-gravity hint)
                    (:north-east (values (- x hmargin) y))
                    (:south-east (values (- x hmargin) (- y vmargin)))
                    (:south-west (values x (- y vmargin)))
                    (:static (values (- x left-margin) (- y top-margin)))
                    (t (values x y)))
                  (progn
                    (format t "user-specified-position-p t but x or y isn't.")
                    (default-coordinates))))
            (default-coordinates))))))
391

392
(defun make-decoration (app-window application &key theme)
Iban Hatchondo's avatar
Iban Hatchondo committed
393
  "Returns a newly initialized decoration to hold the given application."
394
  (unless theme (setf theme (root-decoration-theme *root*)))
395
396
397
398
399
  (let* ((netwm-states (ignore-errors (netwm:net-wm-state app-window)))
         (dstyle (find-decoration-frame-style theme app-window))
         (style dstyle)
         (fullscreen-p (member :_net_wm_state_fullscreen netwm-states)))
    (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
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
      (multiple-value-bind (wm-sizes gravity)
          (recompute-wm-normal-hints app-window hmargin vmargin)
        (multiple-value-bind (width height) (drawable-sizes app-window)
          (multiple-value-bind (x y) (initial-coordinates app-window style)
            (let* ((window (xlib:create-window
                               :parent (xlib:drawable-root app-window)
                               :x x :y y
                               :width (+ width hmargin)
                               :height (+ height vmargin)
                               :background background
                               :event-mask +decoration-event-mask+
                               :do-not-propagate-mask
                               '(:button-press :button-release)))
                   (master (make-instance 'decoration
                               :window window
                               :old-frame-style dstyle :frame-style style
                               :children (list :application application)
                               :application-gravity gravity
                               :wm-size-hints wm-sizes)))
              (make-frame-parts master)
              (make-title-bar master (wm-name app-window))
              (update-edges-geometry master)
              (with-slots (icon (fgeometry full-geometry)) application
                (setf (getf (decoration-children master) :icon) icon
                      (slot-value icon 'master) master
                      (slot-value application 'master) master
                      (xlib:drawable-border-width app-window) 0)
                (when fullscreen-p
                  (multiple-value-bind (x y w h)
                      (fullscreen-sizes (xlib:window-display app-window))
                    (configure-window app-window :x x :y y :width w :height h))
                  (setf (geometry fgeometry) (values x y width height))))
              master)))))))
435
436

(defun decore-application (window application &key (map t) theme)
Iban Hatchondo's avatar
Iban Hatchondo committed
437
  "Decores an application and map the resulting decoration as indicated
Iban Hatchondo's avatar
Iban Hatchondo committed
438
  by the :map keyword argument. (default value is T).
Iban Hatchondo's avatar
Iban Hatchondo committed
439
  Returns the newly created decoration instance."
440
  (let* ((master (make-decoration window application :theme theme))
441
442
443
         (master-window (widget-window master))
         (left-margin (style-left-margin (decoration-frame-style master)))
         (top-margin (style-top-margin (decoration-frame-style master))))
james's avatar
james committed
444
445
446
    (with-event-mask (master-window)
      (xlib:map-subwindows master-window))
    (with-event-mask (master-window (when map +decoration-event-mask+))
447
448
      (xlib:reparent-window window master-window left-margin top-margin)
      (send-configuration-notify window))
449
    (setf (application-frame-style application) (decoration-frame-style master))
450
451
452
453
454
455
456
457
458
    ;; handle maximized states.
    (let* ((prop (netwm:net-wm-state window))
           (vert-p (member :_net_wm_state_maximized_vert prop))
           (horz-p (member :_net_wm_state_maximized_horz prop)))
      (when (or vert-p horz-p)
        (setf prop (delete :_net_wm_state_maximized_vert prop))
        (setf prop (delete :_net_wm_state_maximized_horz prop))
        (setf (netwm:net-wm-state window) prop)
        (maximize application (if (and horz-p vert-p) 1 (if horz-p 3 2)))))
459
460
461
    (when map (xlib:map-window window))
    master))

james's avatar
james committed
462
463
;;;; Focus management. According to ICCCM

464
(defgeneric set-focus (input-model window timestamp)
465
466
467
468
  (:documentation 
   "Set focus to the given window according to the input model.
   Input model can be :globally-active :locally-active :passive :no-input.
   For more information on the input-model sementic see ICCCM 4.1.7"))
james's avatar
james committed
469

470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
(defmethod set-focus :around (input-model window timestamp)
  ;; If we have a valid timestamp then assign focus directly
  ;; otherwise set the net-active-window to provoke a property-notify event
  ;; on the root-property-holder. Then the property-notify event will handled
  ;; and will assign the focus with a valid timestamp.
  ;; It seems a bit complicated but this is the bettter way I found to not 
  ;; violate the ICCCM (section 4.1.7).
  (if (and timestamp (> timestamp 0))
      (and (next-method-p) (call-next-method))
      (with-slots ((ww window)) (root-property-holder *root*)
	(setf (netwm:net-active-window ww) window))))

(defmethod set-focus ((input-model (eql :globally-active)) window time)
  (send-wm-protocols-client-message window :wm_take_focus (or time 0)))

(defmethod set-focus ((input-model (eql :locally-active)) window time)
hatchond's avatar
hatchond committed
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))))
james's avatar
james committed
489
490
491

(defmethod set-focus ((input-model (eql :passive)) window timestamp)
  (declare (ignorable timestamp))
hatchond's avatar
hatchond committed
492
  (when (eql (xlib:window-map-state window) :viewable)
493
    (xlib:set-input-focus *display* window :pointer-root)))
james's avatar
james committed
494
495
496

(defmethod set-focus ((input-model (eql :no-input)) window timestamp)
  (declare (ignorable window timestamp))
497
498
  (values))

499
500
501
502
503
504
505
(defmethod set-focus :after (input-model window timestamp)
  (declare (ignorable timestamp))
  (let ((states (netwm:net-wm-state window)))
    (when (member :_net_wm_state_demands_attention states)
      (setf (netwm:net-wm-state window)
            (remove :_net_wm_state_demands_attention states)))))

506
507
508
509
510
;; Next is methods for menu-3 who permit to manage any window :
;;  choose an action in the menu and click on a window
;;  to perform this action.

;; protocol for treating events
hatchond's avatar
hatchond committed
511
(defgeneric menu-3-process (event widget &rest rest))
512
513

(defmethod menu-3-process (event widget &rest rest)
514
515
516
  (declare (ignorable rest))
  (event-process event widget)
  nil)
517

hatchond's avatar
hatchond committed
518
(defmethod menu-3-process ((event pointer-event) (w base-widget) &rest rest)
519
  (declare (ignorable event w rest))
hatchond's avatar
hatchond committed
520
521
  (xlib:ungrab-pointer *display*)
  t)
522

523
524
525
526
527
528
529
530
531
532
533
534
535
536
(defmethod menu-3-process ((event button-release) (app application) &key key)
  (declare (ignorable event))
  (cond ((eql key :move) (finish-move app *verbose-move* *move-mode*)))
  (call-next-method))

(defmethod menu-3-process ((ev button-release) (dec decoration) &key key)
  (cond	((eql key :resize) (finish-resize dec *verbose-resize* *resize-mode*))
	((eql key :move) (finish-move dec *verbose-resize* *resize-mode*)))
  (call-next-method))

(defmethod menu-3-process ((ev motion-notify) (app application) &key key)
  (when (eql key :move)
    (activate-move-resize app *root* 'move-status *move-mode* *verbose-move*)
    (application-active-p app)))
537

538
(defmethod menu-3-process ((ev motion-notify) (master decoration) &key key)
539
540
541
542
543
544
545
546
  (when (or (eql key :resize) (eql key :move))
    (multiple-value-call #'activate-move-resize
      master *root*
      (cond ((eql key :resize)
	     (values 'resize-status *resize-mode* *verbose-resize*))
	    ((eql key :move)
	     (values 'move-status *move-mode* *verbose-move*))))
    (decoration-active-p master)))
547

548
549
550
551
552
553
(defmethod menu-3-process ((event enter-notify) (app application) &rest rest)
  (declare (ignorable event rest))
  (with-slots (window) (or (application-master app) app)
    (xlib:grab-pointer window +pointer-event-mask+ :cursor *cursor-2*))
  nil)

554
(defmethod menu-3-process ((event enter-notify) (master decoration) &rest rest)
555
  (declare (ignorable event rest))
556
557
558
559
  (with-slots (window) master
    (xlib:grab-pointer window +pointer-event-mask+ :cursor *cursor-2*))
  nil)

560
561
562
563
564
(defmethod menu-3-process ((event leave-notify) (app application) &rest rest)
  (declare (ignore event rest))
  (unless (application-master app) (xlib:ungrab-pointer *display*))
  nil)

565
(defmethod menu-3-process ((event leave-notify) (master decoration) &rest rest)
566
  (declare (ignore event master rest))
567
  (xlib:ungrab-pointer *display*)
james's avatar
james committed
568
569
  nil)

570
571
572
573
574
575
576
577
578
(defmethod menu-3-process ((ev button-press) (app application) &key key)
  (with-slots (master window) app
    (case key
      (:kill (kill-client-window window))
      (:close (close-widget app))
      (:resize (when master (initialize-resize master nil ev)))
      (:move (initialize-move (or master app) ev)))
    (when (member key '(:close :kill)) (xlib:ungrab-pointer *display*))))

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
583
584
585
586

(defun define-menu-3 (action)
  (lambda ()
    (with-root-cursor (*cursor-2*)
      (destroy-substructure (slot-value *root* 'menu3))
      (loop for event = (get-next-event *display* :force-output-p t)
hatchond's avatar
hatchond committed
587
	    for widget = (lookup-widget (event-event-window event))
588
589
590
	    until (menu-3-process event widget :key action)))))

;;;; Misc.
james's avatar
james committed
591

592
593
(defun make-desktop-menu (root callback-maker &key realize)
  "Realize a root pop-up menu with as many entry as existing desktop. It attach
594
595
596
597
598
  to each entry a callback realized with the given `callback-maker' function.
  The callback-maker function should be a function of one argument of type
  integer that will be the index of the desktop entry. It may return a lambda
  or sub menu entries. If :realize is nil (the default value) it returns the
  menu entries otherwise a pop-up-menu object is return."
Iban Hatchondo's avatar
Iban Hatchondo committed
599
  (declare (type function callback-maker))
hatchond's avatar
hatchond committed
600
601
602
603
  (loop with root-window = (widget-window root)
	with names = (workspace-names root-window)
	for i from 0 below (number-of-virtual-screens root-window)
	for name = (or (pop names) (format nil "workspace ~D" i))
604
605
606
607
608
609
	collect (cons name (funcall callback-maker i)) into entries
	finally
	  (return (if realize (apply #'make-pop-up root entries) entries))))

(defun make-running-menu (root)
  "Realize the root pop-up menu that shows all applications ordered by desktop."
610
611
612
613
614
615
616
  (labels
      ((raise (window index)
	 (lambda ()
	   (case (first (wm-state window))
	     (1 (change-vscreen root :n index))
	     (3 (uniconify (slot-value (lookup-widget window) 'icon))))
	   (put-on-top (lookup-widget window))))
617
618
       (make-desktop-entries (i)
	 (loop for w in (screen-content i :iconify-p t)
619
	       for state = (= 1 (first (wm-state w)))
620
621
622
623
	       for name = (format nil "~:[[ ~A ]~;~A~]" state (wm-name w))
	       collect (cons name (raise w i)) into entries
	       finally
	        (return (or entries (lambda () (change-vscreen root :n i)))))))
624
625
626
627
628
629
    (make-desktop-menu root #'make-desktop-entries :realize t)))

(defun make-menu-button-menu (master)
  (let* ((app (get-child master :application))
	 (appw (widget-window app))
	 (net-wm-state (netwm:net-wm-state appw))
630
631
	 (data (make-array 1 :element-type 'xlib:card32))
	 (xc-msg (make-event :client-message :data data :type :_net_wm_desktop))
632
633
634
635
	 (shade-str (if (shaded-p app) "Un-shade" "Shade"))
	 (max-str (if (or (member :_net_wm_state_maximized_vert net-wm-state)
			  (member :_net_wm_state_maximized_horz net-wm-state))
		      "Un-maximize" "Maximize")))
636
    (declare (type (simple-array xlib:card32 (1)) data))
637
638
    (flet ((send-message (n)
	     (lambda ()
639
640
	       (setf (aref data 0) n)
	       (event-process xc-msg app))))
641
642
643
644
645
646
      (make-pop-up
          *root*
	  (cons "Send to" (make-desktop-menu *root* #'send-message))
	  (if (stick-p appw)
	      (cons "Un-pin" (send-message (current-desk)))
	      (cons "Pin   " (send-message +any-desktop+)))
Iban Hatchondo's avatar
Iban Hatchondo committed
647
	  (cons max-str (lambda () (maximize app 1)))
648
649
650
651
	  (cons shade-str (lambda () (shade master)))
	  (cons "Close  " (lambda () (close-widget app)))
	  (cons "Destroy" (lambda () (kill-client-window appw)))
	  (cons "Iconify" (lambda () (iconify app)))))))
hatchond's avatar
hatchond committed
652

653
654
655
(defun remove-window-from-client-lists (window root)
  "Removes a window from the client lists root properties."
  (with-slots ((rw window) client-list) root
656
    (remwinhash window client-list)
657
658
659
660
661
662
663
    (setf (netwm:net-client-list-stacking rw :mode :remove) window
	  (gnome:win-client-list rw :mode :remove) window
	  (netwm:net-client-list rw :mode :remove) window)))

(defun add-window-in-client-lists (window root)
  "Add a window in the client lists root properties."
  (with-slots ((rw window) client-list) root
664
665
    (let ((up2date (getwinhash window client-list)))
      (setf (getwinhash window client-list) window)
666
667
668
669
670
671
672
      (update-client-list-stacking root)
      (unless up2date
	(setf (netwm:net-client-list rw :mode :append) window))
      (if (member :win_hints_skip_winlist (gnome:win-hints window))
	  (setf (gnome:win-client-list rw :mode :remove) window)
	  (unless up2date
	    (setf (gnome:win-client-list rw :mode :append) window))))))
hatchond's avatar
hatchond committed
673
674

(defun update-client-list-stacking (root)
675
  "Recompute and set the root property net_client_list_stacking."
hatchond's avatar
hatchond committed
676
677
  (with-slots (window client-list) root
    (loop for win in (query-application-tree window)
678
	  when (getwinhash win client-list) collect win into wins
hatchond's avatar
hatchond committed
679
680
	  finally (setf (netwm:net-client-list-stacking window) wins))))

681
682
683
684
(defun update-lists (app state root)
  "Update root properties win_client_list, net_client_list(_stacking), 
  by adjoining or removing the given application depending of state."
  (with-slots ((appw window) iconic-p) app
Iban Hatchondo's avatar
Iban Hatchondo committed
685
686
687
    (case (if (and (= state 3) (not iconic-p)) 0 state)
      (0 (remove-window-from-client-lists appw root))
      (1 (add-window-in-client-lists appw root)))))
688

689
(defun window-not-decorable-p (window &optional type)
Iban Hatchondo's avatar
Iban Hatchondo committed
690
  "Returns T if a window `should' not be decorated. Typically, a splash screen,
Iban Hatchondo's avatar
Iban Hatchondo committed
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
Iban Hatchondo's avatar
Iban Hatchondo committed
693
  flag `no decoration at all'."
694
  (let ((netwm-type (or type (netwm:net-wm-window-type window))))
hatchond's avatar
hatchond committed
695
696
697
698
699
700
    (or (eql (motif-wm-decoration window) :OFF)
	(member :_net_wm_window_type_splash netwm-type)
	(member :_net_wm_window_type_desktop netwm-type)
	(member :_net_wm_window_type_dock netwm-type))))

(defun procede-decoration (window)
Iban Hatchondo's avatar
Iban Hatchondo committed
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
706
	 (application (create-application window nil))
	 (win-workspace (or (window-desktop-num window) +any-desktop+))
707
	 (stick-p (stick-p window)))
hatchond's avatar
hatchond committed
708
    (xlib:add-to-save-set window)
709
    (unless (or stick-p	(< -1 win-workspace (number-of-virtual-screens rw)))
hatchond's avatar
hatchond committed
710
711
      (setf win-workspace scr-num))
    (setf (window-desktop-num window) win-workspace)
712
713
714
715
716
717
718
719
    (cond ((not (or (= win-workspace scr-num) stick-p))
	   (with-event-mask (rw)
	     (setf (wm-state window) 1)
	     (xlib:unmap-window window)
	     (unless (window-not-decorable-p window)
	       (decore-application window application :map nil))
	     (update-lists application 1 *root*)))
	  ((window-not-decorable-p window (application-type application))
720
           (setf (netwm:net-frame-extents window) (values 0 0 0 0))
hatchond's avatar
hatchond committed
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*)))))
james's avatar
james committed
730

731
;;;; The main loop.
james's avatar
james committed
732

Iban Hatchondo's avatar
Iban Hatchondo committed
733
734
735
736
(define-condition exit-eclipse (error)
  ((close-application-p
     :initform nil :initarg :close-application-p
     :type boolean :reader close-application-p)))
Iban Hatchondo's avatar
Iban Hatchondo committed
737

james's avatar
james committed
738
(defun eclipse-internal-loop ()
Iban Hatchondo's avatar
Iban Hatchondo committed
739
740
  (let ((close-display-p t)
        (exit 0))
james's avatar
james committed
741
742

    ;; Sets the root window pop-up menu
743
744
    (when *menu-1-exit-p*
      (nconc *menu-1-items* (acons "Exit" (lambda () (setf exit 1)) '())))
james's avatar
james committed
745
746
747
748
749
750
751
752
    (with-slots (menu1 menu3) *root*
      (setf menu1 (apply #'make-pop-up *root* *menu-1-items*)
	    menu3 (make-pop-up *root*
			       (cons "Move" (define-menu-3 :move))
			       (cons "Resize" (define-menu-3 :resize))
			       (cons "Close" (define-menu-3 :close))
			       (cons "Kill" (define-menu-3 :kill)))))

753
    ;; Dress windows already displayed at start time.
james's avatar
james committed
754
    (flet ((ignorable-window-p (window)
hatchond's avatar
hatchond committed
755
756
757
	     (let* ((wmh (xlib:get-property window :WM_HINTS))
		    (initial-state (and wmh (logbitp 1 (car wmh)) (third wmh)))
		    (wm-state (car (wm-state window))))
james's avatar
james committed
758
759
	       (or
		(eql (xlib:window-override-redirect window) :ON)
hatchond's avatar
hatchond committed
760
761
762
763
764
		(when (or (eq initial-state 0) (eq wm-state 0))
		  (xlib:unmap-window window)
		  t)
		(and (not wm-state)
		     (eq (xlib:window-map-state window) :unmapped))))))
james's avatar
james committed
765

766
767
      (xlib:with-server-grabbed (*display*)
	(mapc (lambda (w)
768
                (unless (ignore-errors (ignorable-window-p w))
769
		  (procede-decoration w)))
james's avatar
james committed
770
771
772
	      (xlib:query-tree *root-window*))))
    ;; Main loop
    (loop
773
774
775
776
777
778
779
780
781
782
783
784
785
786
       (handler-case
           (let ((event (get-next-event *display* :discard-p t :timeout 2)))
             (when event
               (with-slots (event-window) event
                 (event-process event (lookup-widget event-window)))
               (xlib:display-finish-output *display*))
             (when pt:preprogrammed-tasks (pt:execute-preprogrammed-tasks))
             (with-slots (sm-conn) *root*
               (when sm-conn (handle-session-manager-request sm-conn *root*)))
             (case exit
               (1 (loop for val being each hash-value in *widget-table*
                        when (application-p val) 
                        if close-display-p do (close-widget val)
                        else do (undecore-application val))
787
		   (setf exit 2))
788
789
790
791
792
793
794
795
796
797
798
799
800
801
               (2 (when (root-sm-conn *root*)
                    (close-sm-connection *root* :exit-p nil))
                  (xlib:display-finish-output *display*)
                  (setf (xlib:window-event-mask *root-window*) 0)
                  (let ((win (netwm:net-supporting-wm-check *root-window*)))
                    (xlib:destroy-window win))
                  (xlib:display-finish-output *display*)
                  (return))))
         (exit-eclipse (c)
           (setf close-display-p (close-application-p c))
           (setf exit 1))
         (end-of-file (c) (error c))
         (already-handled-xerror () nil)
         (error (c) (handle-error-condition c))))
Iban Hatchondo's avatar
Iban Hatchondo committed
802
    (format t "~%Main loop exited~%")))