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