5
;; sawmill-menu -- subprocess to handle menus
6
;; $Id: sawfish-menu.jl,v 1.6 2000/12/19 23:05:43 jsh Exp $
8
;; Copyright (C) 1999 John Harper <john@dcs.warwick.ac.uk>
10
;; This file is part of sawmill.
12
;; sawmill is free software; you can redistribute it and/or modify it
13
;; under the terms of the GNU General Public License as published by
14
;; the Free Software Foundation; either version 2, or (at your option)
17
;; sawmill is distributed in the hope that it will be useful, but
18
;; WITHOUT ANY WARRANTY; without even the implied warranty of
19
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20
;; GNU General Public License for more details.
22
;; You should have received a copy of the GNU General Public License
23
;; along with sawmill; see the file COPYING. If not, write to
24
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
27
(require 'rep.data.tables)
32
(define menu-selected nil)
34
;; map radio-group ids to the last widget
35
(define group-table (make-fluid))
37
(define (make-group-table) (make-table symbol-hash eq))
38
(define (group-id-set id w) (table-set (fluid group-table) id w))
39
(define (group-id-ref id) (table-ref (fluid group-table) id))
41
(define (create-menu spec #!optional bar)
42
(let* ((menu (if bar (gtk-menu-bar-new) (gtk-menu-new)))
43
(accels (gtk-menu-ensure-uline-accel-group menu)))
45
;; Set the label of the menu item, handling underlined accelerators
46
(define (label-menu-item item label-text #!optional shortcut)
47
(let* ((label (gtk-label-new label-text))
48
(hbox (gtk-hbox-new nil 16))
49
(hkey (gtk-label-parse-uline label label-text)))
50
(gtk-box-pack-start hbox label nil nil t 0)
52
(let ((accel (gtk-label-new shortcut)))
53
(gtk-box-pack-end hbox accel nil nil 0)))
54
(gtk-widget-add-accelerator item "activate_item" accels hkey 0 0)
55
(gtk-widget-show-all hbox)
56
(gtk-container-add item hbox)))
60
(when (and cell (symbolp (car cell)))
61
(setq cell (symbol-value (car cell))))
64
(setq item (gtk-menu-item-new))
66
(setq label (car cell))
67
(setq cell (cdr cell))
68
(if (and (consp (car cell)) (stringp (car (car cell))))
70
(let ((sub (create-menu cell)))
71
(setq item (gtk-menu-item-new))
72
(label-menu-item item label)
73
(gtk-menu-item-set-submenu item sub))
76
(let ((options (cdr cell)))
77
(let* ((check (assq 'check options))
78
(group (cdr (assq 'group options)))
79
(insensitive (cdr (assq 'insensitive options)))
80
(shortcut (cdr (assq 'shortcut options)))
81
(last-widget (and group (group-id-ref group))))
83
(setq item (gtk-radio-menu-item-new-from-widget
85
(group-id-set group item))
87
(setq item (gtk-check-menu-item-new))
88
(gtk-check-menu-item-set-show-toggle item t))
89
(t (setq item (gtk-menu-item-new))))
90
(label-menu-item item label shortcut)
92
(gtk-check-menu-item-set-state item (cdr check)))
94
(gtk-widget-set-sensitive item nil))))
97
item "activate" (lambda ()
98
(setq menu-selected (car cell))))))
100
(gtk-widget-lock-accelerators item)
101
((if bar gtk-menu-bar-append gtk-menu-append) menu item)
102
(gtk-widget-show item))))
106
(define (popup-menu spec #!optional timestamp position)
107
(let ((menu (let-fluids ((group-table (make-group-table)))
108
(create-menu spec))))
109
(gtk-signal-connect menu "deactivate" gtk-main-quit)
110
(setq menu-selected nil)
111
(gtk-menu-popup-interp menu nil nil 0 (or timestamp 0) position)
116
;; entry point, loop reading command forms, sending back results
120
(let ((input (read standard-input)))
121
(format standard-output "%S\n"
122
(apply (symbol-value (car input)) (cdr input)))
123
(when (filep standard-output)
124
(flush-file standard-output))))
129
;; major-mode: lisp-mode
added
removed
scripts/sawfish-menu.jl
