|
428
|
1 ;;; toolbar.el --- Toolbar support for XEmacs
|
|
|
2
|
|
|
3 ;; Copyright (C) 1995, 1997 Free Software Foundation, Inc.
|
|
771
|
4 ;; Copyright (C) 2002 Ben Wing.
|
|
428
|
5
|
|
|
6 ;; Maintainer: XEmacs Development Team
|
|
|
7 ;; Keywords: extensions, internal, dumped
|
|
|
8
|
|
|
9 ;; This file is part of XEmacs.
|
|
|
10
|
|
|
11 ;; XEmacs is free software; you can redistribute it and/or modify it
|
|
|
12 ;; under the terms of the GNU General Public License as published by
|
|
|
13 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
14 ;; any later version.
|
|
|
15
|
|
|
16 ;; XEmacs is distributed in the hope that it will be useful, but
|
|
|
17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
|
19 ;; General Public License for more details.
|
|
|
20
|
|
|
21 ;; You should have received a copy of the GNU General Public License
|
|
|
22 ;; along with XEmacs; see the file COPYING. If not, write to the
|
|
|
23 ;; Free Software Foundation, 59 Temple Place - Suite 330,
|
|
|
24 ;; Boston, MA 02111-1307, USA.
|
|
|
25
|
|
|
26 ;;; Synched up with: Not in FSF.
|
|
|
27
|
|
|
28 ;;; Commentary:
|
|
|
29
|
|
|
30 ;; This file is dumped with XEmacs (when toolbar support is compiled in).
|
|
|
31
|
|
|
32 ;;; Code:
|
|
|
33
|
|
|
34 (defcustom toolbar-visible-p ;; added for the options menu - dverna apr. 98
|
|
|
35 (specifier-instance default-toolbar-visible-p)
|
|
763
|
36 "*Whether the default toolbar is globally visible.
|
|
771
|
37 This option only has an effect when set using `customize-set-variable',
|
|
|
38 or through the Options menu."
|
|
428
|
39 :group 'display
|
|
|
40 :type 'boolean
|
|
|
41 :set #'(lambda (var val)
|
|
|
42 (set-specifier default-toolbar-visible-p val)
|
|
|
43 (setq toolbar-visible-p val))
|
|
|
44 )
|
|
|
45
|
|
|
46 (defcustom toolbar-captioned-p ;; added for the options menu - dverna apr. 98
|
|
|
47 (specifier-instance toolbar-buttons-captioned-p)
|
|
763
|
48 "*Whether the toolbars buttons are globally captioned.
|
|
771
|
49 This option only has an effect when set using `customize-set-variable',
|
|
|
50 or through the Options menu."
|
|
428
|
51 :group 'display
|
|
|
52 :type 'boolean
|
|
|
53 :set #'(lambda (var val)
|
|
|
54 (set-specifier toolbar-buttons-captioned-p val)
|
|
|
55 (setq toolbar-captioned-p val))
|
|
|
56 )
|
|
|
57
|
|
|
58 (defcustom default-toolbar-position ;; added for the options menu - dverna
|
|
|
59 (default-toolbar-position)
|
|
771
|
60 "*The location of the default toolbar: 'top, 'bottom, 'left or 'right.
|
|
|
61 This option only has an effect when set using `customize-set-variable',
|
|
|
62 or through the Options menu."
|
|
428
|
63 :group 'display
|
|
442
|
64 :type '(choice (const :tag "top" top)
|
|
|
65 (const :tag "bottom" bottom)
|
|
|
66 (const :tag "left" left)
|
|
|
67 (const :tag "right" right))
|
|
428
|
68 :set #'(lambda (var val)
|
|
763
|
69 (let* ((height (window-height))
|
|
|
70 (hdiff (- (frame-height) height))
|
|
|
71 (width (window-width)))
|
|
|
72 (set-default-toolbar-position val)
|
|
|
73 (setq default-toolbar-position val)
|
|
|
74 ;; needed or dimensions don't update?
|
|
|
75 (redisplay-frame)
|
|
|
76 ;; This probably only works correctly if there is only one
|
|
|
77 ;; Emacs window. If windows are split, it probably results in
|
|
|
78 ;; small adjustments in their sizes.
|
|
|
79 (set-frame-size (selected-frame) width (+ height hdiff))
|
|
767
|
80 )))
|
|
428
|
81
|
|
|
82 (defvar toolbar-help-enabled t
|
|
|
83 "If non-nil help is echoed for toolbar buttons.")
|
|
|
84
|
|
|
85 (defvar toolbar-icon-directory nil
|
|
|
86 "Location of standard toolbar icon bitmaps.")
|
|
|
87
|
|
|
88 (defun toolbar-make-button-list (up &optional down disabled cap-up cap-down cap-disabled)
|
|
|
89 "Call make-glyph on each arg and return a list of the results."
|
|
|
90 (let ((up-glyph (make-glyph up))
|
|
|
91 (down-glyph (and down (make-glyph down)))
|
|
|
92 (disabled-glyph (and disabled (make-glyph disabled)))
|
|
|
93 (cap-up-glyph (and cap-up (make-glyph cap-up)))
|
|
|
94 (cap-down-glyph (and cap-down (make-glyph cap-down)))
|
|
|
95 (cap-disabled-glyph (and cap-disabled (make-glyph cap-disabled))))
|
|
|
96 (if cap-disabled
|
|
|
97 (list up-glyph down-glyph disabled-glyph
|
|
|
98 cap-up-glyph cap-down-glyph cap-disabled-glyph)
|
|
|
99 (if cap-down
|
|
|
100 (list up-glyph down-glyph disabled-glyph
|
|
|
101 cap-up-glyph cap-down-glyph)
|
|
|
102 (if cap-up
|
|
|
103 (list up-glyph down-glyph disabled-glyph cap-up-glyph)
|
|
|
104 (if disabled-glyph
|
|
|
105 (list up-glyph down-glyph disabled-glyph)
|
|
|
106 (if down-glyph
|
|
|
107 (list up-glyph down-glyph)
|
|
|
108 (list up-glyph))))))))
|
|
|
109
|
|
|
110 (defun init-toolbar-location ()
|
|
|
111 (if (not toolbar-icon-directory)
|
|
|
112 (let ((name (locate-data-directory "toolbar")))
|
|
|
113 (if name
|
|
|
114 (setq toolbar-icon-directory
|
|
|
115 (file-name-as-directory name))))))
|
|
|
116
|
|
487
|
117 ;; called from toolbar.c during device and frame initialization
|
|
428
|
118 (defun init-toolbar-from-resources (locale)
|
|
|
119 (if (and (featurep 'x)
|
|
|
120 (or (eq locale 'global)
|
|
|
121 (eq 'x (device-or-frame-type locale))))
|
|
502
|
122 (declare-fboundp (x-init-toolbar-from-resources locale))))
|
|
428
|
123
|
|
|
124
|
|
|
125 ;; #### Is this actually needed or will the code in
|
|
|
126 ;; default-mouse-motion-handler suffice?
|
|
|
127 (define-key global-map 'button1up 'release-toolbar-button)
|
|
|
128
|
|
|
129 (defvar toolbar-map (let ((m (make-sparse-keymap)))
|
|
|
130 (set-keymap-name m 'toolbar-map)
|
|
|
131 m)
|
|
|
132 "Keymap consulted for mouse-clicks over a toolbar.")
|
|
|
133
|
|
|
134 (define-key toolbar-map 'button1 'press-toolbar-button)
|
|
|
135 (define-key toolbar-map 'button1up 'release-and-activate-toolbar-button)
|
|
|
136 (defvar last-pressed-toolbar-button nil)
|
|
|
137 (defvar toolbar-active nil)
|
|
|
138
|
|
442
|
139 (defvar toolbar-blank-press-function nil
|
|
|
140 "Function to call if a blank area of the toolbar is pressed.")
|
|
|
141
|
|
428
|
142 ;;
|
|
|
143 ;; It really sucks that we also have to tie onto
|
|
|
144 ;; default-mouse-motion-handler to make sliding buttons work right.
|
|
|
145 ;;
|
|
|
146 (defun press-toolbar-button (event)
|
|
|
147 "Press a toolbar button. This only changes its appearance.
|
|
3061
|
148 Call function stored in `toolbar-blank-press-function', if any, with EVENT as
|
|
428
|
149 an argument if press is over a blank area of the toolbar."
|
|
|
150 (interactive "_e")
|
|
|
151 (setq this-command last-command)
|
|
|
152 (let ((button (event-toolbar-button event)))
|
|
|
153 ;; We silently ignore non-buttons. This most likely means we are
|
|
|
154 ;; over a blank part of the toolbar.
|
|
|
155 (setq toolbar-active t)
|
|
|
156 (if (toolbar-button-p button)
|
|
|
157 (progn
|
|
|
158 (set-toolbar-button-down-flag button t)
|
|
|
159 (setq last-pressed-toolbar-button button))
|
|
|
160 ;; Added by Bob Weiner, Motorola Inc., 10/6/95, to handle
|
|
|
161 ;; presses on blank portions of toolbars.
|
|
442
|
162 (when (functionp toolbar-blank-press-function)
|
|
|
163 (funcall toolbar-blank-press-function event)))))
|
|
428
|
164
|
|
|
165 (defun release-and-activate-toolbar-button (event)
|
|
|
166 "Release a toolbar button and activate its callback.
|
|
3061
|
167 Call function stored in `toolbar-blank-release-function', if any, with EVENT
|
|
428
|
168 as an argument if release is over a blank area of the toolbar."
|
|
|
169 (interactive "_e")
|
|
|
170 (or (button-release-event-p event)
|
|
|
171 (error "%s must be invoked by a mouse-release" this-command))
|
|
|
172 (release-toolbar-button event)
|
|
|
173 (let ((button (event-toolbar-button event)))
|
|
|
174 (if (and (toolbar-button-p button)
|
|
|
175 (toolbar-button-enabled-p button)
|
|
|
176 (toolbar-button-callback button))
|
|
|
177 (let ((callback (toolbar-button-callback button)))
|
|
|
178 (setq this-command callback)
|
|
|
179 ;; Handle arbitrary functions.
|
|
|
180 (if (functionp callback)
|
|
|
181 (if (commandp callback)
|
|
|
182 (call-interactively callback)
|
|
|
183 (funcall callback))
|
|
|
184 (eval callback))))))
|
|
|
185
|
|
|
186 ;; If current is not t, then only release the toolbar button stored in
|
|
|
187 ;; last-pressed-toolbar-button
|
|
|
188 (defun release-toolbar-button-internal (event current)
|
|
|
189 (let ((button (event-toolbar-button event)))
|
|
|
190 (setq zmacs-region-stays t)
|
|
|
191 (if (and last-pressed-toolbar-button
|
|
|
192 (not (eq last-pressed-toolbar-button button))
|
|
|
193 (toolbar-button-p last-pressed-toolbar-button))
|
|
|
194 (progn
|
|
|
195 (set-toolbar-button-down-flag last-pressed-toolbar-button nil)
|
|
|
196 (setq last-pressed-toolbar-button nil)))
|
|
|
197 (if (and current (toolbar-button-p button))
|
|
|
198 (set-toolbar-button-down-flag button nil))))
|
|
|
199
|
|
|
200 (defun release-toolbar-button (event)
|
|
|
201 "Release all pressed toolbar buttons."
|
|
|
202 (interactive "_e")
|
|
|
203 (or (button-release-event-p event)
|
|
|
204 (error "%s must be invoked by a mouse-release" this-command))
|
|
|
205 (release-toolbar-button-internal event t)
|
|
|
206 ;; Don't set this-command if we're being called
|
|
|
207 ;; from release-and-activate-toolbar-button.
|
|
|
208 (if (interactive-p)
|
|
|
209 (setq this-command last-command))
|
|
|
210 (setq toolbar-active nil))
|
|
|
211
|
|
|
212 (defun release-previous-toolbar-button (event)
|
|
|
213 (setq zmacs-region-stays t)
|
|
|
214 (release-toolbar-button-internal event nil))
|
|
|
215
|
|
442
|
216 (defun make-toolbar-specifier (spec-list)
|
|
|
217 "Return a new `toolbar' specifier object with the given specification list.
|
|
|
218 SPEC-LIST can be a list of specifications (each of which is a cons of a
|
|
|
219 locale and a list of instantiators), a single instantiator, or a list
|
|
|
220 of instantiators. See `make-specifier' for more information about
|
|
|
221 specifiers.
|
|
|
222
|
|
|
223 Toolbar specifiers are used to specify the format of a toolbar.
|
|
|
224 The values of the variables `default-toolbar', `top-toolbar',
|
|
|
225 `left-toolbar', `right-toolbar', and `bottom-toolbar' are always
|
|
|
226 toolbar specifiers.
|
|
|
227
|
|
|
228 Valid toolbar instantiators are called \"toolbar descriptors\"
|
|
|
229 and are lists of vectors. See `default-toolbar' for a description
|
|
|
230 of the exact format."
|
|
|
231 (make-specifier-and-init 'toolbar spec-list))
|
|
|
232
|
|
428
|
233 ;;; toolbar.el ends here
|
