1
;; gnome.jl -- minimal GNOME compliance
2
;; $Id: gnome.jl,v 1.74 2001/12/11 23:05:50 federico Exp $
4
;; Copyright (C) 1999 John Harper <john@dcs.warwick.ac.uk>
6
;; This file is part of sawmill.
8
;; sawmill is free software; you can redistribute it and/or modify it
9
;; under the terms of the GNU General Public License as published by
10
;; the Free Software Foundation; either version 2, or (at your option)
13
;; sawmill is distributed in the hope that it will be useful, but
14
;; WITHOUT ANY WARRANTY; without even the implied warranty of
15
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16
;; GNU General Public License for more details.
18
;; You should have received a copy of the GNU General Public License
19
;; along with sawmill; see the file COPYING. If not, write to
20
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
22
(define-structure sawfish.wm.state.gnome
24
(export WIN_STATE_STICKY
25
WIN_STATE_MAXIMIZED_VERT
26
WIN_STATE_MAXIMIZED_HORIZ
29
WIN_STATE_FIXED_POSITION
32
WIN_HINTS_SKIP_WINLIST
33
WIN_HINTS_SKIP_TASKLIST
34
WIN_HINTS_FOCUS_ON_CLICK
35
WIN_HINTS_DO_NOT_COVER
51
sawfish.wm.state.maximize
52
sawfish.wm.state.iconify
53
sawfish.wm.state.shading)
55
(define-structure-alias gnome sawfish.wm.state.gnome)
57
(defconst WIN_STATE_STICKY 1)
58
(defconst WIN_STATE_MAXIMIZED_VERT 4)
59
(defconst WIN_STATE_MAXIMIZED_HORIZ 8)
60
(defconst WIN_STATE_HIDDEN 16)
61
(defconst WIN_STATE_SHADED 32)
62
(defconst WIN_STATE_FIXED_POSITION 256)
64
(defconst WIN_LAYER_NORMAL 4)
66
(defconst WIN_HINTS_SKIP_FOCUS 1)
67
(defconst WIN_HINTS_SKIP_WINLIST 2)
68
(defconst WIN_HINTS_SKIP_TASKLIST 4)
69
(defconst WIN_HINTS_FOCUS_ON_CLICK 16)
70
(defconst WIN_HINTS_DO_NOT_COVER 32)
72
(defvar gnome-window-id nil)
74
(defvar gnome-supported-protocols [_WIN_CLIENT_LIST _WIN_WORKSPACE
75
_WIN_WORKSPACE_COUNT _WIN_STATE
78
;; this is needed since the gnome tasklist applet doesn't honour
79
;; the _WIN_HIDDEN property (?)
80
(defvar gnome-ignored-windows-in-client-list t)
82
(define (gnome-set-client-list)
84
(map-windows (lambda (w)
85
(when (and (windowp w) (window-mapped-p w)
86
(or gnome-ignored-windows-in-client-list
87
(not (window-get w 'ignored))))
88
(setq clients (cons (window-id w) clients)))))
89
(setq vec (apply vector clients))
90
(set-x-property 'root '_WIN_CLIENT_LIST vec 'CARDINAL 32)))
92
(define (gnome-set-hint w bit)
93
(let ((hints (get-x-property w '_WIN_HINTS)))
95
(setq hints (aref (nth 2 hints) 0))
97
(setq hints (logior bit hints))
98
(set-x-property w '_WIN_HINTS (vector hints) 'CARDINAL 32)))
100
(define (gnome-clear-hint w bit)
101
(let ((hints (get-x-property w '_WIN_HINTS)))
103
(setq hints (aref (nth 2 hints) 0))
105
(setq hints (logand (lognot bit) hints))
106
(set-x-property w '_WIN_HINTS (vector hints) 'CARDINAL 32)))
108
(define (gnome-toggle-hint w bit)
109
(let ((hints (get-x-property w '_WIN_HINTS)))
111
(setq hints (aref (nth 2 hints) 0))
113
(setq hints (logxor bit hints))
114
(set-x-property w '_WIN_HINTS (vector hints) 'CARDINAL 32)))
116
;; Queries whether a property in _WIN_HINTS is set. Involves a
117
;; server roundtrip as it does get-x-property.
118
(define (gnome-hint-set-p w bit)
119
(let ((hints (get-x-property w '_WIN_HINTS)))
121
(setq hints (aref (nth 2 hints) 0))
123
(if (zerop (logand bit hints))
127
(define current-workspace-index nil)
128
(define current-workspace-count 0)
129
(define current-workspace-names nil)
130
(define current-area nil)
131
(define current-area-count nil)
133
(define (gnome-set-workspace)
134
(let* ((limits (workspace-limits))
135
(port (screen-viewport))
136
(port-size viewport-dimensions)
137
(total-workspaces (1+ (- (cdr limits) (car limits)))))
138
;; apparently some pagers don't like it if we place windows
139
;; on (temporarily) non-existent workspaces
140
(when (< current-workspace-count total-workspaces)
141
(setq current-workspace-count total-workspaces)
142
(set-x-property 'root '_WIN_WORKSPACE_COUNT
143
(vector current-workspace-count) 'CARDINAL 32))
147
;; XXX the gnome-wm standard sucks..
148
((space (and (not (window-get w 'sticky))
149
(window-get w 'swapped-in)))
150
(w-port (and (not (window-get w 'viewport-sticky))
151
(window-viewport w))))
153
(set-x-property w '_WIN_WORKSPACE
154
(vector (- space (car limits))) 'CARDINAL 32)
155
(delete-x-property w '_WIN_WORKSPACE))
157
(set-x-property w '_WIN_AREA
158
(vector (car w-port) (cdr w-port))
160
(delete-x-property w '_WIN_AREA)))))
161
(unless (equal current-workspace-index
162
(- current-workspace (car limits)))
163
(setq current-workspace-index (- current-workspace (car limits)))
164
(set-x-property 'root '_WIN_WORKSPACE
165
(vector current-workspace-index) 'CARDINAL 32))
166
(when (> current-workspace-count total-workspaces)
167
(setq current-workspace-count total-workspaces)
168
(set-x-property 'root '_WIN_WORKSPACE_COUNT
169
(vector current-workspace-count) 'CARDINAL 32))
170
(unless (equal current-workspace-names workspace-names)
171
(setq current-workspace-names workspace-names)
172
(set-x-text-property 'root '_WIN_WORKSPACE_NAMES
173
(apply vector workspace-names)))
174
(unless (equal current-area port)
175
(setq current-area port)
176
(set-x-property 'root '_WIN_AREA (vector (car port) (cdr port))
178
(unless (equal current-area-count port-size)
179
(setq current-area-count port-size)
180
(set-x-property 'root '_WIN_AREA_COUNT (vector (car port-size)
184
(define (gnome-set-client-state w)
186
(when (window-get w 'sticky)
187
(setq state (logior state WIN_STATE_STICKY)))
188
(when (window-get w 'shaded)
189
(setq state (logior state WIN_STATE_SHADED)))
190
(when (window-get w 'fixed-position)
191
(setq state (logior state WIN_STATE_FIXED_POSITION)))
192
(when (window-maximized-vertically-p w)
193
(setq state (logior state WIN_STATE_MAXIMIZED_VERT)))
194
(when (window-maximized-horizontally-p w)
195
(setq state (logior state WIN_STATE_MAXIMIZED_HORIZ)))
196
(when (window-get w 'ignored)
197
(setq state (logior state WIN_STATE_HIDDEN)))
198
(set-x-property w '_WIN_STATE (vector state) 'CARDINAL 32)
199
(when (window-get w 'depth)
200
(set-x-property w '_WIN_LAYER
201
(vector (+ (window-get w 'depth) WIN_LAYER_NORMAL))
204
(define (gnome-set-client-hints w states)
205
(let ((hints (let ((prop (get-x-property w '_WIN_HINTS)))
206
(if (eq (car prop) 'CARDINAL)
207
(aref (nth 2 prop) 0)
209
(mapc (lambda (state)
212
(setq hints (logior (logand
213
hints (lognot WIN_HINTS_SKIP_WINLIST))
214
(if (window-get w 'window-list-skip)
215
WIN_HINTS_SKIP_WINLIST 0)
216
(if (window-get w 'avoid)
217
WIN_HINTS_DO_NOT_COVER 0))))))
219
(set-x-property w '_WIN_HINTS (vector hints) 'CARDINAL 32)))
221
;; XXX Ugly hacks to make the GNOME desktop function sanely
222
(define (gnome-window-class-hacks w)
223
(let ((class (get-x-text-property w 'WM_CLASS)))
224
(when (and class (>= (length class) 2))
225
(cond ((and (string= (aref class 1) "Panel")
226
(string= (aref class 0) "panel_window"))
227
;; XXX I don't think the GNOME hints specify these things...
228
(window-put w 'focus-click-through t)
229
(window-put w 'no-history t)
230
(window-put w 'never-iconify t)
231
(window-put w 'never-maximize t)
232
;; XXX the panel is broken, in that it doesn't check
233
;; XXX that the wm gave it the position that it wanted.
234
;; XXX (The wm is under no obligation; the panel should
235
;; XXX move itself to the required position after
236
;; XXX initially mapping the window, or perhaps it
237
;; XXX should use the USPosition hints?). The following
238
;; XXX line prevents panel windows being placed at all
239
(window-put w 'placed t))
240
((string= (aref class 1) "gmc-desktop-icon")
241
(window-put w 'focus-click-through t)
242
(window-put w 'never-focus t)
243
(window-put w 'never-iconify t)
244
(window-put w 'never-maximize t)
245
;; XXX same reason as above
246
(window-put w 'placed t))
247
((and (string= (aref class 1) "Nautilus")
248
(string= (aref class 0) "desktop_window"))
249
(mark-window-as-desktop w))))))
251
(define (gnome-honour-client-state w)
252
(gnome-window-class-hacks w)
253
(let ((state (get-x-property w '_WIN_STATE))
254
(hints (get-x-property w '_WIN_HINTS))
255
(layer (get-x-property w '_WIN_LAYER))
256
(space (get-x-property w '_WIN_WORKSPACE))
258
(when (eq (car state) 'CARDINAL)
259
(setq bits (aref (nth 2 state) 0))
260
(unless (zerop (logand bits WIN_STATE_STICKY))
261
(window-put w 'sticky t)
262
(window-put w 'sticky-viewport t))
263
(unless (zerop (logand bits WIN_STATE_SHADED))
264
(window-put w 'shaded t))
265
(unless (zerop (logand bits WIN_STATE_FIXED_POSITION))
266
(window-put w 'fixed-position t))
267
(unless (zerop (logand bits WIN_STATE_MAXIMIZED_VERT))
268
(unless (window-maximized-vertically-p w)
269
(window-put w 'queued-vertical-maximize t)))
270
(unless (zerop (logand bits WIN_STATE_MAXIMIZED_HORIZ))
271
(unless (window-maximized-horizontally-p w)
272
(window-put w 'queued-horizontal-maximize t))))
273
(when (eq (car hints) 'CARDINAL)
274
(setq bits (aref (nth 2 hints) 0))
275
(unless (zerop (logand bits WIN_HINTS_SKIP_FOCUS))
276
(window-put w 'cycle-skip t))
277
(unless (zerop (logand bits WIN_HINTS_SKIP_WINLIST))
278
(window-put w 'window-list-skip t))
279
(unless (zerop (logand bits WIN_HINTS_DO_NOT_COVER))
280
(window-put w 'avoid t)))
282
(setq layer (aref (nth 2 layer) 0))
283
(set-window-depth w (- layer WIN_LAYER_NORMAL)))
284
(when (and space (not (window-workspaces w)))
285
(set-window-workspaces w (list (aref (nth 2 space) 0))))))
287
(define (gnome-client-message-handler w type data)
288
(cond ((eq type '_WIN_WORKSPACE)
289
(let ((limits (workspace-limits)))
290
(select-workspace (+ (aref data 0) (car limits)))
292
((eq type '_WIN_AREA)
293
(set-screen-viewport (aref data 0) (aref data 1)))
294
((and (eq type '_WIN_STATE) (windowp w))
295
(let ((mask (aref data 0))
296
(values (aref data 1))
298
(unless (zerop (logand mask WIN_STATE_STICKY))
299
(if (zerop (logand values WIN_STATE_STICKY))
300
(make-window-unsticky w)
301
(make-window-sticky w)))
302
(unless (zerop (logand mask WIN_STATE_SHADED))
303
(if (zerop (logand values WIN_STATE_SHADED))
306
(unless (zerop (logand mask WIN_STATE_FIXED_POSITION))
307
(window-put w 'fixed-position
308
(/= (logand values WIN_STATE_FIXED_POSITION) 0)))
309
(unless (zerop (logand mask WIN_STATE_MAXIMIZED_VERT))
310
(setq tem (window-maximized-vertically-p w))
311
(if (or (and (not tem) (not (zerop (logand values WIN_STATE_MAXIMIZED_VERT))))
312
(and tem (zerop (logand values WIN_STATE_MAXIMIZED_VERT))))
313
(maximize-window-vertically-toggle w)))
314
(unless (zerop (logand mask WIN_STATE_MAXIMIZED_HORIZ))
315
(setq tem (window-maximized-horizontally-p w))
316
(if (or (and (not tem) (not (zerop (logand values WIN_STATE_MAXIMIZED_HORIZ))))
317
(and tem (zerop (logand values WIN_STATE_MAXIMIZED_HORIZ))))
318
(maximize-window-horizontally-toggle w))))
320
((and (eq type '_WIN_HINTS) (windowp w))
321
(let ((mask (aref data 0))
322
(bits (aref data 1)))
323
(unless (zerop (logand mask WIN_HINTS_SKIP_FOCUS))
324
(window-put w 'cycle-skip
325
(not (zerop (logand bits WIN_HINTS_SKIP_FOCUS)))))
326
(unless (zerop (logand mask WIN_HINTS_SKIP_WINLIST))
327
(window-put w 'window-list-skip
328
(not (zerop (logand bits WIN_HINTS_SKIP_WINLIST)))))
329
(unless (zerop (logand mask WIN_HINTS_DO_NOT_COVER))
331
(not (zerop (logand bits WIN_HINTS_DO_NOT_COVER)))))))
332
((and (eq type '_WIN_LAYER) (windowp w))
333
(set-window-depth w (- (aref data 0) WIN_LAYER_NORMAL))
336
(define (gnome-property-handler w prop)
340
(let ((space (get-x-property w '_WIN_WORKSPACE)))
341
(when (and space (eq (car space) 'CARDINAL)
342
(= (length (nth 2 space)) 1))
343
(let ((count (aref (nth 2 space) 0)))
344
(unless (window-appears-in-workspace-p
345
w (workspace-id-from-logical count))
346
(send-window-to-workspace-from-first w count))))))
349
(let ((area (get-x-property w '_WIN_AREA)))
350
(when (and area (eq (car area) 'CARDINAL)
351
(= (length (nth 2 area)) 2))
352
(let ((x (aref (nth 2 area) 0))
353
(y (aref (nth 2 area) 1))
354
(port (window-viewport w)))
355
(unless (and (= (car port) x) (= (cdr port) y))
356
(set-window-viewport w x y)))))))))
358
(define (gnome-event-proxyer)
359
(when (and (current-event) (eq (current-event-window) 'root))
360
(let ((event (event-name (current-event))))
361
;; only proxy Click1 or Off events, and only if we don't have
362
;; a binding for an event that may follow in the same grab
363
(cond ((and (string-match "^(.*)-Click\\d?$" event)
364
(let ((mirror (lookup-event
365
(expand-last-match "\\1-Off"))))
366
(not (or (search-keymap mirror global-keymap)
367
(search-keymap mirror root-window-keymap)))))
368
;; send with SubstructureNotifyMask
369
(proxy-current-event gnome-window-id (lsh 1 19))
371
((and (string-match "^(.*)-Off[123]?$" event)
375
(concat (expand-last-match "\\1-") x)))
376
'("Click1" "Click2" "Click3" "Move"))))
379
(when (or (search-keymap ev global-keymap)
380
(search-keymap ev root-window-keymap))
384
;; send with SubstructureNotifyMask
385
(proxy-current-event gnome-window-id (lsh 1 19))
392
(setq gnome-window-id (create-window 'root -200 -200 5 5))
394
(set-x-property 'root '_WIN_SUPPORTING_WM_CHECK
395
(vector gnome-window-id) 'CARDINAL 32)
396
(set-x-property gnome-window-id '_WIN_SUPPORTING_WM_CHECK
397
(vector gnome-window-id) 'CARDINAL 32)
399
(set-x-property 'root '_WIN_DESKTOP_BUTTON_PROXY
400
(vector gnome-window-id) 'CARDINAL 32)
401
(set-x-property gnome-window-id '_WIN_DESKTOP_BUTTON_PROXY
402
(vector gnome-window-id) 'CARDINAL 32)
404
(set-x-property 'root '_WIN_PROTOCOLS
405
gnome-supported-protocols 'ATOM 32)
407
(let ((port (screen-viewport)))
408
(set-x-property 'root '_WIN_AREA
409
(vector (car port) (cdr port)) 'CARDINAL 32)
410
(set-x-property 'root '_WIN_AREA_COUNT
411
(vector (car viewport-dimensions)
412
(cdr viewport-dimensions)) 'CARDINAL 32)
414
;; XXX I'm using this property to tell desk-guide to move
415
;; XXX the current area on all desktops at once
416
;; XXX This is totally non-standard and may change..
417
(set-x-property 'root '_WIN_UNIFIED_AREA (vector 1) 'CARDINAL 32))
419
(delete-x-property 'root '_WIN_WORKSPACE_NAMES)
421
(add-hook 'workspace-state-change-hook gnome-set-workspace)
422
(add-hook 'viewport-resized-hook gnome-set-workspace)
423
(add-hook 'viewport-moved-hook gnome-set-workspace)
425
(add-hook 'add-window-hook gnome-set-client-list)
426
(add-hook 'destroy-notify-hook gnome-set-client-list)
427
(add-hook 'map-notify-hook gnome-set-client-list)
428
(add-hook 'unmap-notify-hook gnome-set-client-list)
429
(add-hook 'workspace-state-change-hook gnome-set-client-list)
431
(add-hook 'before-add-window-hook gnome-honour-client-state)
432
(add-hook 'add-window-hook gnome-set-client-state)
433
(call-after-state-changed '(sticky shaded maximized ignored stacking)
434
gnome-set-client-state)
435
(call-after-state-changed '(window-list-skip) gnome-set-client-hints)
437
(add-hook 'client-message-hook gnome-client-message-handler)
438
(add-hook 'property-notify-hook gnome-property-handler)
440
(add-hook 'unbound-key-hook gnome-event-proxyer)
441
(add-hook 'before-exit-hook gnome-exit))
444
(destroy-window gnome-window-id)
445
(delete-x-property 'root '_WIN_SUPPORTING_WM_CHECK)
446
(delete-x-property 'root '_WIN_PROTOCOLS)
447
(delete-x-property 'root '_WIN_AREA)
448
(delete-x-property 'root '_WIN_AREA_COUNT)
449
(delete-x-property 'root '_WIN_UNIFIED_AREA))
451
(unless (or gnome-window-id batch-mode)
453
(require 'sawfish.wm.gnome.match-window))
455
(add-window-menu-toggle (_ "In GNOME _task list")
456
'gnome-toggle-skip-tasklist
457
(lambda (w) (not (gnome-hint-set-p w WIN_HINTS_SKIP_TASKLIST)))))
added
removed
lisp/sawfish/wm/state/gnome.jl
