Mercurial > hg > xemacs-beta

comparison lisp/toolbar.el @ 209:41ff10fd062f r20-4b3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-4b3
author cvs
date Mon, 13 Aug 2007 10:04:58 +0200
parents
children d44af0c54775
comparison
equal deleted inserted replaced
208:f427b8ec4379 209:41ff10fd062f
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 (defvar toolbar-help-enabled t
34 "If non-nil help is echoed for toolbar buttons.")
35
36 (defvar toolbar-icon-directory nil
37 "Location of standard toolbar icon bitmaps.")
38
39 (defun toolbar-make-button-list (up &optional down disabled cap-up cap-down cap-disabled)
40 "Calls make-glyph on each arg and returns a list of the results."
41 (if (featurep 'x)
42 (let ((up-glyph (make-glyph up))
43 (down-glyph (and down (make-glyph down)))
44 (disabled-glyph (and disabled (make-glyph disabled)))
45 (cap-up-glyph (and cap-up (make-glyph cap-up)))
46 (cap-down-glyph (and cap-down (make-glyph cap-down)))
47 (cap-disabled-glyph (and cap-disabled (make-glyph cap-disabled))))
48 (if cap-disabled
49 (list up-glyph down-glyph disabled-glyph
50 cap-up-glyph cap-down-glyph cap-disabled-glyph)
51 (if cap-down
52 (list up-glyph down-glyph disabled-glyph
53 cap-up-glyph cap-down-glyph)
54 (if cap-up
55 (list up-glyph down-glyph disabled-glyph cap-up-glyph)
56 (if disabled-glyph
57 (list up-glyph down-glyph disabled-glyph)
58 (if down-glyph
59 (list up-glyph down-glyph)
60 (list up-glyph)))))))
61 nil))
62
63 (defun init-toolbar-location ()
64 (if (not toolbar-icon-directory)
65 (setq toolbar-icon-directory
66 (file-name-as-directory
67 (locate-data-directory "toolbar")))))
68
69 (defun init-toolbar-from-resources (locale)
70 (if (and (featurep 'x)
71 (or (eq locale 'global)
72 (eq 'x (device-or-frame-type locale)))
73 (x-init-toolbar-from-resources locale))))
74
75
76 ;; #### Is this actually needed or will the code in
77 ;; default-mouse-motion-handler suffice?
78 (define-key global-map 'button1up 'release-toolbar-button)
79
80 (defvar toolbar-map (let ((m (make-sparse-keymap)))
81 (set-keymap-name m 'toolbar-map)
82 m)
83 "Keymap consulted for mouse-clicks over a toolbar.")
84
85 (define-key toolbar-map 'button1 'press-toolbar-button)
86 (define-key toolbar-map 'button1up 'release-and-activate-toolbar-button)
87 (defvar last-pressed-toolbar-button nil)
88 (defvar toolbar-active nil)
89
90 ;;
91 ;; It really sucks that we also have to tie onto
92 ;; default-mouse-motion-handler to make sliding buttons work right.
93 ;;
94 (defun press-toolbar-button (event)
95 "Press a toolbar button. This only changes its appearance.
96 Call function stored in `toolbar-blank-press-function,' if any, with EVENT as
97 an argument if press is over a blank area of the toolbar."
98 (interactive "_e")
99 (setq this-command last-command)
100 (let ((button (event-toolbar-button event)))
101 ;; We silently ignore non-buttons. This most likely means we are
102 ;; over a blank part of the toolbar.
103 (setq toolbar-active t)
104 (if (toolbar-button-p button)
105 (progn
106 (set-toolbar-button-down-flag button t)
107 (setq last-pressed-toolbar-button button))
108 ;; Added by Bob Weiner, Motorola Inc., 10/6/95, to handle
109 ;; presses on blank portions of toolbars.
110 (and (boundp 'toolbar-blank-press-function)
111 (functionp toolbar-blank-press-function)
112 (funcall toolbar-blank-press-function event)))))
113
114 (defun release-and-activate-toolbar-button (event)
115 "Release a toolbar button and activate its callback.
116 Call function stored in `toolbar-blank-release-function,' if any, with EVENT
117 as an argument if release is over a blank area of the toolbar."
118 (interactive "_e")
119 (or (button-release-event-p event)
120 (error "%s must be invoked by a mouse-release" this-command))
121 (release-toolbar-button event)
122 (let ((button (event-toolbar-button event)))
123 (if (and (toolbar-button-p button)
124 (toolbar-button-enabled-p button)
125 (toolbar-button-callback button))
126 (let ((callback (toolbar-button-callback button)))
127 (setq this-command callback)
128 ;; Handle arbitrary functions.
129 (if (functionp callback)
130 (if (commandp callback)
131 (call-interactively callback)
132 (funcall callback))
133 (eval callback))))))
134
135 ;; If current is not t, then only release the toolbar button stored in
136 ;; last-pressed-toolbar-button
137 (defun release-toolbar-button-internal (event current)
138 (let ((button (event-toolbar-button event)))
139 (setq zmacs-region-stays t)
140 (if (and last-pressed-toolbar-button
141 (not (eq last-pressed-toolbar-button button))
142 (toolbar-button-p last-pressed-toolbar-button))
143 (progn
144 (set-toolbar-button-down-flag last-pressed-toolbar-button nil)
145 (setq last-pressed-toolbar-button nil)))
146 (if (and current (toolbar-button-p button))
147 (set-toolbar-button-down-flag button nil))))
148
149 (defun release-toolbar-button (event)
150 "Release all pressed toolbar buttons."
151 (interactive "_e")
152 (or (button-release-event-p event)
153 (error "%s must be invoked by a mouse-release" this-command))
154 (release-toolbar-button-internal event t)
155 ;; Don't set this-command if we're being called
156 ;; from release-and-activate-toolbar-button.
157 (if (interactive-p)
158 (setq this-command last-command))
159 (setq toolbar-active nil))
160
161 (defun release-previous-toolbar-button (event)
162 (setq zmacs-region-stays t)
163 (release-toolbar-button-internal event nil))
164
165 ;;; toolbar.el ends here