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