Mercurial > hg > xemacs-beta

comparison lisp/prim/toolbar.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children 0293115a14e9
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
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
17 ;; along with XEmacs; see the file COPYING. If not, write to the Free
18 ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
19
20 ;;; Synched up with: Not in FSF.
21
22 (defvar toolbar-help-enabled t
23 "If non-nil help is echoed for toolbar buttons.")
24
25 (defvar toolbar-icon-directory nil
26 "Location of standard toolbar icon bitmaps.")
27
28 (defun toolbar-make-button-list (up &optional down disabled cap-up cap-down cap-disabled)
29 "Calls make-glyph on each arg and returns a list of the results."
30 (if (featurep 'x)
31 (let ((up-glyph (make-glyph up))
32 (down-glyph (and down (make-glyph down)))
33 (disabled-glyph (and disabled (make-glyph disabled)))
34 (cap-up-glyph (and cap-up (make-glyph cap-up)))
35 (cap-down-glyph (and cap-down (make-glyph cap-down)))
36 (cap-disabled-glyph (and cap-disabled (make-glyph cap-disabled))))
37 (if cap-disabled
38 (list up-glyph down-glyph disabled-glyph
39 cap-up-glyph cap-down-glyph cap-disabled-glyph)
40 (if cap-down
41 (list up-glyph down-glyph disabled-glyph
42 cap-up-glyph cap-down-glyph)
43 (if cap-up
44 (list up-glyph down-glyph disabled-glyph cap-up-glyph)
45 (if disabled-glyph
46 (list up-glyph down-glyph disabled-glyph)
47 (if down-glyph
48 (list up-glyph down-glyph)
49 (list up-glyph)))))))
50 nil))
51
52 (defun init-toolbar-location ()
53 (if (not toolbar-icon-directory)
54 (setq toolbar-icon-directory
55 (file-name-as-directory
56 (expand-file-name "toolbar" data-directory)))))
57
58 (defun init-toolbar-from-resources (locale)
59 (if (and (featurep 'x)
60 (or (eq locale 'global)
61 (eq 'x (device-or-frame-type locale)))
62 (x-init-toolbar-from-resources locale))))
63
64
65 ;; #### Is this actually needed or will the code in
66 ;; default-mouse-motion-handler suffice?
67 (define-key global-map 'button1up 'release-toolbar-button)
68
69 (defvar toolbar-map (let ((m (make-sparse-keymap)))
70 (set-keymap-name m 'toolbar-map)
71 m)
72 "Keymap consulted for mouse-clicks over a toolbar.")
73
74 (define-key toolbar-map 'button1 'press-toolbar-button)
75 (define-key toolbar-map 'button1up 'release-and-activate-toolbar-button)
76 (defvar last-pressed-toolbar-button nil)
77 (defvar toolbar-active nil)
78
79 ;;
80 ;; It really sucks that we also have to tie onto
81 ;; default-mouse-motion-handler to make sliding buttons work right.
82 ;;
83 (defun press-toolbar-button (event)
84 "Press a toolbar button. This only changes its appearance."
85 (interactive "_e")
86 (setq this-command last-command)
87 (let ((button (event-toolbar-button event)))
88 ;; We silently ignore non-buttons. This most likely means we are
89 ;; over a blank part of the toolbar.
90 (setq toolbar-active t)
91 (if (toolbar-button-p button)
92 (progn
93 (set-toolbar-button-down-flag button t)
94 (setq last-pressed-toolbar-button button)))))
95
96 (defun release-and-activate-toolbar-button (event)
97 "Release a toolbar button and activate its callback."
98 (interactive "_e")
99 (or (button-release-event-p event)
100 (error "%s must be invoked by a mouse-release" this-command))
101 (release-toolbar-button event)
102 (let ((button (event-toolbar-button event)))
103 (if (and (toolbar-button-p button)
104 (toolbar-button-enabled-p button)
105 (toolbar-button-callback button))
106 (let ((callback (toolbar-button-callback button)))
107 (setq this-command callback)
108 (if (symbolp callback)
109 (call-interactively callback)
110 (eval callback))))))
111
112 ;; If current is not t, then only release the toolbar button stored in
113 ;; last-pressed-toolbar-button
114 (defun release-toolbar-button-internal (event current)
115 (let ((button (event-toolbar-button event)))
116 (setq zmacs-region-stays t)
117 (if (and last-pressed-toolbar-button
118 (not (eq last-pressed-toolbar-button button))
119 (toolbar-button-p last-pressed-toolbar-button))
120 (progn
121 (set-toolbar-button-down-flag last-pressed-toolbar-button nil)
122 (setq last-pressed-toolbar-button nil)))
123 (if (and current (toolbar-button-p button))
124 (set-toolbar-button-down-flag button nil))))
125
126 (defun release-toolbar-button (event)
127 "Release all pressed toolbar buttons."
128 (interactive "_e")
129 (or (button-release-event-p event)
130 (error "%s must be invoked by a mouse-release" this-command))
131 (release-toolbar-button-internal event t)
132 ;; Don't set this-command if we're being called
133 ;; from release-and-activate-toolbar-button.
134 (if (interactive-p)
135 (setq this-command last-command))
136 (setq toolbar-active nil))
137
138 (defun release-previous-toolbar-button (event)
139 (setq zmacs-region-stays t)
140 (release-toolbar-button-internal event nil))
141