annotate lisp/x-menu.el @ 1097:d9efc1c88574

(command_loop_1): Bind inhibit-quit to t when in Fsit_for.
author Richard M. Stallman <rms@gnu.org>
date Fri, 11 Sep 1992 23:33:17 +0000
parents 2cdce064065f
children 83fea4c633e8
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
656
d74e65773062 *** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents: 35
diff changeset
1 ;;; x-menu.el --- menu support for X
d74e65773062 *** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents: 35
diff changeset
2
35
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
3 ;; Copyright (C) 1986 Free Software Foundation, Inc.
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
4
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
5 ;; This file is part of GNU Emacs.
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
6
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
7 ;; GNU Emacs is free software; you can redistribute it and/or modify
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
8 ;; it under the terms of the GNU General Public License as published by
806
d42e1151eed8 *** empty log message ***
Jim Blandy <jimb@redhat.com>
parents: 773
diff changeset
9 ;; the Free Software Foundation; either version 2, or (at your option)
35
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
10 ;; any later version.
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
11
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
12 ;; GNU Emacs is distributed in the hope that it will be useful,
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
15 ;; GNU General Public License for more details.
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
16
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
17 ;; You should have received a copy of the GNU General Public License
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
18 ;; along with GNU Emacs; see the file COPYING. If not, write to
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
19 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
20
773
9c89fd7ddd41 *** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents: 656
diff changeset
21 ;;; Code:
35
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
22
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
23 (defmacro caar (conscell)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
24 (list 'car (list 'car conscell)))
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
25
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
26 (defmacro cdar (conscell)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
27 (list 'cdr (list 'car conscell)))
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
28
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
29 (defun x-menu-mode ()
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
30 "Major mode for creating permanent menus for use with X.
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
31 These menus are implemented entirely in Lisp; popup menus, implemented
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
32 with x-popup-menu, are implemented using XMenu primitives."
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
33 (make-local-variable 'x-menu-items-per-line)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
34 (make-local-variable 'x-menu-item-width)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
35 (make-local-variable 'x-menu-items-alist)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
36 (make-local-variable 'x-process-mouse-hook)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
37 (make-local-variable 'x-menu-assoc-buffer)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
38 (setq buffer-read-only t)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
39 (setq truncate-lines t)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
40 (setq x-process-mouse-hook 'x-menu-pick-entry)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
41 (setq mode-line-buffer-identification '("MENU: %32b")))
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
42
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
43 (defvar x-menu-max-width 0)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
44 (defvar x-menu-items-per-line 0)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
45 (defvar x-menu-item-width 0)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
46 (defvar x-menu-items-alist nil)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
47 (defvar x-menu-assoc-buffer nil)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
48
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
49 (defvar x-menu-item-spacing 1
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
50 "*Minimum horizontal spacing between objects in a permanent X menu.")
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
51
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
52 (defun x-menu-create-menu (name)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
53 "Create a permanent X menu. Returns an item which should be used as a
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
54 menu object whenever referring to the menu."
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
55 (let ((old (current-buffer))
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
56 (buf (get-buffer-create name)))
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
57 (set-buffer buf)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
58 (x-menu-mode)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
59 (setq x-menu-assoc-buffer old)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
60 (set-buffer old)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
61 buf))
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
62
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
63 (defun x-menu-change-associated-buffer (menu buffer)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
64 "Change associated buffer of MENU to BUFFER. BUFFER should be a buffer
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
65 object."
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
66 (let ((old (current-buffer)))
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
67 (set-buffer menu)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
68 (setq x-menu-assoc-buffer buffer)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
69 (set-buffer old)))
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
70
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
71 (defun x-menu-add-item (menu item binding)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
72 "Adds to MENU an item with name ITEM, associated with BINDING.
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
73 Following a sequence of calls to x-menu-add-item, a call to x-menu-compute
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
74 should be performed before the menu will be made available to the user.
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
75
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
76 BINDING should be a function of one argument, which is the numerical
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
77 button/key code as defined in x-menu.el."
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
78 (let ((old (current-buffer))
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
79 elt)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
80 (set-buffer menu)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
81 (if (setq elt (assoc item x-menu-items-alist))
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
82 (rplacd elt binding)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
83 (setq x-menu-items-alist (append x-menu-items-alist
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
84 (list (cons item binding)))))
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
85 (set-buffer old)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
86 item))
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
87
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
88 (defun x-menu-delete-item (menu item)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
89 "Deletes from MENU the item named ITEM. x-menu-compute should be called
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
90 before the menu is made available to the user."
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
91 (let ((old (current-buffer))
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
92 elt)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
93 (set-buffer menu)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
94 (if (setq elt (assoc item x-menu-items-alist))
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
95 (rplaca elt nil))
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
96 (set-buffer old)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
97 item))
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
98
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
99 (defun x-menu-activate (menu)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
100 "Computes all necessary parameters for MENU. This must be called whenever
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
101 a menu is modified before it is made available to the user.
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
102
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
103 This also creates the menu itself."
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
104 (let ((buf (current-buffer)))
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
105 (pop-to-buffer menu)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
106 (let (buffer-read-only)
806
d42e1151eed8 *** empty log message ***
Jim Blandy <jimb@redhat.com>
parents: 773
diff changeset
107 (setq x-menu-max-width (1- (frame-width)))
35
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
108 (setq x-menu-item-width 0)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
109 (let (items-head
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
110 (items-tail x-menu-items-alist))
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
111 (while items-tail
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
112 (if (caar items-tail)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
113 (progn (setq items-head (cons (car items-tail) items-head))
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
114 (setq x-menu-item-width
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
115 (max x-menu-item-width
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
116 (length (caar items-tail))))))
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
117 (setq items-tail (cdr items-tail)))
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
118 (setq x-menu-items-alist (reverse items-head)))
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
119 (setq x-menu-item-width (+ x-menu-item-spacing x-menu-item-width))
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
120 (setq x-menu-items-per-line
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
121 (max 1 (/ x-menu-max-width x-menu-item-width)))
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
122 (erase-buffer)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
123 (let ((items-head x-menu-items-alist))
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
124 (while items-head
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
125 (let ((items 0))
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
126 (while (and items-head
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
127 (<= (setq items (1+ items)) x-menu-items-per-line))
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
128 (insert (format (concat "%"
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
129 (int-to-string x-menu-item-width) "s")
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
130 (caar items-head)))
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
131 (setq items-head (cdr items-head))))
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
132 (insert ?\n)))
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
133 (shrink-window (max 0
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
134 (- (window-height)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
135 (1+ (count-lines (point-min) (point-max))))))
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
136 (goto-char (point-min)))
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
137 (pop-to-buffer buf)))
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
138
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
139 (defun x-menu-pick-entry (position event)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
140 "Internal function for dispatching on mouse/menu events"
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
141 (let* ((x (min (1- x-menu-items-per-line)
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
142 (/ (current-column) x-menu-item-width)))
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
143 (y (- (count-lines (point-min) (point))
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
144 (if (zerop (current-column)) 0 1)))
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
145 (item (+ x (* y x-menu-items-per-line)))
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
146 (litem (cdr (nth item x-menu-items-alist))))
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
147 (and litem (funcall litem event)))
63b375f17a65 Initial revision
Jim Blandy <jimb@redhat.com>
parents:
diff changeset
148 (pop-to-buffer x-menu-assoc-buffer))
656
d74e65773062 *** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents: 35
diff changeset
149
d74e65773062 *** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents: 35
diff changeset
150 ;;; x-menu.el ends here