wm.lisp 34.4 KB
Newer Older
1
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
2
;;; $Id: wm.lisp,v 1.45 2004/03/19 15:09:45 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
42
43
   (application-gravity 
     :initarg :application-gravity
     :initform :north-west
     :accessor decoration-application-gravity)
   ))
james's avatar
james committed
44

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

james's avatar
james committed
48
(defconstant +decoration-event-mask+
Iban Hatchondo's avatar
Iban Hatchondo committed
49
50
  '(:substructure-redirect :substructure-notify
    :visibility-change :enter-window :owner-grab-button))
james's avatar
james committed
51
52

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

(defmethod decoration-wm-hints ((master decoration))
Iban Hatchondo's avatar
Iban Hatchondo committed
59
60
  "return as a multiple value: minw minh maxw maxh incw inch basew baseh."
  (with-slots (frame-style (wmsh wm-size-hints)) master
Iban Hatchondo's avatar
Iban Hatchondo committed
61
    (declare (type (vector integer 8) wmsh))
Iban Hatchondo's avatar
Iban Hatchondo committed
62
    (with-slots ((hm hmargin) (vm vmargin)) frame-style
Iban Hatchondo's avatar
Iban Hatchondo committed
63
64
65
66
      (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
67

hatchond's avatar
hatchond committed
68
69
70
(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
71

72
73
74
75
76
77
(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
78
79
80
81
82
83
84
85
(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))
86
	   (gnome-prop (or (gnome:win-state app-win :result-type t) 0)))
hatchond's avatar
hatchond committed
87
      (setf gnome-prop (logand gnome-prop #x3DF)) ; supress :win_state_shaded
88
      (if (member :_net_wm_state_shaded netwm-prop)
hatchond's avatar
hatchond committed
89
90
91
	  (with-event-mask (window) 
	    ;; unshade.
	    (xlib:map-window app-win)
Iban Hatchondo's avatar
Iban Hatchondo committed
92
	    (xlib:map-window window)
hatchond's avatar
hatchond committed
93
94
95
96
97
98
99
	    (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.
100
	    (with-slots ((vm vmargin) (hm hmargin)) frame-style
hatchond's avatar
hatchond committed
101
	      (if (title-bar-horizontal-p master)
102
103
		  (unless (= 0 vm) (setf (xlib:drawable-height window) vm))
		  (unless (= 0 hm) (setf (xlib:drawable-width window) hm))))
hatchond's avatar
hatchond committed
104
105
106
	    (xlib:unmap-window app-win)
	    (pushnew :_net_wm_state_shaded netwm-prop)
	    (pushnew :_net_wm_state_hidden netwm-prop)
107
	    (incf gnome-prop 32)))	; add win_state_shaded
hatchond's avatar
hatchond committed
108
109
110
      (setf (netwm:net-wm-state app-win) netwm-prop
	    (gnome:win-state app-win) gnome-prop))))

Iban Hatchondo's avatar
Iban Hatchondo committed
111
(defmethod (setf decoration-frame-style) :after (astyle (master decoration))
112
  (with-slots (window children wm-size-hints) master
Iban Hatchondo's avatar
Iban Hatchondo committed
113
    (with-slots (left-margin top-margin (hm hmargin) (vm vmargin)) astyle
114
      (with-event-mask (window)
hatchond's avatar
hatchond committed
115
	(let* ((application (getf children :application))
116
117
118
119
120
121
122
123
124
125
126
	       (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
127
	    (setf (xlib:window-background window) (style-background astyle)
128
		  (window-position app-win) (values left-margin top-margin)
129
		  (drawable-sizes window) (values width height))
130
	    (make-frame-parts master)
131
132
133
	    (make-title-bar master (wm-name app-win))
	    (update-edges-geometry master)
	    (xlib:map-subwindows window))
134
135
	  (cond ((shaded-p application)
		 (if (title-bar-horizontal-p master)
136
137
		     (unless (= 0 vm) (setf (xlib:drawable-height window) vm))
		     (unless (= 0 hm) (setf (xlib:drawable-width window) hm)))
138
		 (xlib:unmap-window app-win))
hatchond's avatar
hatchond committed
139
140
		((application-iconic-p application)
		 (xlib:unmap-window app-win))))))))
141

142
143
144
(defmethod close-widget ((widget decoration))
  (close-widget (get-child widget :application)))

hatchond's avatar
hatchond committed
145
146
147
148
149
(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)))
james's avatar
james committed
150

151
152
153
(defmethod dispatch-repaint ((master decoration) 
			     &key (focus (focused-p master)))
  (declare (optimize (speed 3) (safety 1)))
154
  (with-slots (parts-to-redraw-on-focus name) (decoration-frame-style master)
155
156
    (declare (type string name))
    (mapc #'(lambda (k) (repaint (get-child master k) name focus))
157
	  parts-to-redraw-on-focus)))
158
159
160
161

(defun title-bar-horizontal-p (master)
  (eq :horizontal (style-title-bar-direction (decoration-frame-style master))))

Iban Hatchondo's avatar
Iban Hatchondo committed
162
163
164
165
166
167
168
169
170
171
172
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
(defun recompute-wm-normal-hints (window hmargin vmargin)
  (let ((hints (or (ignore-errors (xlib:wm-normal-hints window))
		   (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.

202
(defun make-menu-button (master parent-window)
203
  (with-slots (children frame-style) master
204
205
206
    (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
207
	(declare (type pixmaps pixmaps))
208
209
210
	(multiple-value-bind (width height) (drawable-sizes (aref pixmaps 0))
	  (multiple-value-bind (tw th) (drawable-sizes parent-window)
	    (setf (getf children :menu-button)
211
212
213
214
215
216
217
218
		  (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))))))))))
219
220

(defun make-buttons-bar (master parent-window)
Iban Hatchondo's avatar
Iban Hatchondo committed
221
  (with-slots (children (astyle frame-style)) master
222
223
224
225
226
227
    (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
228
      (loop initially (when (zerop (style-nb-buttons astyle)) (return))
229
230
231
232
233
	    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
234
	    for pixmaps of-type pixmaps = (frame-item-pixmaps astyle child)
235
	    for bkgrd = (aref pixmaps 0)
Iban Hatchondo's avatar
Iban Hatchondo committed
236
	    when (frame-item-exist-p astyle child)
237
238
239
	    do (multiple-value-setq (width height) (drawable-sizes bkgrd))
	       (setf (getf children child)
		     (create-button type
240
241
242
243
		       :parent container :master master
		       :background bkgrd :item (aref pixmaps 1)
		       :x x :y y :width width :height height
		       :event-mask +push-button-mask+))
244
245
246
247
248
249
250
251
252
253
254
255
256
	       (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)
257
  (with-slots (children frame-style) master
258
259
260
261
262
263
264
265
266
    (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
267
	(declare (type pixmaps pixmaps))
268
269
270
271
272
273
	(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
274
275
276
277
278
279
	      (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)
280
281
282
	      (slot-value title 'parent) parent-window
	      (getf children :title-bar) title
	      (xlib:window-background parent-window) :parent-relative
283
	      (xlib:window-event-mask parent-window) 0)
284
285
286
287
288
	(if horizontal-p 
	    (setf (slot-value title 'hmargin) (+ bcw mbw))
	    (setf (slot-value title 'vmargin) (+ bch mbh)))
	(xlib:map-subwindows parent-window)
	title))))
289

290
(defun edge-position (style edge-key width height)
291
  (with-slots (top-left-w top-left-h top-right-h bottom-left-w) style
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
    (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
307
  (with-slots (children window (astyle frame-style)) master
308
    (multiple-value-bind (width height) (drawable-sizes window)
309
      (loop for child in *frame-parts*
Iban Hatchondo's avatar
Iban Hatchondo committed
310
	    for pixmaps of-type pixmaps = (frame-item-pixmaps astyle child)
311
312
	    for hilighted = (aref pixmaps 1)
	    for event-mask = (if hilighted +std-button-mask+ +edge-event-mask+)
Iban Hatchondo's avatar
Iban Hatchondo committed
313
	    when (frame-item-exist-p astyle child) do
Iban Hatchondo's avatar
Iban Hatchondo committed
314
	     (multiple-value-bind (x y)
Iban Hatchondo's avatar
Iban Hatchondo committed
315
316
		 (edge-position astyle child width height)
	       (multiple-value-bind (w h) (frame-item-sizes astyle child)
Iban Hatchondo's avatar
Iban Hatchondo committed
317
318
319
320
321
322
		 (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
323

Iban Hatchondo's avatar
Iban Hatchondo committed
324
325
;; Public.

james's avatar
james committed
326
(defun update-edges-geometry (master)
327
328
  (declare (optimize (speed 3) (safety 0)))
  (declare (inline update-edges-geometry))
hatchond's avatar
hatchond committed
329
330
331
332
333
334
335
  (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))
336
		    (max 1 (- ,size ,@frame-style-slots-size)))))))
hatchond's avatar
hatchond committed
337
338
339
340
341
342
343
344
345
346
347
    (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)))
348
  (when title-bar
349
350
    (with-slots (parent window (vm vmargin) (hm hmargin)) title-bar
      (declare (type xlib:card16 vm hm))
351
352
353
      (multiple-value-bind (width height) (drawable-sizes parent)
	(declare (type xlib:card16 width height))
	(setf (drawable-sizes window)
354
	      (values (max 1 (- width hm)) (max 1 (- height vm))))))))
355

356
(defun initial-coordinates (app-window frame-style)
357
358
  "Returns as multiple values the decoration initial coordinates."
  (let ((hint (ignore-errors (xlib:wm-normal-hints app-window))))
359
360
361
362
363
364
365
366
367
368
369
370
    (with-slots (top-margin left-margin vmargin hmargin) frame-style
      (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)))
	    (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))))
	  (multiple-value-bind (x y) (window-position app-window)
	    (values (max 0 (- x left-margin)) (max 0 (- y top-margin))))))))
371

372
(defun make-decoration (app-window application &key theme)
373
374
375
376
377
  (unless theme (setf theme (root-decoration-theme *root*)))
  (let* ((dstyle (find-decoration-frame-style theme app-window))
	 (style dstyle))
    (when (member :_net_wm_state_fullscreen (netwm:net-wm-state app-window))
      (setf style (theme-default-style (lookup-theme "no-decoration"))))
378
    (with-slots (hmargin vmargin left-margin top-margin background) style
hatchond's avatar
hatchond committed
379
      (multiple-value-bind (wm-sizes gravity) 
380
381
	  (recompute-wm-normal-hints app-window hmargin vmargin)
	(multiple-value-bind (width height) (drawable-sizes app-window)
382
	  (multiple-value-bind (x y) (initial-coordinates app-window style)
383
384
385
386
387
388
389
390
391
	    (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)))
392
393
394
395
396
397
398
		   (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)
399
400
401
402
403
404
405
406
407
408
	      (make-title-bar master (wm-name app-window))
	      (update-edges-geometry master)
	      (with-slots (icon) 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))
	      master)))))))

(defun decore-application (window application &key (map t) theme)
Iban Hatchondo's avatar
Iban Hatchondo committed
409
410
411
  "Decore an application and map the resulting decoration as indicated
  by the :map keyword argument. (default value is T).
  Return the newly created decoration."
412
  (let* ((master (make-decoration window application :theme theme))
413
414
415
	 (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
416
417
418
    (with-event-mask (master-window)
      (xlib:map-subwindows master-window))
    (with-event-mask (master-window (when map +decoration-event-mask+))
419
420
421
422
      (xlib:reparent-window window master-window left-margin top-margin))
    (when map (xlib:map-window window))
    master))

Iban Hatchondo's avatar
Iban Hatchondo committed
423
424
;;;; Maximization tools.

Iban Hatchondo's avatar
Iban Hatchondo committed
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
(defun find-max-geometry (application direction fill-p &key x y w h)
  (multiple-value-bind (ulx uly lrx lry)
      (find-largest-empty-area 
          application 
	  :area-include-me-p (or (/= 1 direction) fill-p)
	  :panels-only-p (not fill-p)
	  :direction (case direction (2 :vertical) (3 :horizontal) (t :both)))
    (with-slots (window master) application
      (with-slots ((hm hmargin) (vm vmargin))
	  (if master (decoration-frame-style master)
	      (theme-default-style (lookup-theme "no-decoration")))
	(symbol-macrolet ((minw (aref wmsh 0)) (minh (aref wmsh 1))
			  (maxw (aref wmsh 2)) (maxh (aref wmsh 3))
			  (incw (aref wmsh 4)) (inch (aref wmsh 5))
			  (basew (aref wmsh 6)) (baseh (aref wmsh 7)))
	  (let* ((wmsh (recompute-wm-normal-hints window hm vm))
		 (ww (or w (check-size (- lrx ulx hm) basew incw minw maxw)))
		 (hh (or h (check-size (- lry uly vm) baseh inch minh maxh))))
	    (when (> (+ ww hm) (- lrx ulx)) (decf ww incw))
	    (when (> (+ hh vm) (- lry uly)) (decf hh inch))
	    (make-geometry :w ww :h hh :x (or x ulx) :y (or y uly))))))))

(defun compute-max-geometry
    (application x y w h direction fill-p vert-p horz-p)
  (symbol-macrolet 
	((ix (geometry-x initial-geometry)) (iy (geometry-y initial-geometry))
	 (iw (geometry-w initial-geometry)) (ih (geometry-h initial-geometry)))
    (with-slots (initial-geometry) application
      (case direction
	;; Unmaximize or Maximize in both directions
	(1 (if (or horz-p vert-p)
	       (copy-geometry initial-geometry)
	       (find-max-geometry application direction fill-p)))
	;; Unmaximize or Maximize Vertically
	(2 (if vert-p
	       (make-geometry :x x :y iy :w w :h ih)
	       (find-max-geometry application direction fill-p :x x :w w)))
	;; Unmaximize or Maximize Horizontally
	(3 (if horz-p
	       (make-geometry :x ix :y y :w iw :h h)
	       (find-max-geometry application direction fill-p :y y :h h)))))))

Iban Hatchondo's avatar
Iban Hatchondo committed
467
468
;; Public.

Iban Hatchondo's avatar
Iban Hatchondo committed
469
(defun maximize-window (application code &key (fill-p *maximize-fill*))
hatchond's avatar
hatchond committed
470
471
472
  (with-slots ((app-window window) initial-geometry full-geometry master)
      application
    (when (shaded-p master) (shade master))
Iban Hatchondo's avatar
Iban Hatchondo committed
473
    (let* ((new-g)
hatchond's avatar
hatchond committed
474
475
476
	   (m-window (if master (widget-window master) app-window))
	   (prop (netwm:net-wm-state app-window))
	   (fullscreen-p (member :_net_wm_state_fullscreen prop))
Iban Hatchondo's avatar
Iban Hatchondo committed
477
478
	   (vert-p (car (member :_net_wm_state_maximized_vert prop)))
	   (horz-p (car (member :_net_wm_state_maximized_horz prop))))
hatchond's avatar
hatchond committed
479
      (multiple-value-bind (x y) (window-position m-window)
480
	(multiple-value-bind (w h) (drawable-sizes app-window)
hatchond's avatar
hatchond committed
481
482
483
	  (unless (or horz-p vert-p)
	    (if fullscreen-p
		(setf initial-geometry (copy-geometry full-geometry))
484
		(setf (geometry initial-geometry) (values x y w h))))
Iban Hatchondo's avatar
Iban Hatchondo committed
485
486
487
488
489
	  (setf new-g (compute-max-geometry
		          application x y w h code fill-p vert-p horz-p))))
      (when (and (= 1 code) (or horz-p vert-p))
	(setf (values horz-p vert-p) (values t t)))
      (unless (= 3 code)
hatchond's avatar
hatchond committed
490
491
492
	(if vert-p 
	    (setf prop (delete :_net_wm_state_maximized_vert prop))
	    (pushnew :_net_wm_state_maximized_vert prop)))
Iban Hatchondo's avatar
Iban Hatchondo committed
493
      (unless (= 2 code)
hatchond's avatar
hatchond committed
494
495
496
497
	(if horz-p
	    (setf prop (delete :_net_wm_state_maximized_horz prop))
	    (pushnew :_net_wm_state_maximized_horz prop)))
      (if fullscreen-p
Iban Hatchondo's avatar
Iban Hatchondo committed
498
499
500
	  (setf full-geometry new-g)
	  (setf (window-position m-window) (geometry-coordinates new-g)
		(drawable-sizes app-window) (geometry-sizes new-g)))
hatchond's avatar
hatchond committed
501
502
      (setf (netwm:net-wm-state app-window) prop))))

james's avatar
james committed
503
504
;;;; Focus management. According to ICCCM

505
(defgeneric set-focus (input-model window timestamp)
506
507
508
509
  (: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
510
511

(defmethod set-focus ((input-model (eql :globally-active)) window timestamp)
hatchond's avatar
hatchond committed
512
  (send-wm-protocols-client-message window :wm_take_focus (or timestamp 0)))
james's avatar
james committed
513
514

(defmethod set-focus ((input-model (eql :locally-active)) window timestamp)
hatchond's avatar
hatchond committed
515
  (when (eql (xlib:window-map-state window) :viewable)
516
517
    (xlib:set-input-focus *display* window :pointer-root)
    (send-wm-protocols-client-message window :wm_take_focus (or timestamp 0))))
james's avatar
james committed
518
519
520

(defmethod set-focus ((input-model (eql :passive)) window timestamp)
  (declare (ignorable timestamp))
hatchond's avatar
hatchond committed
521
  (when (eql (xlib:window-map-state window) :viewable)
522
    (xlib:set-input-focus *display* window :pointer-root)))
james's avatar
james committed
523
524
525

(defmethod set-focus ((input-model (eql :no-input)) window timestamp)
  (declare (ignorable window timestamp))
526
527
528
529
530
531
532
  (values))

;; 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
533
(defgeneric menu-3-process (event widget &rest rest))
534
535

(defmethod menu-3-process (event widget &rest rest)
536
537
538
  (declare (ignorable rest))
  (event-process event widget)
  nil)
539

hatchond's avatar
hatchond committed
540
(defmethod menu-3-process ((event pointer-event) (w base-widget) &rest rest)
541
  (declare (ignorable event w rest))
hatchond's avatar
hatchond committed
542
543
  (xlib:ungrab-pointer *display*)
  t)
544

545
546
547
548
549
550
551
552
553
554
555
556
557
558
(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)))
559

560
(defmethod menu-3-process ((ev motion-notify) (master decoration) &key key)
561
562
563
564
565
566
567
568
  (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)))
569

570
571
572
573
574
575
(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)

576
(defmethod menu-3-process ((event enter-notify) (master decoration) &rest rest)
577
  (declare (ignorable event rest))
578
579
580
581
  (with-slots (window) master
    (xlib:grab-pointer window +pointer-event-mask+ :cursor *cursor-2*))
  nil)

582
583
584
585
586
(defmethod menu-3-process ((event leave-notify) (app application) &rest rest)
  (declare (ignore event rest))
  (unless (application-master app) (xlib:ungrab-pointer *display*))
  nil)

587
(defmethod menu-3-process ((event leave-notify) (master decoration) &rest rest)
588
  (declare (ignore event master rest))
589
  (xlib:ungrab-pointer *display*)
james's avatar
james committed
590
591
  nil)

592
593
594
595
596
597
598
599
600
(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*))))

601
(defmethod menu-3-process ((ev button-press) (master decoration) &key key)
602
  (menu-3-process ev (get-child master :application) :key key))
603
604
605
606
607
608

(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
609
	    for widget = (lookup-widget (event-event-window event))
610
611
612
	    until (menu-3-process event widget :key action)))))

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

614
615
(defun make-desktop-menu (root callback-maker &key realize)
  "Realize a root pop-up menu with as many entry as existing desktop. It attach
616
617
618
619
620
  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
621
  (declare (type function callback-maker))
hatchond's avatar
hatchond committed
622
623
624
625
  (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))
626
627
628
629
630
631
	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."
632
633
634
635
636
637
638
  (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))))
639
640
       (make-desktop-entries (i)
	 (loop for w in (screen-content i :iconify-p t)
641
	       for state = (= 1 (first (wm-state w)))
642
643
644
645
	       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)))))))
646
647
648
649
650
651
    (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))
652
653
	 (data (make-array 1 :element-type 'xlib:card32))
	 (xc-msg (make-event :client-message :data data :type :_net_wm_desktop))
654
655
656
657
	 (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")))
658
    (declare (type (simple-array xlib:card32 (1)) data))
659
660
    (flet ((send-message (n)
	     (lambda ()
661
662
	       (setf (aref data 0) n)
	       (event-process xc-msg app))))
663
664
665
666
667
668
669
670
671
672
673
      (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+)))
	  (cons max-str (lambda () (maximize-window app 1)))
	  (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
674

675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
(defun remove-window-from-client-lists (window root)
  "Removes a window from the client lists root properties."
  (with-slots ((rw window) client-list) root
    (remhash window client-list)
    (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
    (let ((up2date (gethash window client-list)))
      (setf (gethash window client-list) window)
      (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
695
696

(defun update-client-list-stacking (root)
697
  "Recompute ans set the root property net_client_list_stacking."
hatchond's avatar
hatchond committed
698
699
700
701
702
  (with-slots (window client-list) root
    (loop for win in (query-application-tree window)
	  when (gethash win client-list) collect win into wins
	  finally (setf (netwm:net-client-list-stacking window) wins))))

703
704
705
706
707
708
709
710
711
(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
    (with-slots ((rw window) client-list) root
      (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))))))

712
713
(defun window-not-decorable-p (window &optional type)
  "Return T if a window `should' not be decorated. Typically, a splash screen,
Iban Hatchondo's avatar
Iban Hatchondo committed
714
  a desktop (e.g. nautilus) or a dock (e.g. gnome panels) will be assumed as
715
  non-decorable windows, as well as windows holding the motif_wm_hints with the
Iban Hatchondo's avatar
Iban Hatchondo committed
716
  flag `no decoration at all'."
717
  (let ((netwm-type (or type (netwm:net-wm-window-type window))))
hatchond's avatar
hatchond committed
718
719
720
721
722
723
    (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
724
  "Decore, if necessary, add/update properties, map or not, etc a window."
725
726
  (let* ((rw (xlib:drawable-root window))
	 (scr-num (current-vscreen rw))
727
728
	 (application (create-application window nil))
	 (win-workspace (or (window-desktop-num window) +any-desktop+))
729
	 (stick-p (stick-p window)))
hatchond's avatar
hatchond committed
730
    (xlib:add-to-save-set window)
731
    (unless (or stick-p	(< -1 win-workspace (number-of-virtual-screens rw)))
hatchond's avatar
hatchond committed
732
733
      (setf win-workspace scr-num))
    (setf (window-desktop-num window) win-workspace)
734
735
736
737
738
739
740
741
    (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))
hatchond's avatar
hatchond committed
742
	   (setf (wm-state window) 1)
743
744
	   (xlib:map-window window))
	  (t (decore-application window application :map t)))
745
    (with-slots (wants-focus-p input-model type) application
746
      (unless (member :_net_wm_window_type_desktop type)
747
748
	(unless (eq input-model :no-input)
	  (setf wants-focus-p *focus-new-mapped-window*)))
749
      (when (member :_net_wm_window_type_dock type)
750
	(update-workarea-property *root*)))))
james's avatar
james committed
751

752
;;;; The main loop.
james's avatar
james committed
753

Iban Hatchondo's avatar
Iban Hatchondo committed
754
755
756
757
(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
758

james's avatar
james committed
759
(defun eclipse-internal-loop ()
Iban Hatchondo's avatar
Iban Hatchondo committed
760
  (let* ((exit 0) time)
james's avatar
james committed
761
762

    ;; Sets the root window pop-up menu
763
764
    (when *menu-1-exit-p*
      (nconc *menu-1-items* (acons "Exit" (lambda () (setf exit 1)) '())))
james's avatar
james committed
765
766
767
768
769
770
771
772
    (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)))))

773
    ;; Dress windows already displayed at start time.
james's avatar
james committed
774
    (flet ((ignorable-window-p (window)
hatchond's avatar
hatchond committed
775
776
777
	     (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
778
779
	       (or
		(eql (xlib:window-override-redirect window) :ON)
hatchond's avatar
hatchond committed
780
781
782
783
784
		(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
785

786
787
788
789
      (xlib:with-server-grabbed (*display*)
	(mapc (lambda (w)
		(unless (ignore-errors (ignorable-window-p w))
		  (procede-decoration w)))
james's avatar
james committed
790
791
792
793
794
	      (xlib:query-tree *root-window*))))

    ;; Main loop
    (loop
      (catch 'general-error
Iban Hatchondo's avatar
Iban Hatchondo committed
795
796
797
798
	(handler-case
	    (let ((event (get-next-event *display* :discard-p t :timeout 2)))
	      (when event
		(with-slots (event-window) event
799
800
		  (event-process event (lookup-widget event-window)))
		(xlib:display-finish-output *display*))
Iban Hatchondo's avatar
Iban Hatchondo committed
801
	      (when pt:preprogrammed-tasks (pt:execute-preprogrammed-tasks))
802
803
	      (with-slots (sm-conn) *root*
		(when sm-conn (handle-session-manager-request sm-conn *root*)))
Iban Hatchondo's avatar
Iban Hatchondo committed
804
	      (case exit
Iban Hatchondo's avatar
Iban Hatchondo committed
805
806
807
808
		(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))
Iban Hatchondo's avatar
Iban Hatchondo committed
809
		   (setf time 10 exit 2))
Iban Hatchondo's avatar
Iban Hatchondo committed
810
811
812
		(2 (when (root-sm-conn *root*)
		     (close-sm-connection *root* :exit-p nil))
		   (xlib:display-finish-output *display*)
813
		   (setf (xlib:window-event-mask *root-window*) 0)
814
815
		   (let ((win (netwm:net-supporting-wm-check *root-window*)))
		     (xlib:destroy-window win))
Iban Hatchondo's avatar
Iban Hatchondo committed
816
817
818
819
		   (xlib:display-finish-output *display*)
		   (return))))
	  (exit-eclipse (c)
	    (setf *close-display-p* (close-application-p c) exit 1))
Iban Hatchondo's avatar
Iban Hatchondo committed
820
821
822
823
	  (end-of-file (c) (handle-end-of-file-condition c))
	  (already-handled-xerror () nil)
	  (error (c) (handle-error-condition c)))))
    (format t "~%Main loop exited~%")))