Line data Source code
1 : ;;; tool-bar.el --- setting up the tool bar
2 :
3 : ;; Copyright (C) 2000-2017 Free Software Foundation, Inc.
4 :
5 : ;; Author: Dave Love <fx@gnu.org>
6 : ;; Keywords: mouse frames
7 : ;; Package: emacs
8 :
9 : ;; This file is part of GNU Emacs.
10 :
11 : ;; GNU Emacs is free software: you can redistribute it and/or modify
12 : ;; it under the terms of the GNU General Public License as published by
13 : ;; the Free Software Foundation, either version 3 of the License, or
14 : ;; (at your option) any later version.
15 :
16 : ;; GNU Emacs is distributed in the hope that it will be useful,
17 : ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 : ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 : ;; GNU General Public License for more details.
20 :
21 : ;; You should have received a copy of the GNU General Public License
22 : ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
23 :
24 : ;;; Commentary:
25 :
26 : ;; Provides `tool-bar-mode' to control display of the tool-bar and
27 : ;; bindings for the global tool bar with convenience functions
28 : ;; `tool-bar-add-item' and `tool-bar-add-item-from-menu'.
29 :
30 : ;; The normal global binding for [tool-bar] (below) uses the value of
31 : ;; `tool-bar-map' as the actual keymap to define the tool bar. Modes
32 : ;; may either bind items under the [tool-bar] prefix key of the local
33 : ;; map to add to the global bar or may set `tool-bar-map'
34 : ;; buffer-locally to override it. (Some items are removed from the
35 : ;; global bar in modes which have `special' as their `mode-class'
36 : ;; property.)
37 :
38 : ;; Todo: Somehow make tool bars easily customizable by the naive?
39 :
40 : ;;; Code:
41 :
42 : ;; The autoload cookie doesn't work when preloading.
43 : ;; Deleting it means invoking this command won't work
44 : ;; when you are on a tty. I hope that won't cause too much trouble -- rms.
45 : (define-minor-mode tool-bar-mode
46 : "Toggle the tool bar in all graphical frames (Tool Bar mode).
47 : With a prefix argument ARG, enable Tool Bar mode if ARG is
48 : positive, and disable it otherwise. If called from Lisp, enable
49 : Tool Bar mode if ARG is omitted or nil.
50 :
51 : See `tool-bar-add-item' and `tool-bar-add-item-from-menu' for
52 : conveniently adding tool bar items."
53 : :init-value t
54 : :global t
55 : ;; It's defined in C/cus-start, this stops the d-m-m macro defining it again.
56 : :variable tool-bar-mode
57 0 : (let ((val (if tool-bar-mode 1 0)))
58 0 : (dolist (frame (frame-list))
59 0 : (set-frame-parameter frame 'tool-bar-lines val))
60 : ;; If the user has given `default-frame-alist' a `tool-bar-lines'
61 : ;; parameter, replace it.
62 0 : (if (assq 'tool-bar-lines default-frame-alist)
63 0 : (setq default-frame-alist
64 0 : (cons (cons 'tool-bar-lines val)
65 0 : (assq-delete-all 'tool-bar-lines
66 0 : default-frame-alist)))))
67 0 : (and tool-bar-mode
68 0 : (= 1 (length (default-value 'tool-bar-map))) ; not yet setup
69 0 : (tool-bar-setup)))
70 :
71 : ;;;###autoload
72 : ;; Used in the Show/Hide menu, to have the toggle reflect the current frame.
73 : (defun toggle-tool-bar-mode-from-frame (&optional arg)
74 : "Toggle tool bar on or off, based on the status of the current frame.
75 : See `tool-bar-mode' for more information."
76 0 : (interactive (list (or current-prefix-arg 'toggle)))
77 0 : (if (eq arg 'toggle)
78 0 : (tool-bar-mode (if (> (frame-parameter nil 'tool-bar-lines) 0) 0 1))
79 0 : (tool-bar-mode arg)))
80 :
81 : (defvar tool-bar-map (make-sparse-keymap)
82 : "Keymap for the tool bar.
83 : Define this locally to override the global tool bar.")
84 :
85 : (global-set-key [tool-bar]
86 : `(menu-item ,(purecopy "tool bar") ignore
87 : :filter tool-bar-make-keymap))
88 :
89 : (declare-function image-mask-p "image.c" (spec &optional frame))
90 :
91 : (defconst tool-bar-keymap-cache (make-hash-table :weakness t :test 'equal))
92 :
93 : (defun tool-bar-make-keymap (&optional _ignore)
94 : "Generate an actual keymap from `tool-bar-map'.
95 : Its main job is to figure out which images to use based on the display's
96 : color capability and based on the available image libraries."
97 0 : (let ((key (cons (frame-terminal) tool-bar-map)))
98 0 : (or (gethash key tool-bar-keymap-cache)
99 0 : (puthash key (tool-bar-make-keymap-1) tool-bar-keymap-cache))))
100 :
101 : (defun tool-bar-make-keymap-1 ()
102 : "Generate an actual keymap from `tool-bar-map', without caching."
103 0 : (mapcar (lambda (bind)
104 0 : (let (image-exp plist)
105 0 : (when (and (eq (car-safe (cdr-safe bind)) 'menu-item)
106 : ;; For the format of menu-items, see node
107 : ;; `Extended Menu Items' in the Elisp manual.
108 0 : (setq plist (nthcdr (if (consp (nth 4 bind)) 5 4)
109 0 : bind))
110 0 : (setq image-exp (plist-get plist :image))
111 0 : (consp image-exp)
112 0 : (not (eq (car image-exp) 'image))
113 0 : (fboundp (car image-exp)))
114 0 : (if (not (display-images-p))
115 0 : (setq bind nil)
116 0 : (let ((image (eval image-exp)))
117 0 : (unless (and image (image-mask-p image))
118 0 : (setq image (append image '(:mask heuristic))))
119 0 : (setq bind (copy-sequence bind)
120 0 : plist (nthcdr (if (consp (nth 4 bind)) 5 4)
121 0 : bind))
122 0 : (plist-put plist :image image))))
123 0 : bind))
124 0 : tool-bar-map))
125 :
126 : ;;;###autoload
127 : (defun tool-bar-add-item (icon def key &rest props)
128 : "Add an item to the tool bar.
129 : ICON names the image, DEF is the key definition and KEY is a symbol
130 : for the fake function key in the menu keymap. Remaining arguments
131 : PROPS are additional items to add to the menu item specification. See
132 : Info node `(elisp)Tool Bar'. Items are added from left to right.
133 :
134 : ICON is the base name of a file containing the image to use. The
135 : function will first try to use low-color/ICON.xpm if `display-color-cells'
136 : is less or equal to 256, then ICON.xpm, then ICON.pbm, and finally
137 : ICON.xbm, using `find-image'.
138 :
139 : Use this function only to make bindings in the global value of `tool-bar-map'.
140 : To define items in any other map, use `tool-bar-local-item'."
141 0 : (apply 'tool-bar-local-item icon def key tool-bar-map props))
142 :
143 : (defun tool-bar--image-expression (icon)
144 : "Return an expression that evaluates to an image spec for ICON."
145 0 : (let* ((fg (face-attribute 'tool-bar :foreground))
146 0 : (bg (face-attribute 'tool-bar :background))
147 0 : (colors (nconc (if (eq fg 'unspecified) nil (list :foreground fg))
148 0 : (if (eq bg 'unspecified) nil (list :background bg))))
149 0 : (xpm-spec (list :type 'xpm :file (concat icon ".xpm")))
150 0 : (xpm-lo-spec (list :type 'xpm :file
151 0 : (concat "low-color/" icon ".xpm")))
152 0 : (pbm-spec (append (list :type 'pbm :file
153 0 : (concat icon ".pbm")) colors))
154 0 : (xbm-spec (append (list :type 'xbm :file
155 0 : (concat icon ".xbm")) colors)))
156 0 : `(find-image (cond ((not (display-color-p))
157 0 : ',(list pbm-spec xbm-spec xpm-lo-spec xpm-spec))
158 : ((< (display-color-cells) 256)
159 0 : ',(list xpm-lo-spec xpm-spec pbm-spec xbm-spec))
160 : (t
161 0 : ',(list xpm-spec pbm-spec xbm-spec))))))
162 :
163 : ;;;###autoload
164 : (defun tool-bar-local-item (icon def key map &rest props)
165 : "Add an item to the tool bar in map MAP.
166 : ICON names the image, DEF is the key definition and KEY is a symbol
167 : for the fake function key in the menu keymap. Remaining arguments
168 : PROPS are additional items to add to the menu item specification. See
169 : Info node `(elisp)Tool Bar'. Items are added from left to right.
170 :
171 : ICON is the base name of a file containing the image to use. The
172 : function will first try to use low-color/ICON.xpm if `display-color-cells'
173 : is less or equal to 256, then ICON.xpm, then ICON.pbm, and finally
174 : ICON.xbm, using `find-image'."
175 0 : (let* ((image-exp (tool-bar--image-expression icon)))
176 0 : (define-key-after map (vector key)
177 0 : `(menu-item ,(symbol-name key) ,def :image ,image-exp ,@props))
178 0 : (force-mode-line-update)))
179 :
180 : ;;;###autoload
181 : (defun tool-bar-add-item-from-menu (command icon &optional map &rest props)
182 : "Define tool bar binding for COMMAND in keymap MAP using the given ICON.
183 : This makes a binding for COMMAND in `tool-bar-map', copying its
184 : binding from the menu bar in MAP (which defaults to `global-map'), but
185 : modifies the binding by adding an image specification for ICON. It
186 : finds ICON just like `tool-bar-add-item'. PROPS are additional
187 : properties to add to the binding.
188 :
189 : MAP must contain appropriate binding for `[menu-bar]' which holds a keymap.
190 :
191 : Use this function only to make bindings in the global value of `tool-bar-map'.
192 : To define items in any other map, use `tool-bar-local-item-from-menu'."
193 0 : (apply 'tool-bar-local-item-from-menu command icon
194 0 : (default-value 'tool-bar-map) map props))
195 :
196 : ;;;###autoload
197 : (defun tool-bar-local-item-from-menu (command icon in-map &optional from-map &rest props)
198 : "Define local tool bar binding for COMMAND using the given ICON.
199 : This makes a binding for COMMAND in IN-MAP, copying its binding from
200 : the menu bar in FROM-MAP (which defaults to `global-map'), but
201 : modifies the binding by adding an image specification for ICON. It
202 : finds ICON just like `tool-bar-add-item'. PROPS are additional
203 : properties to add to the binding.
204 :
205 : FROM-MAP must contain appropriate binding for `[menu-bar]' which
206 : holds a keymap."
207 0 : (unless from-map
208 0 : (setq from-map global-map))
209 0 : (let* ((menu-bar-map (lookup-key from-map [menu-bar]))
210 0 : (keys (where-is-internal command menu-bar-map))
211 0 : (image-exp (tool-bar--image-expression icon))
212 : submap key)
213 : ;; We'll pick up the last valid entry in the list of keys if
214 : ;; there's more than one.
215 : ;; FIXME: Aren't they *all* "valid"?? --Stef
216 0 : (dolist (k keys)
217 : ;; We're looking for a binding of the command in a submap of
218 : ;; the menu bar map, so the key sequence must be two or more
219 : ;; long.
220 0 : (if (and (vectorp k)
221 0 : (> (length k) 1))
222 0 : (let ((m (lookup-key menu-bar-map (substring k 0 -1)))
223 : ;; Last element in the bound key sequence:
224 0 : (kk (aref k (1- (length k)))))
225 0 : (if (and (keymapp m)
226 0 : (symbolp kk))
227 0 : (setq submap m
228 0 : key kk)))))
229 0 : (when (and (symbolp submap) (boundp submap))
230 0 : (setq submap (eval submap)))
231 0 : (let ((defn (assq key (cdr submap))))
232 0 : (if (eq (cadr defn) 'menu-item)
233 0 : (define-key-after in-map (vector key)
234 0 : (append (cdr defn) (list :image image-exp) props))
235 0 : (setq defn (cdr defn))
236 0 : (define-key-after in-map (vector key)
237 0 : (let ((rest (cdr defn)))
238 : ;; If the rest of the definition starts
239 : ;; with a list of menu cache info, get rid of that.
240 0 : (if (and (consp rest) (consp (car rest)))
241 0 : (setq rest (cdr rest)))
242 0 : (append `(menu-item ,(car defn) ,rest)
243 0 : (list :image image-exp) props))))
244 0 : (force-mode-line-update))))
245 :
246 : ;;; Set up some global items. Additions/deletions up for grabs.
247 :
248 : (defun tool-bar-setup ()
249 0 : (setq tool-bar-separator-image-expression
250 0 : (tool-bar--image-expression "separator"))
251 0 : (tool-bar-add-item-from-menu 'find-file "new" nil :label "New File"
252 0 : :vert-only t)
253 0 : (tool-bar-add-item-from-menu 'menu-find-file-existing "open" nil
254 0 : :label "Open" :vert-only t)
255 0 : (tool-bar-add-item-from-menu 'dired "diropen" nil :vert-only t)
256 0 : (tool-bar-add-item-from-menu 'kill-this-buffer "close" nil :vert-only t)
257 0 : (tool-bar-add-item-from-menu 'save-buffer "save" nil
258 0 : :label "Save")
259 0 : (define-key-after (default-value 'tool-bar-map) [separator-1] menu-bar-separator)
260 0 : (tool-bar-add-item-from-menu 'undo "undo" nil)
261 0 : (define-key-after (default-value 'tool-bar-map) [separator-2] menu-bar-separator)
262 0 : (tool-bar-add-item-from-menu (lookup-key menu-bar-edit-menu [cut])
263 0 : "cut" nil :vert-only t)
264 0 : (tool-bar-add-item-from-menu (lookup-key menu-bar-edit-menu [copy])
265 0 : "copy" nil :vert-only t)
266 0 : (tool-bar-add-item-from-menu (lookup-key menu-bar-edit-menu [paste])
267 0 : "paste" nil :vert-only t)
268 0 : (define-key-after (default-value 'tool-bar-map) [separator-3] menu-bar-separator)
269 0 : (tool-bar-add-item-from-menu 'isearch-forward "search"
270 0 : nil :label "Search" :vert-only t)
271 : ;;(tool-bar-add-item-from-menu 'ispell-buffer "spell")
272 :
273 : ;; There's no icon appropriate for News and we need a command rather
274 : ;; than a lambda for Read Mail.
275 : ;;(tool-bar-add-item-from-menu 'compose-mail "mail/compose")
276 :
277 : ;; Help button on a tool bar is rather non-standard...
278 : ;; (let ((tool-bar-map (default-value 'tool-bar-map)))
279 : ;; (tool-bar-add-item "help" (lambda ()
280 : ;; (interactive)
281 : ;; (popup-menu menu-bar-help-menu))
282 : ;; 'help
283 : ;; :help "Pop up the Help menu"))
284 : )
285 :
286 : (if (featurep 'move-toolbar)
287 : (defcustom tool-bar-position 'top
288 : "Specify on which side the tool bar shall be.
289 : Possible values are `top' (tool bar on top), `bottom' (tool bar at bottom),
290 : `left' (tool bar on left) and `right' (tool bar on right).
291 : Customize `tool-bar-mode' if you want to show or hide the tool bar."
292 : :version "24.1"
293 : :type '(choice (const top)
294 : (const bottom)
295 : (const left)
296 : (const right))
297 : :group 'frames
298 : :initialize 'custom-initialize-default
299 : :set (lambda (sym val)
300 : (set-default sym val)
301 : (modify-all-frames-parameters
302 : (list (cons 'tool-bar-position val))))))
303 :
304 :
305 : (provide 'tool-bar)
306 :
307 : ;;; tool-bar.el ends here
|