git.chise.org Git - chise/xemacs-chise.git.1/blob - lisp/toolbar.el

   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, 'bootom, 'left or
  58 'right. This option can be customized through the options menu."
  59   :group 'display
  60   :type '(choice (const :tag "top" 'top)
  61                  (const :tag "bottom" 'bottom)
  62                  (const :tag "left" 'left)
  63                  (const :tag "right" 'right))
  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
 104 (defun init-toolbar-from-resources (locale)
 105   (if (and (featurep 'x)
 106            (not (featurep 'infodock))
 107            (or (eq locale 'global)
 108                (eq 'x (device-or-frame-type locale))))
 109       (x-init-toolbar-from-resources locale)))
 110
 111 \f
 112 ;; #### Is this actually needed or will the code in
 113 ;; default-mouse-motion-handler suffice?
 114 (define-key global-map 'button1up 'release-toolbar-button)
 115
 116 (defvar toolbar-map (let ((m (make-sparse-keymap)))
 117                       (set-keymap-name m 'toolbar-map)
 118                       m)
 119   "Keymap consulted for mouse-clicks over a toolbar.")
 120
 121 (define-key toolbar-map 'button1 'press-toolbar-button)
 122 (define-key toolbar-map 'button1up 'release-and-activate-toolbar-button)
 123 (defvar last-pressed-toolbar-button nil)
 124 (defvar toolbar-active nil)
 125
 126 ;;
 127 ;; It really sucks that we also have to tie onto
 128 ;; default-mouse-motion-handler to make sliding buttons work right.
 129 ;;
 130 (defun press-toolbar-button (event)
 131   "Press a toolbar button.  This only changes its appearance.
 132 Call function stored in `toolbar-blank-press-function,' if any, with EVENT as
 133 an argument if press is over a blank area of the toolbar."
 134   (interactive "_e")
 135   (setq this-command last-command)
 136   (let ((button (event-toolbar-button event)))
 137     ;; We silently ignore non-buttons.  This most likely means we are
 138     ;; over a blank part of the toolbar.
 139     (setq toolbar-active t)
 140     (if (toolbar-button-p button)
 141         (progn
 142           (set-toolbar-button-down-flag button t)
 143           (setq last-pressed-toolbar-button button))
 144       ;; Added by Bob Weiner, Motorola Inc., 10/6/95, to handle
 145       ;; presses on blank portions of toolbars.
 146       (and (boundp 'toolbar-blank-press-function)
 147            (functionp toolbar-blank-press-function)
 148            (funcall toolbar-blank-press-function event)))))
 149
 150 (defun release-and-activate-toolbar-button (event)
 151   "Release a toolbar button and activate its callback.
 152 Call function stored in `toolbar-blank-release-function,' if any, with EVENT
 153 as an argument if release is over a blank area of the toolbar."
 154   (interactive "_e")
 155   (or (button-release-event-p event)
 156       (error "%s must be invoked by a mouse-release" this-command))
 157   (release-toolbar-button event)
 158   (let ((button (event-toolbar-button event)))
 159     (if (and (toolbar-button-p button)
 160              (toolbar-button-enabled-p button)
 161              (toolbar-button-callback button))
 162         (let ((callback (toolbar-button-callback button)))
 163           (setq this-command callback)
 164           ;; Handle arbitrary functions.
 165           (if (functionp callback)
 166               (if (commandp callback)
 167                   (call-interactively callback)
 168                 (funcall callback))
 169             (eval callback))))))
 170
 171 ;; If current is not t, then only release the toolbar button stored in
 172 ;; last-pressed-toolbar-button
 173 (defun release-toolbar-button-internal (event current)
 174   (let ((button (event-toolbar-button event)))
 175     (setq zmacs-region-stays t)
 176     (if (and last-pressed-toolbar-button
 177              (not (eq last-pressed-toolbar-button button))
 178              (toolbar-button-p last-pressed-toolbar-button))
 179         (progn
 180           (set-toolbar-button-down-flag last-pressed-toolbar-button nil)
 181           (setq last-pressed-toolbar-button nil)))
 182     (if (and current (toolbar-button-p button))
 183         (set-toolbar-button-down-flag button nil))))
 184
 185 (defun release-toolbar-button (event)
 186   "Release all pressed toolbar buttons."
 187   (interactive "_e")
 188   (or (button-release-event-p event)
 189       (error "%s must be invoked by a mouse-release" this-command))
 190   (release-toolbar-button-internal event t)
 191   ;; Don't set this-command if we're being called
 192   ;; from release-and-activate-toolbar-button.
 193   (if (interactive-p)
 194       (setq this-command last-command))
 195   (setq toolbar-active nil))
 196
 197 (defun release-previous-toolbar-button (event)
 198   (setq zmacs-region-stays t)
 199   (release-toolbar-button-internal event nil))
 200
 201 ;;; toolbar.el ends here