*** empty log message ***
[emacs.git] / lisp / x-menu.el
blobcad653f0303629763feb605650315e41c46d2b05
1 ;;; x-menu.el --- menu support for X
3 ;; Copyright (C) 1986 Free Software Foundation, Inc.
5 ;; This file is part of GNU Emacs.
7 ;; GNU Emacs is free software; you can redistribute it and/or modify
8 ;; it under the terms of the GNU General Public License as published by
9 ;; the Free Software Foundation; either version 2, or (at your option)
10 ;; any later version.
12 ;; GNU Emacs is distributed in the hope that it will be useful,
13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ;; GNU General Public License for more details.
17 ;; You should have received a copy of the GNU General Public License
18 ;; along with GNU Emacs; see the file COPYING. If not, write to the
19 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 ;; Boston, MA 02111-1307, USA.
22 ;;; Code:
24 (defun x-menu-mode ()
25 "Major mode for creating permanent menus for use with X.
26 These menus are implemented entirely in Lisp; popup menus, implemented
27 with x-popup-menu, are implemented using XMenu primitives."
28 (make-local-variable 'x-menu-items-per-line)
29 (make-local-variable 'x-menu-item-width)
30 (make-local-variable 'x-menu-items-alist)
31 (make-local-variable 'x-process-mouse-hook)
32 (make-local-variable 'x-menu-assoc-buffer)
33 (setq buffer-read-only t)
34 (setq truncate-lines t)
35 (setq x-process-mouse-hook 'x-menu-pick-entry)
36 (setq mode-line-buffer-identification '("MENU: %32b")))
38 (defvar x-menu-max-width 0)
39 (defvar x-menu-items-per-line 0)
40 (defvar x-menu-item-width 0)
41 (defvar x-menu-items-alist nil)
42 (defvar x-menu-assoc-buffer nil)
44 (defvar x-menu-item-spacing 1
45 "*Minimum horizontal spacing between objects in a permanent X menu.")
47 (defun x-menu-create-menu (name)
48 "Create a permanent X menu.
49 Returns an item which should be used as a
50 menu object whenever referring to the menu."
51 (let ((old (current-buffer))
52 (buf (get-buffer-create name)))
53 (set-buffer buf)
54 (x-menu-mode)
55 (setq x-menu-assoc-buffer old)
56 (set-buffer old)
57 buf))
59 (defun x-menu-change-associated-buffer (menu buffer)
60 "Change associated buffer of MENU to BUFFER.
61 BUFFER should be a buffer object."
62 (let ((old (current-buffer)))
63 (set-buffer menu)
64 (setq x-menu-assoc-buffer buffer)
65 (set-buffer old)))
67 (defun x-menu-add-item (menu item binding)
68 "Add to MENU an item with name ITEM, associated with BINDING.
69 Following a sequence of calls to x-menu-add-item, a call to x-menu-compute
70 should be performed before the menu will be made available to the user.
72 BINDING should be a function of one argument, which is the numerical
73 button/key code as defined in x-menu.el."
74 (let ((old (current-buffer))
75 elt)
76 (set-buffer menu)
77 (if (setq elt (assoc item x-menu-items-alist))
78 (rplacd elt binding)
79 (setq x-menu-items-alist (append x-menu-items-alist
80 (list (cons item binding)))))
81 (set-buffer old)
82 item))
84 (defun x-menu-delete-item (menu item)
85 "Delete from MENU the item named ITEM.
86 Call `x-menu-compute' before making the menu available to the user."
87 (let ((old (current-buffer))
88 elt)
89 (set-buffer menu)
90 (if (setq elt (assoc item x-menu-items-alist))
91 (rplaca elt nil))
92 (set-buffer old)
93 item))
95 (defun x-menu-activate (menu)
96 "Compute all necessary parameters for MENU.
97 This must be called whenever a menu is modified before it is made
98 available to the user. This also creates the menu itself."
99 (let ((buf (current-buffer)))
100 (pop-to-buffer menu)
101 (let (buffer-read-only)
102 (setq x-menu-max-width (1- (frame-width)))
103 (setq x-menu-item-width 0)
104 (let (items-head
105 (items-tail x-menu-items-alist))
106 (while items-tail
107 (if (car (car items-tail))
108 (progn (setq items-head (cons (car items-tail) items-head))
109 (setq x-menu-item-width
110 (max x-menu-item-width
111 (length (car (car items-tail)))))))
112 (setq items-tail (cdr items-tail)))
113 (setq x-menu-items-alist (reverse items-head)))
114 (setq x-menu-item-width (+ x-menu-item-spacing x-menu-item-width))
115 (setq x-menu-items-per-line
116 (max 1 (/ x-menu-max-width x-menu-item-width)))
117 (erase-buffer)
118 (let ((items-head x-menu-items-alist))
119 (while items-head
120 (let ((items 0))
121 (while (and items-head
122 (<= (setq items (1+ items)) x-menu-items-per-line))
123 (insert (format (concat "%"
124 (int-to-string x-menu-item-width) "s")
125 (car (car items-head))))
126 (setq items-head (cdr items-head))))
127 (insert ?\n)))
128 (shrink-window (max 0
129 (- (window-height)
130 (1+ (count-lines (point-min) (point-max))))))
131 (goto-char (point-min)))
132 (pop-to-buffer buf)))
134 (defun x-menu-pick-entry (position event)
135 "Internal function for dispatching on mouse/menu events"
136 (let* ((x (min (1- x-menu-items-per-line)
137 (/ (current-column) x-menu-item-width)))
138 (y (- (count-lines (point-min) (point))
139 (if (zerop (current-column)) 0 1)))
140 (item (+ x (* y x-menu-items-per-line)))
141 (litem (cdr (nth item x-menu-items-alist))))
142 (and litem (funcall litem event)))
143 (pop-to-buffer x-menu-assoc-buffer))
145 (provide 'x-menu)
147 ;;; x-menu.el ends here