File: menus.jl

package info (click to toggle)
sawfish 1%3A1.3.5.2-2
  • links: PTS, VCS
  • area: main
  • in suites: squeeze
  • size: 11,636 kB
  • ctags: 1,327
  • sloc: lisp: 22,765; ansic: 15,810; sh: 10,203; makefile: 675; perl: 19
file content (361 lines) | stat: -rw-r--r-- 12,231 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
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
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
;; menus.jl -- popup menus
;; $Id: menus.jl,v 1.76 2005/02/07 00:12:18 jsh Exp $

;; Copyright (C) 1999 John Harper <john@dcs.warwick.ac.uk>

;; This file is part of sawmill.

;; sawmill 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; either version 2, or (at your option)
;; any later version.

;; sawmill 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.

;; You should have received a copy of the GNU General Public License
;; along with sawmill; see the file COPYING.  If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

(define-structure sawfish.wm.menus

    (export menu-start-process
	    menu-stop-process
	    popup-menu
	    popup-window-menu
	    popup-root-menu
	    popup-apps-menu
	    add-window-menu-toggle
	    custom-menu)

    (open rep
	  rep.regexp
	  rep.io.files
	  rep.io.processes
	  rep.data.tables
	  sawfish.wm.events
	  sawfish.wm.windows
	  sawfish.wm.misc
	  sawfish.wm.custom
	  sawfish.wm.frames
	  sawfish.wm.commands
	  sawfish.wm.util.groups
	  sawfish.wm.workspace
	  sawfish.wm.state.maximize
	  sawfish.wm.state.iconify)

  (define-structure-alias menus sawfish.wm.menus)

  ;; Suppress annoying compiler warnings
  (eval-when-compile (require 'rep.io.timers))

  (defvar menus-include-shortcuts nil
    "Display key-binding information in menu items.")

  (defvar menu-program (expand-file-name "sawfish-menu" sawfish-exec-directory)
    "Location of the program implementing sawfish's menu interface.")

  (defvar menu-program-stays-running t
    "When non-nil, the menu program is never stopped. If a number, then this
is taken as the number of seconds to let the process hang around unused
before killing it.")

  ;; the active user interface process
  (define menu-process nil)

  ;; output from the user-interface process that's received but not
  ;; yet processed
  (define menu-pending nil)

  ;; non-nil when we're waiting for a response from the ui process
  ;; if a window, then it's the window that received the event causing
  ;; the menu to be shown
  (define menu-active nil)

  ;; hash table mapping nicknames to result objects without read syntax
  (define nickname-table)
  (define nickname-index)

  ;; if menu-program-stays-running is a number, this may be a timer
  ;; waiting to kill the process
  (define menu-timer nil)

  (defvar window-ops-menu
    `((,(_ "Mi_nimize") iconify-window
       (insensitive . ,(lambda (w)
                         (not (window-iconifiable-p w)))))
      (,(lambda (w)
          (if (window-maximized-p w)
              (_ "Unma_ximize")
            (_ "Ma_ximize"))) maximize-window-toggle
            (insensitive . ,(lambda (w)
                              (not (or (window-maximized-p w)
                                       (window-maximizable-p w))))))
      (,(_ "_Move") move-window-interactively)
      (,(_ "_Resize") resize-window-interactively)
      (,(_ "_Close") delete-window)
      ()
      (,(_ "_Toggle") . window-ops-toggle-menu)
      (,(_ "In _group") . window-group-menu)
      (,(_ "_Send window to")
       (,(_ "_Previous workspace") send-to-previous-workspace)
       (,(_ "_Next workspace") send-to-next-workspace)
       (,(_ "Copy to p_revious") copy-to-previous-workspace)
       (,(_ "Copy to ne_xt") copy-to-next-workspace))
      (,(_ "Stac_king")
       (,(_ "_Raise") raise-window)
       (,(_ "_Lower") lower-window)
       (,(_ "_Upper layer") raise-window-depth)
       (,(_ "Lo_wer layer") lower-window-depth))
      (,(_ "Frame ty_pe") . frame-type-menu)
      (,(_ "Frame sty_le") . frame-style-menu)))

  (defvar window-ops-toggle-menu '())

  (defvar window-menu nil)

  (defvar root-menu
    `((,(_ "_Windows") . window-menu)
      (,(_ "Work_spaces") . workspace-menu)
      (,(_ "_Programs") . apps-menu)
      (,(_ "_Customize") . custom-menu)
      (,(_ "_Help")
       (,(_ "_FAQ...") help:show-faq)
       (,(_ "_News...") help:show-news)
       (,(_ "_WWW page...") help:show-homepage)
       (,(_ "_Manual...") help:show-programmer-manual)
       (,(_ "_About Sawfish...") help:about))
      ()
      (,(_ "_Restart") restart)
      (,(_ "_Quit") quit)))

  (defvar apps-menu
    `(("xterm" (system "xterm &"))
      ("Emacs" (system "emacs &"))
      ("Netscape" (system "netscape &"))
      ("The GIMP" (system "gimp &"))
      ("XFIG" (system "xfig &"))
      ("GV" (system "gv &"))
      ("xcalc" (system "xcalc &"))))

  (define (menu-start-process)
    (when menu-timer
      (delete-timer menu-timer)
      (setq menu-timer nil))
    (unless (and menu-process (process-in-use-p menu-process))
      (when menu-process
	(kill-process menu-process)
	(setq menu-process nil))
      (let ((menu-sentinel (lambda ()
			     (when (and menu-process
					(not (process-in-use-p menu-process)))
			       (setq menu-process nil))
			     (when menu-timer
			       (delete-timer menu-timer)
			       (setq menu-timer nil))))
	    (menu-filter (lambda (output)
			   (setq output (concat menu-pending output))
			   (setq menu-pending nil)
			   (condition-case nil
			       (let
				   ((result (read-from-string output)))
				 ;; GTK takes the focus for its menu,
				 ;; but later returns it to the original
				 ;; window. We want the focus to be
				 ;; restored by the time the menu-chosen
				 ;; command is invoked..
				 (accept-x-input)
				 (menu-dispatch result))
			     (end-of-stream
			      (setq menu-pending output))))))
	(setq menu-process (make-process menu-filter menu-sentinel)))
      (set-process-error-stream menu-process nil)
      (or (start-process menu-process menu-program)
	  (error "Can't start menu backend: %s" menu-program))))

  (define (menu-stop-process #!optional force)
    (when menu-process
      (cond ((and (not force) (numberp menu-program-stays-running))
	     ;; number of seconds to let it hang around for
	     (require 'rep.io.timers)
	     (setq menu-timer (make-timer (lambda ()
					    (when menu-process
					      (kill-process menu-process)
					      (setq menu-process nil))
					    (setq menu-timer nil))
					  menu-program-stays-running)))
	    ((or force (not menu-program-stays-running))
	     (kill-process menu-process)
	     (setq menu-process nil)))))

  (define (make-nickname obj)
    (let ((nick nickname-index))
      (setq nickname-index (1+ nickname-index))
      (table-set nickname-table nick obj)
      nick))

  (define (nicknamep arg) (fixnump arg))
  (define (nickname-ref nick) (table-ref nickname-table nick))

  (define menu-args (make-fluid '()))
  (define where-is-fun (make-fluid '()))

  (define (menu-preprocessor cell)
    (define (inner cell)
      (when cell
	(let ((label (car cell)))
	  (when (functionp label)
	    (setq label (apply label (fluid menu-args))))
	  (cond ((functionp (cdr cell))
		 (setq cell (apply (cdr cell) (fluid menu-args))))
		((and (symbolp (cdr cell)) (not (null (cdr cell))))
		 (setq cell (symbol-value (cdr cell)))
		 (when (functionp cell)
		   (setq cell (apply cell (fluid menu-args)))))
		(t (setq cell (cdr cell))))
	  (when cell
	    (if (and (consp (car cell)) (stringp (car (car cell))))
		;; recurse through sub-menu
		(setq cell (mapcar inner cell))
	      (let* ((action (car cell))
		     (options (cdr cell))
		     (shortcut (and (fluid where-is-fun)
				    (symbolp action)
				    ((fluid where-is-fun) action))))
		(when (not (symbolp action))
		  ;; a non-symbol result, replace by a nickname
		  (setq action (make-nickname (car cell))))
		;; scan the alist of options
		(setq options (mapcar
			       (lambda (cell)
				 (if (functionp (cdr cell))
				     (cons (car cell)
					   (apply (cdr cell)
						  (fluid menu-args)))
				   cell)) options))
		(when shortcut
		  (setq options (cons (cons 'shortcut shortcut) options)))
		(setq cell (cons action options)))))
	  (cons label cell))))
    (let-fluids ((where-is-fun (and menus-include-shortcuts
				    (require 'sawfish.wm.util.keymap)
				    (make-memoizing-where-is
				     (list global-keymap window-keymap)))))
      (inner cell)))

  (define (menu-dispatch result)
    (let ((orig-win menu-active))
      (menu-stop-process)
      (when (nicknamep result)
	(setq result (nickname-ref result)))
      (setq menu-active nil)
      (setq nickname-table nil)
      (frame-draw-mutex nil)
      (when result
	(when (windowp orig-win)
	  (current-event-window orig-win))
	(cond ((commandp result)
	       (call-command result))
	      ((functionp result)
	       (result))
	      ((consp result)
	       (user-eval result))
	      (t result)))))

  (define (popup-menu spec)
    (or spec (error "No menu given to popup-menu"))
    (if (and menu-active menu-process (process-in-use-p menu-process))
	(error "Menu already active")
      (let* ((part (clicked-frame-part))
	     (offset (and part (frame-part-position part)))
	     (dims (and part (frame-part-dimensions part))))
	(setq menu-active (or (current-event-window) (input-focus)))
	(condition-case error-data
	    (progn
	      (menu-start-process)
	      ;; prevent any depressed button being redrawn until the menu
	      ;; is popped down
	      ;; XXX expose events screw this up..
	      (when (clicked-frame-part)
		(frame-draw-mutex t))
	      ;; This function is probably called from a ButtonPress event,
	      ;; so cancel the implicit pointer grab (to allow the menu's grab
	      ;; to succeed)
	      (ungrab-pointer)
	      (ungrab-keyboard)
	      (sync-server t)
	      (when (functionp spec)
		(setq spec (spec)))
	      ;; XXX this is a hack, but I want menus to appear under buttons
	      (if (and part (setq part (frame-part-get part 'class))
		       (windowp menu-active)
		       (string-match "-button$" (symbol-name part)))
		  (progn
		    (rplaca offset
			    (max 0 (+ (car offset)
				      (car (window-position menu-active)))))
		    (rplacd offset
			    (max 0 (+ (cdr offset) (cdr dims)
				      (cdr (window-position menu-active))))))
		(setq offset nil))
	      (setq nickname-table (make-table eq-hash eq))
	      (setq nickname-index 0)
	      (format menu-process "(popup-menu %s %S %S)\n"
		      ;; write out the menu spec in one chunk to
		      ;; avoid large numbers of system calls :-[
		      (format nil "%S" (mapcar menu-preprocessor spec))
		      (x-server-timestamp) offset))
	      (error
	       ;; prevents spurious errors with subsequent menus
	       (setq menu-active nil)
	       (apply signal error-data))))))

  (define (popup-window-menu w)
    "Display the menu listing all window operations."
    (let-fluids ((menu-args (list w)))
      (popup-menu window-ops-menu)))

  (define (popup-root-menu)
    "Display the main menu."
    (popup-menu root-menu))

  (define (popup-apps-menu)
    "Display the applications menu."
    (popup-menu apps-menu))

  ;;###autoload
  (define-command 'popup-window-menu popup-window-menu #:spec "%W")
  (define-command 'popup-root-menu popup-root-menu)
  (define-command 'popup-apps-menu popup-apps-menu)

;;; menu modifiers

  (define (add-window-menu-toggle label command #!optional predicate)
    (let ((item (list* label command
		       (and predicate (list (cons 'check predicate))))))
    (let loop ((rest window-ops-toggle-menu))
      (cond
       ((null rest)
	(setq window-ops-toggle-menu (nconc window-ops-toggle-menu
					    (list item))))
       ((eq (cadar rest) command)
	(rplaca rest item))
       (t (loop (cdr rest)))))))

;;; customize menu

  (defvar custom-menu-includes-all-settings t
    "When non-nil, the custom menu includes the `All settings' item.")

  (define (custom-menu)
    `(,@(and custom-menu-includes-all-settings
	     (list (list (_ "_All settings") 'customize) nil))
      ,@(mapcar (lambda (sub)
		  (list (_ (cadr sub))
			(intern (concat "customize:"
					(symbol-name (car sub))))))
		(filter consp (cddr custom-groups)))
      ,@(and (frame-style-editable-p default-frame-style)
	     (list nil `(,(_"Edit theme...") edit-frame-style))))))