|
0
|
1 ;; Toolbar support.
|
|
|
2 ;; Copyright (C) 1995 Board of Trustees, University of Illinois
|
|
|
3
|
|
|
4 ;; This file is part of XEmacs.
|
|
|
5
|
|
|
6 ;; XEmacs is free software; you can redistribute it and/or modify it
|
|
|
7 ;; under the terms of the GNU General Public License as published by
|
|
|
8 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
9 ;; any later version.
|
|
|
10
|
|
|
11 ;; XEmacs is distributed in the hope that it will be useful, but
|
|
|
12 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
|
14 ;; General Public License for more details.
|
|
|
15
|
|
|
16 ;; You should have received a copy of the GNU General Public License
|
|
16
|
17 ;; along with XEmacs; see the file COPYING. If not, write to the
|
|
70
|
18 ;; Free Software Foundation, 59 Temple Place - Suite 330,
|
|
16
|
19 ;; Boston, MA 02111-1307, USA.
|
|
0
|
20
|
|
|
21 ;;; Synched up with: Not in FSF.
|
|
|
22
|
|
|
23 (defvar toolbar-help-enabled t
|
|
|
24 "If non-nil help is echoed for toolbar buttons.")
|
|
|
25
|
|
|
26 (defvar toolbar-icon-directory nil
|
|
|
27 "Location of standard toolbar icon bitmaps.")
|
|
|
28
|
|
|
29 (defun toolbar-make-button-list (up &optional down disabled cap-up cap-down cap-disabled)
|
|
|
30 "Calls make-glyph on each arg and returns a list of the results."
|
|
|
31 (if (featurep 'x)
|
|
|
32 (let ((up-glyph (make-glyph up))
|
|
|
33 (down-glyph (and down (make-glyph down)))
|
|
|
34 (disabled-glyph (and disabled (make-glyph disabled)))
|
|
|
35 (cap-up-glyph (and cap-up (make-glyph cap-up)))
|
|
|
36 (cap-down-glyph (and cap-down (make-glyph cap-down)))
|
|
|
37 (cap-disabled-glyph (and cap-disabled (make-glyph cap-disabled))))
|
|
|
38 (if cap-disabled
|
|
|
39 (list up-glyph down-glyph disabled-glyph
|
|
|
40 cap-up-glyph cap-down-glyph cap-disabled-glyph)
|
|
|
41 (if cap-down
|
|
|
42 (list up-glyph down-glyph disabled-glyph
|
|
|
43 cap-up-glyph cap-down-glyph)
|
|
|
44 (if cap-up
|
|
|
45 (list up-glyph down-glyph disabled-glyph cap-up-glyph)
|
|
|
46 (if disabled-glyph
|
|
|
47 (list up-glyph down-glyph disabled-glyph)
|
|
|
48 (if down-glyph
|
|
|
49 (list up-glyph down-glyph)
|
|
|
50 (list up-glyph)))))))
|
|
|
51 nil))
|
|
|
52
|
|
|
53 (defun init-toolbar-location ()
|
|
|
54 (if (not toolbar-icon-directory)
|
|
|
55 (setq toolbar-icon-directory
|
|
|
56 (file-name-as-directory
|
|
|
57 (expand-file-name "toolbar" data-directory)))))
|
|
|
58
|
|
|
59 (defun init-toolbar-from-resources (locale)
|
|
|
60 (if (and (featurep 'x)
|
|
|
61 (or (eq locale 'global)
|
|
|
62 (eq 'x (device-or-frame-type locale)))
|
|
|
63 (x-init-toolbar-from-resources locale))))
|
|
|
64
|
|
|
65
|
|
|
66 ;; #### Is this actually needed or will the code in
|
|
|
67 ;; default-mouse-motion-handler suffice?
|
|
|
68 (define-key global-map 'button1up 'release-toolbar-button)
|
|
|
69
|
|
|
70 (defvar toolbar-map (let ((m (make-sparse-keymap)))
|
|
|
71 (set-keymap-name m 'toolbar-map)
|
|
|
72 m)
|
|
|
73 "Keymap consulted for mouse-clicks over a toolbar.")
|
|
|
74
|
|
|
75 (define-key toolbar-map 'button1 'press-toolbar-button)
|
|
|
76 (define-key toolbar-map 'button1up 'release-and-activate-toolbar-button)
|
|
|
77 (defvar last-pressed-toolbar-button nil)
|
|
|
78 (defvar toolbar-active nil)
|
|
|
79
|
|
|
80 ;;
|
|
|
81 ;; It really sucks that we also have to tie onto
|
|
|
82 ;; default-mouse-motion-handler to make sliding buttons work right.
|
|
|
83 ;;
|
|
|
84 (defun press-toolbar-button (event)
|
|
|
85 "Press a toolbar button. This only changes its appearance."
|
|
|
86 (interactive "_e")
|
|
|
87 (setq this-command last-command)
|
|
|
88 (let ((button (event-toolbar-button event)))
|
|
|
89 ;; We silently ignore non-buttons. This most likely means we are
|
|
|
90 ;; over a blank part of the toolbar.
|
|
|
91 (setq toolbar-active t)
|
|
|
92 (if (toolbar-button-p button)
|
|
|
93 (progn
|
|
|
94 (set-toolbar-button-down-flag button t)
|
|
|
95 (setq last-pressed-toolbar-button button)))))
|
|
|
96
|
|
|
97 (defun release-and-activate-toolbar-button (event)
|
|
|
98 "Release a toolbar button and activate its callback."
|
|
|
99 (interactive "_e")
|
|
|
100 (or (button-release-event-p event)
|
|
|
101 (error "%s must be invoked by a mouse-release" this-command))
|
|
|
102 (release-toolbar-button event)
|
|
|
103 (let ((button (event-toolbar-button event)))
|
|
|
104 (if (and (toolbar-button-p button)
|
|
|
105 (toolbar-button-enabled-p button)
|
|
|
106 (toolbar-button-callback button))
|
|
|
107 (let ((callback (toolbar-button-callback button)))
|
|
|
108 (setq this-command callback)
|
|
|
109 (if (symbolp callback)
|
|
|
110 (call-interactively callback)
|
|
|
111 (eval callback))))))
|
|
|
112
|
|
|
113 ;; If current is not t, then only release the toolbar button stored in
|
|
|
114 ;; last-pressed-toolbar-button
|
|
|
115 (defun release-toolbar-button-internal (event current)
|
|
|
116 (let ((button (event-toolbar-button event)))
|
|
|
117 (setq zmacs-region-stays t)
|
|
|
118 (if (and last-pressed-toolbar-button
|
|
|
119 (not (eq last-pressed-toolbar-button button))
|
|
|
120 (toolbar-button-p last-pressed-toolbar-button))
|
|
|
121 (progn
|
|
|
122 (set-toolbar-button-down-flag last-pressed-toolbar-button nil)
|
|
|
123 (setq last-pressed-toolbar-button nil)))
|
|
|
124 (if (and current (toolbar-button-p button))
|
|
|
125 (set-toolbar-button-down-flag button nil))))
|
|
|
126
|
|
|
127 (defun release-toolbar-button (event)
|
|
|
128 "Release all pressed toolbar buttons."
|
|
|
129 (interactive "_e")
|
|
|
130 (or (button-release-event-p event)
|
|
|
131 (error "%s must be invoked by a mouse-release" this-command))
|
|
|
132 (release-toolbar-button-internal event t)
|
|
|
133 ;; Don't set this-command if we're being called
|
|
|
134 ;; from release-and-activate-toolbar-button.
|
|
|
135 (if (interactive-p)
|
|
|
136 (setq this-command last-command))
|
|
|
137 (setq toolbar-active nil))
|
|
|
138
|
|
|
139 (defun release-previous-toolbar-button (event)
|
|
|
140 (setq zmacs-region-stays t)
|
|
|
141 (release-toolbar-button-internal event nil))
|
|
|
142
|
