428
+ − 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
442
+ − 60 :type '(choice (const :tag "top" top)
+ − 61 (const :tag "bottom" bottom)
+ − 62 (const :tag "left" left)
+ − 63 (const :tag "right" right))
428
+ − 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
487
+ − 104 ;; called from toolbar.c during device and frame initialization
428
+ − 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
+ − 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
442
+ − 127 (defvar toolbar-blank-press-function nil
+ − 128 "Function to call if a blank area of the toolbar is pressed.")
+ − 129
428
+ − 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.
442
+ − 150 (when (functionp toolbar-blank-press-function)
+ − 151 (funcall toolbar-blank-press-function event)))))
428
+ − 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
442
+ − 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
428
+ − 221 ;;; toolbar.el ends here
