Mercurial > hg > xemacs-beta

comparison lisp/toolbar.el @ 428:3ecd8885ac67 r21-2-22

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-22
author cvs
date Mon, 13 Aug 2007 11:28:15 +0200
parents
children abe6d1db359e
comparison
equal deleted inserted replaced
427:0a0253eac470 428:3ecd8885ac67
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. This option can be
36 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. This option can be
47 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. It can be 'top, 'bottom, 'left or
58 'right. This option can be customized through the options menu."
59 :group 'display
60 :type '(choice (const :tag "top" 'top)
61 (const :tag "bottom" 'bottom)
62 (const :tag "left" 'left)
63 (const :tag "right" 'right))
64 :set #'(lambda (var val)
65 (set-default-toolbar-position val)
66 (setq default-toolbar-position val))
67 )
68
69 (defvar toolbar-help-enabled t
70 "If non-nil help is echoed for toolbar buttons.")
71
72 (defvar toolbar-icon-directory nil
73 "Location of standard toolbar icon bitmaps.")
74
75 (defun toolbar-make-button-list (up &optional down disabled cap-up cap-down cap-disabled)
76 "Call make-glyph on each arg and return a list of the results."
77 (let ((up-glyph (make-glyph up))
78 (down-glyph (and down (make-glyph down)))
79 (disabled-glyph (and disabled (make-glyph disabled)))
80 (cap-up-glyph (and cap-up (make-glyph cap-up)))
81 (cap-down-glyph (and cap-down (make-glyph cap-down)))
82 (cap-disabled-glyph (and cap-disabled (make-glyph cap-disabled))))
83 (if cap-disabled
84 (list up-glyph down-glyph disabled-glyph
85 cap-up-glyph cap-down-glyph cap-disabled-glyph)
86 (if cap-down
87 (list up-glyph down-glyph disabled-glyph
88 cap-up-glyph cap-down-glyph)
89 (if cap-up
90 (list up-glyph down-glyph disabled-glyph cap-up-glyph)
91 (if disabled-glyph
92 (list up-glyph down-glyph disabled-glyph)
93 (if down-glyph
94 (list up-glyph down-glyph)
95 (list up-glyph))))))))
96
97 (defun init-toolbar-location ()
98 (if (not toolbar-icon-directory)
99 (let ((name (locate-data-directory "toolbar")))
100 (if name
101 (setq toolbar-icon-directory
102 (file-name-as-directory name))))))
103
104 (defun init-toolbar-from-resources (locale)
105 (if (and (featurep 'x)
106 (not (featurep 'infodock))
107 (or (eq locale 'global)
108 (eq 'x (device-or-frame-type locale))))
109 (x-init-toolbar-from-resources locale)))
110
111
112 ;; #### Is this actually needed or will the code in
113 ;; default-mouse-motion-handler suffice?
114 (define-key global-map 'button1up 'release-toolbar-button)
115
116 (defvar toolbar-map (let ((m (make-sparse-keymap)))
117 (set-keymap-name m 'toolbar-map)
118 m)
119 "Keymap consulted for mouse-clicks over a toolbar.")
120
121 (define-key toolbar-map 'button1 'press-toolbar-button)
122 (define-key toolbar-map 'button1up 'release-and-activate-toolbar-button)
123 (defvar last-pressed-toolbar-button nil)
124 (defvar toolbar-active nil)
125
126 ;;
127 ;; It really sucks that we also have to tie onto
128 ;; default-mouse-motion-handler to make sliding buttons work right.
129 ;;
130 (defun press-toolbar-button (event)
131 "Press a toolbar button. This only changes its appearance.
132 Call function stored in `toolbar-blank-press-function,' if any, with EVENT as
133 an argument if press is over a blank area of the toolbar."
134 (interactive "_e")
135 (setq this-command last-command)
136 (let ((button (event-toolbar-button event)))
137 ;; We silently ignore non-buttons. This most likely means we are
138 ;; over a blank part of the toolbar.
139 (setq toolbar-active t)
140 (if (toolbar-button-p button)
141 (progn
142 (set-toolbar-button-down-flag button t)
143 (setq last-pressed-toolbar-button button))
144 ;; Added by Bob Weiner, Motorola Inc., 10/6/95, to handle
145 ;; presses on blank portions of toolbars.
146 (and (boundp 'toolbar-blank-press-function)
147 (functionp toolbar-blank-press-function)
148 (funcall toolbar-blank-press-function event)))))
149
150 (defun release-and-activate-toolbar-button (event)
151 "Release a toolbar button and activate its callback.
152 Call function stored in `toolbar-blank-release-function,' if any, with EVENT
153 as an argument if release is over a blank area of the toolbar."
154 (interactive "_e")
155 (or (button-release-event-p event)
156 (error "%s must be invoked by a mouse-release" this-command))
157 (release-toolbar-button event)
158 (let ((button (event-toolbar-button event)))
159 (if (and (toolbar-button-p button)
160 (toolbar-button-enabled-p button)
161 (toolbar-button-callback button))
162 (let ((callback (toolbar-button-callback button)))
163 (setq this-command callback)
164 ;; Handle arbitrary functions.
165 (if (functionp callback)
166 (if (commandp callback)
167 (call-interactively callback)
168 (funcall callback))
169 (eval callback))))))
170
171 ;; If current is not t, then only release the toolbar button stored in
172 ;; last-pressed-toolbar-button
173 (defun release-toolbar-button-internal (event current)
174 (let ((button (event-toolbar-button event)))
175 (setq zmacs-region-stays t)
176 (if (and last-pressed-toolbar-button
177 (not (eq last-pressed-toolbar-button button))
178 (toolbar-button-p last-pressed-toolbar-button))
179 (progn
180 (set-toolbar-button-down-flag last-pressed-toolbar-button nil)
181 (setq last-pressed-toolbar-button nil)))
182 (if (and current (toolbar-button-p button))
183 (set-toolbar-button-down-flag button nil))))
184
185 (defun release-toolbar-button (event)
186 "Release all pressed toolbar buttons."
187 (interactive "_e")
188 (or (button-release-event-p event)
189 (error "%s must be invoked by a mouse-release" this-command))
190 (release-toolbar-button-internal event t)
191 ;; Don't set this-command if we're being called
192 ;; from release-and-activate-toolbar-button.
193 (if (interactive-p)
194 (setq this-command last-command))
195 (setq toolbar-active nil))
196
197 (defun release-previous-toolbar-button (event)
198 (setq zmacs-region-stays t)
199 (release-toolbar-button-internal event nil))
200
201 ;;; toolbar.el ends here