1 ;;; tool-bar.el --- setting up the tool bar
3 ;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
4 ;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
6 ;; Author: Dave Love <fx@gnu.org>
7 ;; Keywords: mouse frames
9 ;; This file is part of GNU Emacs.
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.
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.
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/>.
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'.
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'
38 ;; Todo: Somehow make tool bars easily customizable by the naive?
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 use of the tool bar.
47 With numeric ARG, display the tool bar if and only if ARG is positive.
49 See `tool-bar-add-item' and `tool-bar-add-item-from-menu' for
50 conveniently adding tool bar items."
55 ;; Make tool-bar even if terminal is non-graphical (Bug#1754).
56 (let ((val (if tool-bar-mode
1 0)))
57 (dolist (frame (frame-list))
58 (set-frame-parameter frame
'tool-bar-lines val
)))
60 (if (= 1 (length (default-value 'tool-bar-map
))) ; not yet setup
64 ;; Used in the Show/Hide menu, to have the toggle reflect the current frame.
65 (defun toggle-tool-bar-mode-from-frame (&optional arg
)
66 "Toggle tool bar on or off, based on the status of the current frame.
67 See `tool-bar-mode' for more information."
68 (interactive (list (or current-prefix-arg
'toggle
)))
70 (tool-bar-mode (if (> (frame-parameter nil
'tool-bar-lines
) 0) 0 1))
73 (defvar tool-bar-map
(make-sparse-keymap)
74 "Keymap for the tool bar.
75 Define this locally to override the global tool bar.")
77 (global-set-key [tool-bar
]
78 `(menu-item ,(purecopy "tool bar") ignore
79 :filter tool-bar-make-keymap
))
81 (declare-function image-mask-p
"image.c" (spec &optional frame
))
83 (defconst tool-bar-keymap-cache
(make-hash-table :weakness t
:test
'equal
))
85 (defun tool-bar-make-keymap (&optional ignore
)
86 "Generate an actual keymap from `tool-bar-map'.
87 Its main job is to figure out which images to use based on the display's
88 color capability and based on the available image libraries."
89 (let ((key (cons (frame-terminal) tool-bar-map
)))
90 (or (gethash key tool-bar-keymap-cache
)
91 (puthash key
(tool-bar-make-keymap-1) tool-bar-keymap-cache
))))
93 (defun tool-bar-make-keymap-1 ()
94 "Generate an actual keymap from `tool-bar-map', without caching."
95 (mapcar (lambda (bind)
96 (let (image-exp plist
)
97 (when (and (eq (car-safe (cdr-safe bind
)) 'menu-item
)
98 ;; For the format of menu-items, see node
99 ;; `Extended Menu Items' in the Elisp manual.
100 (setq plist
(nthcdr (if (consp (nth 4 bind
)) 5 4)
102 (setq image-exp
(plist-get plist
:image
))
104 (not (eq (car image-exp
) 'image
))
105 (fboundp (car image-exp
)))
106 (if (not (display-images-p))
108 (let ((image (eval image-exp
)))
109 (unless (and image
(image-mask-p image
))
110 (setq image
(append image
'(:mask heuristic
))))
111 (setq bind
(copy-sequence bind
)
112 plist
(nthcdr (if (consp (nth 4 bind
)) 5 4)
114 (plist-put plist
:image image
))))
119 (defun tool-bar-add-item (icon def key
&rest props
)
120 "Add an item to the tool bar.
121 ICON names the image, DEF is the key definition and KEY is a symbol
122 for the fake function key in the menu keymap. Remaining arguments
123 PROPS are additional items to add to the menu item specification. See
124 Info node `(elisp)Tool Bar'. Items are added from left to right.
126 ICON is the base name of a file containing the image to use. The
127 function will first try to use low-color/ICON.xpm if `display-color-cells'
128 is less or equal to 256, then ICON.xpm, then ICON.pbm, and finally
129 ICON.xbm, using `find-image'.
131 Use this function only to make bindings in the global value of `tool-bar-map'.
132 To define items in any other map, use `tool-bar-local-item'."
133 (apply 'tool-bar-local-item icon def key tool-bar-map props
))
136 (defun tool-bar-local-item (icon def key map
&rest props
)
137 "Add an item to the tool bar in map MAP.
138 ICON names the image, DEF is the key definition and KEY is a symbol
139 for the fake function key in the menu keymap. Remaining arguments
140 PROPS are additional items to add to the menu item specification. See
141 Info node `(elisp)Tool Bar'. Items are added from left to right.
143 ICON is the base name of a file containing the image to use. The
144 function will first try to use low-color/ICON.xpm if `display-color-cells'
145 is less or equal to 256, then ICON.xpm, then ICON.pbm, and finally
146 ICON.xbm, using `find-image'."
147 (let* ((fg (face-attribute 'tool-bar
:foreground
))
148 (bg (face-attribute 'tool-bar
:background
))
149 (colors (nconc (if (eq fg
'unspecified
) nil
(list :foreground fg
))
150 (if (eq bg
'unspecified
) nil
(list :background bg
))))
151 (xpm-spec (list :type
'xpm
:file
(concat icon
".xpm")))
152 (xpm-lo-spec (list :type
'xpm
:file
153 (concat "low-color/" icon
".xpm")))
154 (pbm-spec (append (list :type
'pbm
:file
155 (concat icon
".pbm")) colors
))
156 (xbm-spec (append (list :type
'xbm
:file
157 (concat icon
".xbm")) colors
))
158 (image-exp `(find-image
159 (cond ((not (display-color-p))
160 ',(list pbm-spec xbm-spec xpm-lo-spec xpm-spec
))
161 ((< (display-color-cells) 256)
162 ',(list xpm-lo-spec xpm-spec pbm-spec xbm-spec
))
164 ',(list xpm-spec pbm-spec xbm-spec
))))))
165 (define-key-after map
(vector key
)
166 `(menu-item ,(symbol-name key
) ,def
:image
,image-exp
,@props
))))
169 (defun tool-bar-add-item-from-menu (command icon
&optional map
&rest props
)
170 "Define tool bar binding for COMMAND in keymap MAP using the given ICON.
171 This makes a binding for COMMAND in `tool-bar-map', copying its
172 binding from the menu bar in MAP (which defaults to `global-map'), but
173 modifies the binding by adding an image specification for ICON. It
174 finds ICON just like `tool-bar-add-item'. PROPS are additional
175 properties to add to the binding.
177 MAP must contain appropriate binding for `[menu-bar]' which holds a keymap.
179 Use this function only to make bindings in the global value of `tool-bar-map'.
180 To define items in any other map, use `tool-bar-local-item-from-menu'."
181 (apply 'tool-bar-local-item-from-menu command icon
182 (default-value 'tool-bar-map
) map props
))
185 (defun tool-bar-local-item-from-menu (command icon in-map
&optional from-map
&rest props
)
186 "Define local tool bar binding for COMMAND using the given ICON.
187 This makes a binding for COMMAND in IN-MAP, copying its binding from
188 the menu bar in FROM-MAP (which defaults to `global-map'), but
189 modifies the binding by adding an image specification for ICON. It
190 finds ICON just like `tool-bar-add-item'. PROPS are additional
191 properties to add to the binding.
193 FROM-MAP must contain appropriate binding for `[menu-bar]' which
196 (setq from-map global-map
))
197 (let* ((menu-bar-map (lookup-key from-map
[menu-bar
]))
198 (keys (where-is-internal command menu-bar-map
))
199 (fg (face-attribute 'tool-bar
:foreground
))
200 (bg (face-attribute 'tool-bar
:background
))
201 (colors (nconc (if (eq fg
'unspecified
) nil
(list :foreground fg
))
202 (if (eq bg
'unspecified
) nil
(list :background bg
))))
203 (xpm-spec (list :type
'xpm
:file
(concat icon
".xpm")))
204 (xpm-lo-spec (list :type
'xpm
:file
205 (concat "low-color/" icon
".xpm")))
206 (pbm-spec (append (list :type
'pbm
:file
207 (concat icon
".pbm")) colors
))
208 (xbm-spec (append (list :type
'xbm
:file
209 (concat icon
".xbm")) colors
))
210 (image-exp `(find-image
211 (cond ((not (display-color-p))
212 ',(list pbm-spec xbm-spec xpm-lo-spec xpm-spec
))
213 ((< (display-color-cells) 256)
214 ',(list xpm-lo-spec xpm-spec pbm-spec xbm-spec
))
216 ',(list xpm-spec pbm-spec xbm-spec
)))))
218 ;; We'll pick up the last valid entry in the list of keys if
219 ;; there's more than one.
220 ;; FIXME: Aren't they *all* "valid"?? --Stef
222 ;; We're looking for a binding of the command in a submap of
223 ;; the menu bar map, so the key sequence must be two or more
227 (let ((m (lookup-key menu-bar-map
(substring k
0 -
1)))
228 ;; Last element in the bound key sequence:
229 (kk (aref k
(1- (length k
)))))
234 (when (and (symbolp submap
) (boundp submap
))
235 (setq submap
(eval submap
)))
236 (let ((defn (assq key
(cdr submap
))))
237 (if (eq (cadr defn
) 'menu-item
)
238 (define-key-after in-map
(vector key
)
239 (append (cdr defn
) (list :image image-exp
) props
))
240 (setq defn
(cdr defn
))
241 (define-key-after in-map
(vector key
)
242 (let ((rest (cdr defn
)))
243 ;; If the rest of the definition starts
244 ;; with a list of menu cache info, get rid of that.
245 (if (and (consp rest
) (consp (car rest
)))
246 (setq rest
(cdr rest
)))
247 (append `(menu-item ,(car defn
) ,rest
)
248 (list :image image-exp
) props
)))))))
250 ;;; Set up some global items. Additions/deletions up for grabs.
252 (defun tool-bar-setup ()
253 ;; People say it's bad to have EXIT on the tool bar, since users
254 ;; might inadvertently click that button.
255 ;;(tool-bar-add-item-from-menu 'save-buffers-kill-emacs "exit")
256 (tool-bar-add-item-from-menu 'find-file
"new" nil
:label
"New File")
257 (tool-bar-add-item-from-menu 'menu-find-file-existing
"open")
258 (tool-bar-add-item-from-menu 'dired
"diropen")
259 (tool-bar-add-item-from-menu 'kill-this-buffer
"close")
260 (tool-bar-add-item-from-menu 'save-buffer
"save" nil
261 :visible
'(or buffer-file-name
265 (tool-bar-add-item-from-menu 'write-file
"saveas" nil
266 :visible
'(or buffer-file-name
270 (tool-bar-add-item-from-menu 'undo
"undo" nil
271 :visible
'(not (eq 'special
(get major-mode
273 (tool-bar-add-item-from-menu (lookup-key menu-bar-edit-menu
[cut])
275 :visible '(not (eq 'special (get major-mode
277 (tool-bar-add-item-from-menu (lookup-key menu-bar-edit-menu [copy])
279 (tool-bar-add-item-from-menu (lookup-key menu-bar-edit-menu [paste])
281 :visible '(not (eq 'special (get major-mode
283 (tool-bar-add-item-from-menu 'nonincremental-search-forward "search"
285 ;;(tool-bar-add-item-from-menu 'ispell-buffer "spell")
287 ;; There's no icon appropriate for News and we need a command rather
288 ;; than a lambda for Read Mail.
289 ;;(tool-bar-add-item-from-menu 'compose-mail "mail/compose")
291 (tool-bar-add-item-from-menu 'print-buffer "print" nil :label "Print")
293 ;; tool-bar-add-item-from-menu itself operates on
294 ;; (default-value 'tool-bar-map), but when we don't use that function,
295 ;; we must explicitly operate on the default value.
297 (let ((tool-bar-map (default-value 'tool-bar-map)))
298 (tool-bar-add-item "preferences" 'customize 'customize
299 :help "Edit preferences (customize)")
301 (tool-bar-add-item "help" (lambda ()
303 (popup-menu menu-bar-help-menu))
305 :help "Pop up the Help menu")))
309 ;; arch-tag: 15f30f0a-d0d7-4d50-bbb7-f48fd0c8582f
310 ;;; tool-bar.el ends here