cgit.sxemacs.org Git - sxemacs/blob - lisp/toolbar.el

   1 ;;; toolbar.el --- Toolbar support for SXEmacs
   2
   3 ;; Copyright (C) 1995, 1997 Free Software Foundation, Inc.
   4
   5 ;; Maintainer: SXEmacs Development Team
   6 ;; Keywords: extensions, internal, dumped
   7
   8 ;; This file is part of SXEmacs.
   9
  10 ;; SXEmacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; SXEmacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Synched up with: Not in FSF.
  24
  25 ;;; Commentary:
  26
  27 ;; This file is dumped with SXEmacs (when toolbar support is compiled in).
  28
  29 ;;; Code:
  30
  31 (defcustom toolbar-visible-p ;; added for the options menu - dverna apr. 98
  32   (specifier-instance default-toolbar-visible-p)
  33   "Whether the default toolbar is globally visible.
  34 This option can be customized through the options menu."
  35   :group 'display
  36   :type 'boolean
  37   :set #'(lambda (var val)
  38            (set-specifier default-toolbar-visible-p val)
  39            (setq toolbar-visible-p val))
  40   )
  41
  42 (defcustom toolbar-captioned-p ;; added for the options menu - dverna apr. 98
  43   (specifier-instance toolbar-buttons-captioned-p)
  44   "Whether the toolbars buttons are globally captioned.
  45 This option can be customized through the options menu."
  46   :group 'display
  47   :type 'boolean
  48   :set #'(lambda (var val)
  49            (set-specifier toolbar-buttons-captioned-p val)
  50            (setq toolbar-captioned-p val))
  51   )
  52
  53 (defcustom default-toolbar-position ;; added for the options menu - dverna
  54   (default-toolbar-position)
  55   "The location of the default toolbar.
  56 It can be 'top, 'bottom, 'left or 'right. This option can be
  57 customized through the options menu."
  58   :group 'display
  59   :type '(choice (const :tag "top" top)
  60                  (const :tag "bottom" bottom)
  61                  (const :tag "left" left)
  62                  (const :tag "right" right))
  63   :set #'(lambda (var val)
  64            (set-default-toolbar-position val)
  65            (setq default-toolbar-position val))
  66   )
  67
  68 (defvar toolbar-help-enabled t
  69   "If non-nil help is echoed for toolbar buttons.")
  70
  71 (defvar toolbar-icon-directory nil
  72   "Location of standard toolbar icon bitmaps, with trailing path separator.")
  73
  74 (defun toolbar-make-button-list (up &optional down disabled cap-up cap-down cap-disabled)
  75   "Call make-glyph on each arg and return a list of the results."
  76   (let ((up-glyph (make-glyph up))
  77             (down-glyph (and down (make-glyph down)))
  78             (disabled-glyph (and disabled (make-glyph disabled)))
  79             (cap-up-glyph (and cap-up (make-glyph cap-up)))
  80             (cap-down-glyph (and cap-down (make-glyph cap-down)))
  81             (cap-disabled-glyph (and cap-disabled (make-glyph cap-disabled))))
  82         (if cap-disabled
  83             (list up-glyph down-glyph disabled-glyph
  84                   cap-up-glyph cap-down-glyph cap-disabled-glyph)
  85           (if cap-down
  86             (list up-glyph down-glyph disabled-glyph
  87                   cap-up-glyph cap-down-glyph)
  88             (if cap-up
  89                 (list up-glyph down-glyph disabled-glyph cap-up-glyph)
  90               (if disabled-glyph
  91                   (list up-glyph down-glyph disabled-glyph)
  92                 (if down-glyph
  93                     (list up-glyph down-glyph)
  94                   (list up-glyph))))))))
  95
  96 (defun init-toolbar-location ()
  97   (if (not toolbar-icon-directory)
  98       (let ((name (locate-data-directory "toolbar")))
  99         (if name
 100             (setq toolbar-icon-directory
 101                   (file-name-as-directory name))))))
 102
 103 (defun init-toolbar-from-resources (locale)
 104   (if (and (featurep 'x)
 105            (not (featurep 'infodock))
 106            (or (eq locale 'global)
 107                (eq 'x (device-or-frame-type locale))))
 108       (x-init-toolbar-from-resources locale)))
 109
 110 \f
 111 ;; #### Is this actually needed or will the code in
 112 ;; default-mouse-motion-handler suffice?
 113 (define-key global-map 'button1up 'release-toolbar-button)
 114
 115 (defvar toolbar-map (let ((m (make-sparse-keymap)))
 116                       (set-keymap-name m 'toolbar-map)
 117                       m)
 118   "Keymap consulted for mouse-clicks over a toolbar.")
 119
 120 (define-key toolbar-map 'button1 'press-toolbar-button)
 121 (define-key toolbar-map 'button1up 'release-and-activate-toolbar-button)
 122 (defvar last-pressed-toolbar-button nil)
 123 (defvar toolbar-active nil)
 124
 125 (defvar toolbar-blank-press-function nil
 126   "Function to call if a blank area of the toolbar is pressed.")
 127
 128 ;;
 129 ;; It really sucks that we also have to tie onto
 130 ;; default-mouse-motion-handler to make sliding buttons work right.
 131 ;;
 132 (defun press-toolbar-button (event)
 133   "Press a toolbar button.  This only changes its appearance.
 134 Call function stored in `toolbar-blank-press-function,' if any, with EVENT as
 135 an argument if press is over a blank area of the toolbar."
 136   (interactive "_e")
 137   (setq this-command last-command)
 138   (let ((button (event-toolbar-button event)))
 139     ;; We silently ignore non-buttons.  This most likely means we are
 140     ;; over a blank part of the toolbar.
 141     (setq toolbar-active t)
 142     (if (toolbar-button-p button)
 143         (progn
 144           (set-toolbar-button-down-flag button t)
 145           (setq last-pressed-toolbar-button button))
 146       ;; Added by Bob Weiner, Motorola Inc., 10/6/95, to handle
 147       ;; presses on blank portions of toolbars.
 148       (when (functionp toolbar-blank-press-function)
 149         (funcall toolbar-blank-press-function event)))))
 150
 151 (defun release-and-activate-toolbar-button (event)
 152   "Release a toolbar button and activate its callback.
 153 Call function stored in `toolbar-blank-release-function,' if any, with EVENT
 154 as an argument if release is over a blank area of the toolbar."
 155   (interactive "_e")
 156   (or (button-release-event-p event)
 157       (error "%s must be invoked by a mouse-release" this-command))
 158   (release-toolbar-button event)
 159   (let ((button (event-toolbar-button event)))
 160     (if (and (toolbar-button-p button)
 161              (toolbar-button-enabled-p button)
 162              (toolbar-button-callback button))
 163         (let ((callback (toolbar-button-callback button)))
 164           (setq this-command callback)
 165           ;; Handle arbitrary functions.
 166           (if (functionp callback)
 167               (if (commandp callback)
 168                   (call-interactively callback)
 169                 (funcall callback))
 170             (eval callback))))))
 171
 172 ;; If current is not t, then only release the toolbar button stored in
 173 ;; last-pressed-toolbar-button
 174 (defun release-toolbar-button-internal (event current)
 175   (let ((button (event-toolbar-button event)))
 176     (setq zmacs-region-stays t)
 177     (if (and last-pressed-toolbar-button
 178              (not (eq last-pressed-toolbar-button button))
 179              (toolbar-button-p last-pressed-toolbar-button))
 180         (progn
 181           (set-toolbar-button-down-flag last-pressed-toolbar-button nil)
 182           (setq last-pressed-toolbar-button nil)))
 183     (if (and current (toolbar-button-p button))
 184         (set-toolbar-button-down-flag button nil))))
 185
 186 (defun release-toolbar-button (event)
 187   "Release all pressed toolbar buttons."
 188   (interactive "_e")
 189   (or (button-release-event-p event)
 190       (error "%s must be invoked by a mouse-release" this-command))
 191   (release-toolbar-button-internal event t)
 192   ;; Don't set this-command if we're being called
 193   ;; from release-and-activate-toolbar-button.
 194   (if (interactive-p)
 195       (setq this-command last-command))
 196   (setq toolbar-active nil))
 197
 198 (defun release-previous-toolbar-button (event)
 199   (setq zmacs-region-stays t)
 200   (release-toolbar-button-internal event nil))
 201
 202 (defun make-toolbar-specifier (spec-list)
 203   "Return a new `toolbar' specifier object with the given specification list.
 204 SPEC-LIST can be a list of specifications (each of which is a cons of a
 205 locale and a list of instantiators), a single instantiator, or a list
 206 of instantiators.  See `make-specifier' for more information about
 207 specifiers.
 208
 209 Toolbar specifiers are used to specify the format of a toolbar.
 210 The values of the variables `default-toolbar', `top-toolbar',
 211 `left-toolbar', `right-toolbar', and `bottom-toolbar' are always
 212 toolbar specifiers.
 213
 214 Valid toolbar instantiators are called \"toolbar descriptors\"
 215 and are lists of vectors.  See `default-toolbar' for a description
 216 of the exact format."
 217   (make-specifier-and-init 'toolbar spec-list))
 218
 219 ;;; toolbar.el ends here