![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to x-menu.el CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / lisp|
Return to x-menu.el CVS log | Up to [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / lisp |
1.1 root 1: ;; Copyright (C) 1986 Free Software Foundation, Inc.
2:
3: ;; This file is part of GNU Emacs.
4:
5: ;; GNU Emacs is distributed in the hope that it will be useful,
6: ;; but WITHOUT ANY WARRANTY. No author or distributor
7: ;; accepts responsibility to anyone for the consequences of using it
8: ;; or for whether it serves any particular purpose or works at all,
9: ;; unless he says so in writing. Refer to the GNU Emacs General Public
10: ;; License for full details.
11:
12: ;; Everyone is granted permission to copy, modify and redistribute
13: ;; GNU Emacs, but only under the conditions described in the
14: ;; GNU Emacs General Public License. A copy of this license is
15: ;; supposed to have been given to you along with GNU Emacs so you
16: ;; can know your rights and responsibilities. It should be in a
17: ;; file named COPYING. Among other things, the copyright notice
18: ;; and this notice must be preserved on all copies.
19:
20:
21: (defmacro caar (conscell)
22: (list 'car (list 'car conscell)))
23:
24: (defmacro cdar (conscell)
25: (list 'cdr (list 'car conscell)))
26:
27: (defun x-menu-mode ()
28: "Major mode for creating permanent menus for use with X.
29: These menus are implemented entirely in Lisp; popup menus, implemented
30: with x-popup-menu, are implemented using XMenu primitives."
31: (make-local-variable 'x-menu-items-per-line)
32: (make-local-variable 'x-menu-item-width)
33: (make-local-variable 'x-menu-items-alist)
34: (make-local-variable 'x-process-mouse-hook)
35: (make-local-variable 'x-menu-assoc-buffer)
36: (setq buffer-read-only t)
37: (setq truncate-lines t)
38: (setq x-process-mouse-hook 'x-menu-pick-entry)
39: (setq mode-line-buffer-identification '("MENU: %32b")))
40:
41: (defvar x-menu-max-width 0)
42: (defvar x-menu-items-per-line 0)
43: (defvar x-menu-item-width 0)
44: (defvar x-menu-items-alist nil)
45: (defvar x-menu-assoc-buffer nil)
46:
47: (defvar x-menu-item-spacing 1
48: "*Minimum horizontal spacing between objects in a permanent X menu.")
49:
50: (defun x-menu-create-menu (name)
51: "Create a permanent X menu. Returns an item which should be used as a
52: menu object whenever referring to the menu."
53: (let ((old (current-buffer))
54: (buf (get-buffer-create name)))
55: (set-buffer buf)
56: (x-menu-mode)
57: (setq x-menu-assoc-buffer old)
58: (set-buffer old)
59: buf))
60:
61: (defun x-menu-change-associated-buffer (menu buffer)
62: "Change associated buffer of MENU to BUFFER. BUFFER should be a buffer
63: object."
64: (let ((old (current-buffer)))
65: (set-buffer menu)
66: (setq x-menu-assoc-buffer buffer)
67: (set-buffer old)))
68:
69: (defun x-menu-add-item (menu item binding)
70: "Adds to MENU an item with name ITEM, associated with BINDING.
71: Following a sequence of calls to x-menu-add-item, a call to x-menu-compute
72: should be performed before the menu will be made available to the user.
73:
74: BINDING should be a function of one argument, which is the numerical
75: button/key code as defined in x-menu.el."
76: (let ((old (current-buffer))
77: elt)
78: (set-buffer menu)
79: (if (setq elt (assoc item x-menu-items-alist))
80: (rplacd elt binding)
81: (setq x-menu-items-alist (append x-menu-items-alist
82: (list (cons item binding)))))
83: (set-buffer old)
84: item))
85:
86: (defun x-menu-delete-item (menu item)
87: "Deletes from MENU the item named ITEM. x-menu-compute should be called
88: before the menu is made available to the user."
89: (let ((old (current-buffer))
90: elt)
91: (set-buffer menu)
92: (if (setq elt (assoc item x-menu-items-alist))
93: (rplaca elt nil))
94: (set-buffer old)
95: item))
96:
97: (defun x-menu-activate (menu)
98: "Computes all necessary parameters for MENU. This must be called whenever
99: a menu is modified before it is made available to the user.
100:
101: This also creates the menu itself."
102: (let ((buf (current-buffer)))
103: (pop-to-buffer menu)
104: (let (buffer-read-only)
105: (setq x-menu-max-width (1- (screen-width)))
106: (setq x-menu-item-width 0)
107: (let (items-head
108: (items-tail x-menu-items-alist))
109: (while items-tail
110: (if (caar items-tail)
111: (progn (setq items-head (cons (car items-tail) items-head))
112: (setq x-menu-item-width
113: (max x-menu-item-width
114: (length (caar items-tail))))))
115: (setq items-tail (cdr items-tail)))
116: (setq x-menu-items-alist (reverse items-head)))
117: (setq x-menu-item-width (+ x-menu-item-spacing x-menu-item-width))
118: (setq x-menu-items-per-line
119: (max 1 (/ x-menu-max-width x-menu-item-width)))
120: (erase-buffer)
121: (let ((items-head x-menu-items-alist))
122: (while items-head
123: (let ((items 0))
124: (while (and items-head
125: (<= (setq items (1+ items)) x-menu-items-per-line))
126: (insert (format (concat "%"
127: (int-to-string x-menu-item-width) "s")
128: (caar items-head)))
129: (setq items-head (cdr items-head))))
130: (insert ?\n)))
131: (shrink-window (max 0
132: (- (window-height)
133: (1+ (count-lines (point-min) (point-max))))))
134: (goto-char (point-min)))
135: (pop-to-buffer buf)))
136:
137: (defun x-menu-pick-entry (position event)
138: "Internal function for dispatching on mouse/menu events"
139: (let* ((x (min (1- x-menu-items-per-line)
140: (/ (current-column) x-menu-item-width)))
141: (y (- (count-lines (point-min) (point))
142: (if (zerop (current-column)) 0 1)))
143: (item (+ x (* y x-menu-items-per-line)))
144: (litem (cdr (nth item x-menu-items-alist))))
145: (and litem (funcall litem event)))
146: (pop-to-buffer x-menu-assoc-buffer))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.