1 ;;; toolbar.el --- Toolbar support for SXEmacs
3 ;; Copyright (C) 1995, 1997 Free Software Foundation, Inc.
5 ;; Maintainer: SXEmacs Development Team
6 ;; Keywords: extensions, internal, dumped
8 ;; This file is part of SXEmacs.
10 ;; SXEmacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
15 ;; SXEmacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
23 ;;; Synched up with: Not in FSF.
27 ;; This file is dumped with SXEmacs (when toolbar support is compiled in).
31 (defcustom toolbar-visible-p ;; added for the options menu - dverna apr. 98
32 (specifier-instance default-toolbar-visible-p)
33 "Whether the default toolbar is globally visible.
34 This option can be customized through the options menu."
37 :set #'(lambda (var val)
38 (set-specifier default-toolbar-visible-p val)
39 (setq toolbar-visible-p val))
42 (defcustom toolbar-captioned-p ;; added for the options menu - dverna apr. 98
43 (specifier-instance toolbar-buttons-captioned-p)
44 "Whether the toolbars buttons are globally captioned.
45 This option can be customized through the options menu."
48 :set #'(lambda (var val)
49 (set-specifier toolbar-buttons-captioned-p val)
50 (setq toolbar-captioned-p val))
53 (defcustom default-toolbar-position ;; added for the options menu - dverna
54 (default-toolbar-position)
55 "The location of the default toolbar.
56 It can be 'top, 'bottom, 'left or 'right. This option can be
57 customized through the options menu."
59 :type '(choice (const :tag "top" top)
60 (const :tag "bottom" bottom)
61 (const :tag "left" left)
62 (const :tag "right" right))
63 :set #'(lambda (var val)
64 (set-default-toolbar-position val)
65 (setq default-toolbar-position val))
68 (defvar toolbar-help-enabled t
69 "If non-nil help is echoed for toolbar buttons.")
71 (defvar toolbar-icon-directory nil
72 "Location of standard toolbar icon bitmaps, with trailing path separator.")
74 (defun toolbar-make-button-list (up &optional down disabled cap-up cap-down cap-disabled)
75 "Call make-glyph on each arg and return a list of the results."
76 (let ((up-glyph (make-glyph up))
77 (down-glyph (and down (make-glyph down)))
78 (disabled-glyph (and disabled (make-glyph disabled)))
79 (cap-up-glyph (and cap-up (make-glyph cap-up)))
80 (cap-down-glyph (and cap-down (make-glyph cap-down)))
81 (cap-disabled-glyph (and cap-disabled (make-glyph cap-disabled))))
83 (list up-glyph down-glyph disabled-glyph
84 cap-up-glyph cap-down-glyph cap-disabled-glyph)
86 (list up-glyph down-glyph disabled-glyph
87 cap-up-glyph cap-down-glyph)
89 (list up-glyph down-glyph disabled-glyph cap-up-glyph)
91 (list up-glyph down-glyph disabled-glyph)
93 (list up-glyph down-glyph)
94 (list up-glyph))))))))
96 (defun init-toolbar-location ()
97 (if (not toolbar-icon-directory)
98 (let ((name (locate-data-directory "toolbar")))
100 (setq toolbar-icon-directory
101 (file-name-as-directory name))))))
103 (defun init-toolbar-from-resources (locale)
104 (if (and (featurep 'x)
105 (not (featurep 'infodock))
106 (or (eq locale 'global)
107 (eq 'x (device-or-frame-type locale))))
108 (x-init-toolbar-from-resources locale)))
111 ;; #### Is this actually needed or will the code in
112 ;; default-mouse-motion-handler suffice?
113 (define-key global-map 'button1up 'release-toolbar-button)
115 (defvar toolbar-map (let ((m (make-sparse-keymap)))
116 (set-keymap-name m 'toolbar-map)
118 "Keymap consulted for mouse-clicks over a toolbar.")
120 (define-key toolbar-map 'button1 'press-toolbar-button)
121 (define-key toolbar-map 'button1up 'release-and-activate-toolbar-button)
122 (defvar last-pressed-toolbar-button nil)
123 (defvar toolbar-active nil)
125 (defvar toolbar-blank-press-function nil
126 "Function to call if a blank area of the toolbar is pressed.")
129 ;; It really sucks that we also have to tie onto
130 ;; default-mouse-motion-handler to make sliding buttons work right.
132 (defun press-toolbar-button (event)
133 "Press a toolbar button. This only changes its appearance.
134 Call function stored in `toolbar-blank-press-function,' if any, with EVENT as
135 an argument if press is over a blank area of the toolbar."
137 (setq this-command last-command)
138 (let ((button (event-toolbar-button event)))
139 ;; We silently ignore non-buttons. This most likely means we are
140 ;; over a blank part of the toolbar.
141 (setq toolbar-active t)
142 (if (toolbar-button-p button)
144 (set-toolbar-button-down-flag button t)
145 (setq last-pressed-toolbar-button button))
146 ;; Added by Bob Weiner, Motorola Inc., 10/6/95, to handle
147 ;; presses on blank portions of toolbars.
148 (when (functionp toolbar-blank-press-function)
149 (funcall toolbar-blank-press-function event)))))
151 (defun release-and-activate-toolbar-button (event)
152 "Release a toolbar button and activate its callback.
153 Call function stored in `toolbar-blank-release-function,' if any, with EVENT
154 as an argument if release is over a blank area of the toolbar."
156 (or (button-release-event-p event)
157 (error "%s must be invoked by a mouse-release" this-command))
158 (release-toolbar-button event)
159 (let ((button (event-toolbar-button event)))
160 (if (and (toolbar-button-p button)
161 (toolbar-button-enabled-p button)
162 (toolbar-button-callback button))
163 (let ((callback (toolbar-button-callback button)))
164 (setq this-command callback)
165 ;; Handle arbitrary functions.
166 (if (functionp callback)
167 (if (commandp callback)
168 (call-interactively callback)
172 ;; If current is not t, then only release the toolbar button stored in
173 ;; last-pressed-toolbar-button
174 (defun release-toolbar-button-internal (event current)
175 (let ((button (event-toolbar-button event)))
176 (setq zmacs-region-stays t)
177 (if (and last-pressed-toolbar-button
178 (not (eq last-pressed-toolbar-button button))
179 (toolbar-button-p last-pressed-toolbar-button))
181 (set-toolbar-button-down-flag last-pressed-toolbar-button nil)
182 (setq last-pressed-toolbar-button nil)))
183 (if (and current (toolbar-button-p button))
184 (set-toolbar-button-down-flag button nil))))
186 (defun release-toolbar-button (event)
187 "Release all pressed toolbar buttons."
189 (or (button-release-event-p event)
190 (error "%s must be invoked by a mouse-release" this-command))
191 (release-toolbar-button-internal event t)
192 ;; Don't set this-command if we're being called
193 ;; from release-and-activate-toolbar-button.
195 (setq this-command last-command))
196 (setq toolbar-active nil))
198 (defun release-previous-toolbar-button (event)
199 (setq zmacs-region-stays t)
200 (release-toolbar-button-internal event nil))
202 (defun make-toolbar-specifier (spec-list)
203 "Return a new `toolbar' specifier object with the given specification list.
204 SPEC-LIST can be a list of specifications (each of which is a cons of a
205 locale and a list of instantiators), a single instantiator, or a list
206 of instantiators. See `make-specifier' for more information about
209 Toolbar specifiers are used to specify the format of a toolbar.
210 The values of the variables `default-toolbar', `top-toolbar',
211 `left-toolbar', `right-toolbar', and `bottom-toolbar' are always
214 Valid toolbar instantiators are called \"toolbar descriptors\"
215 and are lists of vectors. See `default-toolbar' for a description
216 of the exact format."
217 (make-specifier-and-init 'toolbar spec-list))
219 ;;; toolbar.el ends here