cgit.sxemacs.org Git - packages/blob - xemacs-packages/edit-utils/toolbar-utils.el

   1 ;;; toolbar-utils.el --- Toolbar utility functions for XEmacs
   2
   3 ;; Copyright (C) 1997, 2002 by Free Software Foundation, Inc.
   4
   5 ;; Author: Stephen J. Turnbull <stephen@xemacs.org>
   6 ;;         Jeff Miller <jmiller@smart.net>
   7 ;; Created: 1997
   8 ;; Last-Modified: 03 December 2002
   9 ;; Keywords: gui, services
  10
  11 ;; This file is part of XEmacs.
  12
  13 ;; XEmacs is free software; you can redistribute it and/or modify it
  14 ;; under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 2, or (at your option)
  16 ;; any later version.
  17
  18 ;; XEmacs is distributed in the hope that it will be useful, but
  19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21 ;; General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  25 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  26 ;; 02111-1307, USA.
  27
  28 ;;; Synched up with: Not in FSF
  29
  30 ;;; Commentary:
  31
  32 ;; This file contains utilities for managing XEmacs toolbars.
  33 ;; It doesn't seem to make sense to provide GNU compatibility here.
  34 ;; Instead, it seems much more reliable to reimplement the XEmacs
  35 ;; APIs for GNU.
  36
  37 ;; This code is inspired by that written by Jeff Miller, and retains
  38 ;; his APIs.  However, it is a thorough rewrite.
  39 ;; See also edit-toolbar.el by Peter D. Pezaris <pez@dwwc.com>
  40
  41 ;;; Change Log: see package ChangeLog.
  42
  43 ;; To do:
  44
  45 ;; 1. Probably should convert all these to use &keywords?
  46 ;; 2. Behavior-like implementation of "mode locales".
  47 ;; 3. Implement toolbar-replace-button (by position or content).
  48 ;; 5. Make an xemacs-toolbar version to do something sane in GNU.
  49
  50 ;;; Code:
  51
  52 ;;;###autoload
  53 (defun restore-initial-toolbar ()
  54   "Restores the default toolbar defined by initial-toolbar-spec.
  55
  56 There is also a cache of killed buttons in `button-palette'."
  57   (interactive)
  58   (set-specifier default-toolbar initial-toolbar-spec))
  59
  60 ;;; Variables:
  61
  62 ;; #### need parent group
  63 (defgroup edit-toolbar nil
  64   "Tools for interactive editing and non-interactive management of toolbars.")
  65
  66 (defcustom toolbar-button-default-position 'right
  67   "Default position for adding toolbar buttons on the fly.
  68
  69 See `toolbar-add-button-on-the-fly' for possible values and meanings."
  70   :type 'sexp
  71   :group 'edit-toolbar)
  72
  73 ;; This needs to be a toolbar descriptor.  We should make a function to
  74 ;; stick it in a non-default toolbar, with surgery done on the function
  75 ;; so that pressing the palette buttons moves them to another toolbar.
  76 (defvar button-palette nil
  77   "List of buttons cut from toolbars.
  78
  79 Note this is actually a toolbar descriptor.")
  80
  81 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  82 ;;
  83 ;; User commands:
  84
  85 ;; toolbar-add-button-on-the-fly
  86
  87 ;; #### This really belongs in edit-toolbar.el, except that it requires
  88 ;; functions from this file and edit-toolbar.el otherwise would not.
  89 ;;;###autoload
  90 (defun toolbar-add-button-on-the-fly (description command label
  91                                       &optional position locale)
  92   "Add an button at POSITION to the default toolbar of the selected window.
  93 Returns t.
  94
  95 #### The return value may change.  Tell stephen@xemacs.org what value
  96 you think would be (most) useful.
  97
  98 DESCRIPTION is a string describing the action, and displayed as help.
  99 COMMAND is an interactive command (ie, a symbol with an interactive function
 100 definition) implementing the action.
 101 LABEL is a string used to label the button.
 102 POSITION is an optional position (a non-negative integer, or one of the
 103 symbols 'left, 'right, or 'extreme-right, see `toolbar-add-item').
 104 LOCALE is an optional locale, defaulting to the current buffer.  If current-
 105 buffer-only is not what you want, and you don't understand specifier locales,
 106 use 'global.  It's safe and probably does what you want.
 107
 108 #### No error checking, use at your own risk."
 109
 110   (interactive (list (read-string "Description: ")
 111                      (read-command "Command: ")
 112                      (read-string "Button label: ")
 113                      (read (completing-read
 114                             "Position: "
 115                             (lambda (x junk morejunk)
 116                               (cond ((let ((y (read x)))
 117                                        (and (integerp y)
 118                                             (<= 0 y)))
 119                                      x)
 120                                     ((try-completion x '(("left")
 121                                                          ("extreme-right")
 122                                                          ("right"))))))
 123                        nil nil nil nil "right"))
 124                      current-prefix-arg))
 125
 126   (let ((domain (selected-window))
 127         (button (toolbar-new-button label command description)))
 128     (set-specifier default-toolbar
 129                    (toolbar-add-item (specifier-instance default-toolbar
 130                                                          domain)
 131                                      button
 132                                      position)
 133                    (or locale (current-buffer))))
 134   t)
 135
 136 ;; toolbar-add-kbd-macro
 137
 138 ;;;###autoload
 139 (defun toolbar-add-kbd-macro (mac icon is-file)
 140   "Add a button invoking a keyboard macro to the toolbar of the current buffer.
 141 The button is added at the end of the left group.
 142
 143 MAC is a keyboard macro name, or the empty string or nil to use a copy of
 144 the last keyboard macro defined.
 145 ICON is a string specifying the icon to be used.  If IS-FILE is non-nil,
 146 it is interpreted as the name of an image file, and searched for using
 147 `locate-data-file'.  Otherwise it is used verbatim as a label.
 148
 149 Interactively, prompts for the macro name MAC and an ICON.  IS-FILE is
 150 non-nil if a prefix argument was used.
 151
 152 Warning: the interpretation of the prefix argument is likely to change."
 153   (interactive
 154    (list (read-string "Macro name (RET to use last defined macro): ")
 155          (read-string (format "Icon %s: "
 156                               (if current-prefix-arg "image" "label")))
 157          current-prefix-arg))
 158   (let* ((locale (current-buffer))
 159          (position nil)
 160          (mac (if (or (null mac) (= 0 (length mac)))
 161                   ;; is there an argument pro or con to copy-sequence?
 162                   last-kbd-macro
 163                 (intern mac)))
 164          ;; #### this actually probably just works, and we don't even need
 165          ;; the IS-FILE argument at all
 166          (icon (if is-file
 167                    (error 'unimplemented "We don't do image icons yet")
 168                  icon))
 169          ;; this is actually the help string
 170          (label (cond ((and is-file mac))
 171                       ;;  #### should truncate image file extension if any
 172                       ((and (stringp icon) (< 0 (length icon))) icon)
 173                       (t "KbdMac")))
 174          (button (toolbar-new-button icon
 175                                      `(lambda ()
 176                                         (interactive)
 177                                         (execute-kbd-macro ,mac))
 178                                      label)))
 179     ;; #### need to abstract this
 180     ;; something like (toolbar-update-toolbar TOOLBAR ITEM POS LOCALE)
 181     (set-specifier default-toolbar
 182                    (toolbar-add-item (cdadar
 183                                       (specifier-spec-list default-toolbar
 184                                                            locale))
 185                                      button
 186                                      position)
 187                    locale))
 188   t)
 189
 190 ;; #### this should be a behavior
 191 ;;;###autoload
 192 (defun toolbar-add-execute-macro-button ()
 193   "Add a button to the global toolbar to execute the last keyboard macro.
 194
 195 Unlike `toolbar-add-kbd-macro', this does not copy the macro.  The macro
 196 executed will change with redefinitions.
 197
 198 Due to a simple implementation, this button will not appear in buffers with
 199 local toolbars if invoked after the toolbar is installed.  If you like this
 200 button, it's probably best to invoke this function in your init file."
 201   (interactive)
 202   (let* ((locale 'global)
 203          (spec (cdadar (specifier-spec-list default-toolbar locale)))
 204          (button (toolbar-new-button "LastMac"
 205                                      #'toolbar-execute-last-kbd-macro
 206                                      "Execute last defined keyboard macro")))
 207     (set-specifier default-toolbar (toolbar-add-item spec button) locale)))
 208
 209 ;; if this is defsubst, XEmacs 21.4.10 crashes?
 210 (defun toolbar-execute-last-kbd-macro ()
 211   (interactive)
 212   (execute-kbd-macro last-kbd-macro))
 213
 214 \f
 215 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 216 ;;
 217 ;; Lisp API functions:
 218
 219 ;; adding items to a toolbar, with convenience functions for constructing
 220 ;; valid buttons, spacers, and toolbar descriptors
 221
 222 ;;;###autoload
 223 (defun toolbar-update-toolbar (item &optional toolbar position locale)
 224   "Use ITEM to update TOOLBAR at POSITION in LOCALE.
 225
 226 ITEM is a toolbar button or spacer specification (eg, from
 227 `toolbar-new-button' or `toolbar-new-spacer').
 228 Optional TOOLBAR is a toolbar specifier object.  It defaults to the value
 229 of `default-toolbar'.
 230 Optional POSITION is a non-negative integer or a symbol (for valid values,
 231 see `toolbar-add-item').  The default is 'right.
 232 Optional LOCALE is a specifier locale.  The default is 'global.  (This
 233 default is not yet set in stone; it's best not to depend on it.)
 234
 235 This is a convenience function for helper applications or minor modes that
 236 would like to add a small number of buttons to an existing toolbar.  For
 237 constructing toolbars from scratch, use list and vector primitives, or
 238 `toolbar-add-item'."
 239   (setq toolbar (or toolbar default-toolbar))
 240   (setq position (or position 'right))
 241   (setq locale (or locale 'global))
 242   (let ((spec (cdadar (specifier-spec-list toolbar locale))))
 243     (set-specifier toolbar (toolbar-add-item spec item position) locale)))
 244
 245
 246 ;;;###autoload
 247 (defun toolbar-add-item (toolbar-spec item &optional position)
 248   "Add ITEM to TOOLBAR-SPEC at POSITION, and return TOOLBAR-SPEC.
 249 Uses functions that alter list structure.
 250
 251 TOOLBAR-SPEC is a toolbar descriptor (eg, from `toolbar-new-toolbar').
 252 ITEM is a toolbar button or spacer specification (eg, from
 253 `toolbar-new-button' or `toolbar-new-spacer').
 254 Optional POSITION is a non-negative integer, with 0 being the extreme left and
 255 \(length TOOLBAR-SPEC) the extreme right.  The symbols 'left, 'right, and
 256 'extreme-right are also accepted.  'left is synonymous with 0.  'right places
 257 ITEM at the right end of the left group of buttons.  'extreme-right places
 258 ITEM at the extreme right of the toolbar, creating a right group if one
 259 does not exist.
 260
 261 #### This function does not yet support inserting the group delimiter nil
 262 as an explicit item.
 263
 264 POSITION may be greater than (length TOOLBAR-SPEC), in which case it is
 265 truncated to (length TOOLBAR-SPEC).  Note that (length TOOLBAR-SPEC) is not
 266 synonymous with either 'right or 'extreme-right."
 267   (check-valid-instantiator toolbar-spec 'toolbar)
 268   (check-toolbar-button-syntax item)
 269   (unless position (setq position toolbar-button-default-position))
 270   (cond ((eq position 'right)
 271          (let ((tail (memq nil toolbar-spec)))
 272            (if (not tail)
 273                (nconc toolbar-spec (list item))
 274              ;; is this overly tricky?
 275              (setcar tail item)
 276              (setcdr tail (cons nil (cdr tail)))
 277              toolbar-spec)))
 278         ((or (eq position 'left) (eq position 0))
 279          (cons item toolbar-spec))
 280         ((eq position 'extreme-right)
 281          (nconc toolbar-spec (if (memq nil toolbar-spec)
 282                                  (list item)
 283                                (list nil item))))
 284         ((and (integerp position) (< 0 position))
 285          (let ((tail (nthcdr 1 toolbar-spec)))
 286            (if (null tail)
 287                (nconc toolbar-spec (list item))
 288              ;; is this overly tricky?
 289              (setcdr tail (cons (car tail) (cdr tail)))
 290              (setcar tail item)
 291              toolbar-spec)))
 292         (t (error 'wrong-type-argument
 293                   'integer-or-symbol
 294                   position))))
 295
 296 ;;;###autoload
 297 (defun toolbar-new-button (icon-spec command help-string
 298                            &optional initially-disabled)
 299   "Return a checked toolbar button specification.
 300
 301 ICON-SPEC should be a list of glyphs (from `make-glyph'), a glyph, or a
 302 string to use as the button's icon.  If a string or single glyph, it will
 303 be used for the button-up glyph.  If a list, it may contain 1 to 6 glyphs,
 304 which XEmacs will use for button up, button down, button disabled, button
 305 up with caption, button down with caption, and button disabled with caption,
 306 in that order.  Missing or nil glyphs will be defaulted.  (#### Strings as
 307 list elements are not supported but could be.)
 308 COMMAND is the (interactive) command to invoke when the button is pressed.
 309 HELP-STRING is a string briefly describing the command, displayed in the
 310 echo area or as balloon help when the pointer enters the button.
 311 Optional argument INITIALLY-DISABLED, if non-nil, specifies that the button
 312 should initially be disabled.
 313
 314 See `default-toolbar' or the Lispref (node toolbars) for more information."
 315   (setq icon-spec (cond ((glyphp icon-spec) (list icon-spec))
 316                         ((stringp icon-spec) (list (make-glyph icon-spec)))
 317                         ((listp icon-spec) icon-spec)))
 318   (let ((button-spec
 319          (vector icon-spec command (not initially-disabled) help-string)))
 320     (check-toolbar-button-syntax button-spec)
 321     button-spec))
 322
 323 ;;;###autoload
 324 (defun toolbar-new-spacer (style &optional size)
 325   "Returns a checked toolbar spacer \"button\".
 326
 327 STYLE is one of the symbols '2d or '3d, indicating whether the area is
 328 displayed without shadows (giving it a flat appearance), or with shadows
 329 \(giving it a raised, 3-d appearance).  There is no default.
 330 #### We may set a default style.  Tell stephen@xemacs.org which you use.
 331 SIZE specifies the length, in pixels, of the blank area.  If omitted,
 332 it defaults to a device-specific value (8 pixels for X devices)."
 333   (let* ((style (or style '2d))
 334          (button (if size
 335                      (vector :style style :size size)
 336                    (vector :style style))))
 337     (check-toolbar-button-syntax button)
 338     button))
 339
 340 ;;;###autoload
 341 (defun make-toolbar-instantiator (&optional toolbar-spec domain)
 342   "Return a checked toolbar instantiator, a list of vectors.
 343
 344 TOOLBAR-SPEC may be a list of buttons (ie, a toolbar descriptor, see
 345 `default-toolbar'), a toolbar specifier object, or a symbol whose value is
 346 a toolbar specifier object.  If a toolbar specifier object or variable
 347 containing one, the specification for DOMAIN is used.  If non-nil, DOMAIN
 348 must be a window, a frame, or a device, otherwise it defaults to the selected
 349 window (see `specifier-instance').  The list thus generated is checked and
 350 returned.
 351
 352 If TOOLBAR-SPEC is a list, it is copied; it is safe to pass other packages'
 353 toolbar initializers to this function.  However, you probably do not want
 354 to change any of the objects in the returned specification.  They are
 355 returned as is, not copied.
 356
 357 See `default-toolbar' or the Lispref (node toolbars) for more information."
 358   (setq toolbar-spec
 359         (cond ((null toolbar-spec) nil)
 360
 361               ((symbolp toolbar-spec)
 362                (specifier-instance (symbol-value toolbar-spec) domain))
 363               ((specifierp toolbar-spec)
 364                (specifier-instance toolbar-spec domain))
 365               ((listp toolbar-spec) (copy-sequence toolbar-spec))
 366               (t toolbar-spec)))        ; errors by check-valid-instantiator
 367   (check-valid-instantiator toolbar-spec 'toolbar)
 368   toolbar-spec)
 369
 370 ;; removing buttons from a toolbar
 371
 372 ;;;###autoload
 373 (defun toolbar-kill-item-pos (pos &optional toolbar locale)
 374   "Kill the item at position POS of TOOLBAR in LOCALE.
 375 Killed buttons are prepended to `button-palette'.
 376
 377 LOCALE defaults to 'global.  If there are multiple specs for LOCALE, take
 378 the first one.
 379
 380 This function currently does not accept symbolic positions a la
 381 `toolbar-add-item'.  Use `toolbar-find-item' to locate whole buttons and
 382 spacers, and `toolbar-find-button' to locate buttons by characteristics.
 383 See also `toolbar-find-button-by-icon', `toolbar-find-button-by-command',
 384 and `toolbar-find-button-by-help-string'."
 385   (setq locale (or locale 'global))
 386   (setq toolbar (or toolbar default-toolbar))
 387   (let ((spec (cdadar (specifier-spec-list toolbar locale))))
 388     (setq button-palette (cons (nth pos spec) button-palette))
 389     (if (eq pos 0)
 390         (setq spec (cdr spec))
 391       (setcdr (nthcdr (1- pos) spec)
 392               (nthcdr (1+ pos) spec)))
 393     (set-specifier toolbar spec locale)))
 394
 395 ;; locating buttons by their content, returning a position
 396
 397 ;;;###autoload
 398 (defun toolbar-find-button (item &optional toolbar locale)
 399   "Return the position of a button containing ITEM in its specification.
 400
 401 ITEM may specify a button, spacer, icon, command, help string, or nil.
 402 If ITEM is nil, find the separator between the group of buttons to be left
 403 justified, and the group to be right justified.  (Distinctions among the
 404 various \"search key types\" are somewhat heuristic but are probably
 405 reliable enough to use in library code.)
 406
 407 If TOOLBAR is non-nil, search it; otherwise search the default toolbar.
 408 If LOCALE is non-nil, get TOOLBAR's descriptor in that locale, otherwise
 409 use the global locale."
 410   (setq toolbar (or toolbar default-toolbar))
 411   (setq locale (or locale 'global))
 412   (cond ((or (null item) (vectorp item)) (toolbar-find-item item))
 413         ((commandp item) (toolbar-find-button-by-command item toolbar locale))
 414         ((stringp item)
 415          (toolbar-find-button-by-help-string item toolbar locale))
 416         (t (toolbar-find-button-by-icon item toolbar locale))))
 417
 418 ;;;###autoload
 419 (defun toolbar-find-item (item &optional toolbar locale)
 420   "Return the position of ITEM, a button, spacer, or nil.
 421 TOOLBAR and LOCALE determine the descriptor to be searched.
 422
 423 If ITEM is nil, find the separator between the group of buttons to be left
 424 justified, and the group to be right justified.
 425 If there are several matching items, the first is returned.  If none is
 426 found, return nil."
 427   (catch 'found
 428     (let ((pos 0))
 429       (while toolbar
 430         (if (equal (car toolbar) item) (throw 'found pos))
 431         (setq pos (1+ pos))
 432         (setq toolbar (cdr toolbar)))
 433       nil)))
 434
 435 ;; internals -- if you think these should be autoloaded, let me know
 436 (defun toolbar-find-button-by-icon (icon &optional toolbar locale)
 437   "Return the position of a button with icon ICON.
 438 ICON must be a list of glyphs or a symbols whose value is a list of glyphs.
 439 TOOLBAR and LOCALE determine the descriptor to be searched.
 440
 441 If there are several matching buttons, the first is returned."
 442   (flet ((thunk (x) (if (symbolp x) (symbol-value x) x)))
 443     (toolbar-find-button-by-element icon 0 toolbar locale #'thunk)))
 444
 445 (defun toolbar-find-button-by-command (cmd &optional toolbar locale)
 446   "Return the position of a button invoking command CMD.
 447 TOOLBAR and LOCALE determine the descriptor to be searched.
 448
 449 If there are several matching buttons, the first is returned."
 450   (toolbar-find-button-by-element cmd 2 toolbar locale))
 451
 452 (defun toolbar-find-button-by-help-string (str &optional toolbar locale)
 453   "Return the position of a button with help-string STR.
 454 TOOLBAR and LOCALE determine the descriptor to be searched.
 455
 456 If there are several matching buttons, the first is returned.
 457 This function will not find spacers."
 458   (toolbar-find-button-by-element str 3 toolbar locale))
 459
 460 (defun toolbar-find-button-by-element (object index toolbar locale
 461                                        &optional thunk)
 462   "Return the position of a button containing OBJECT in element INDEX.
 463 TOOLBAR and LOCALE determine the descriptor to be searched.
 464
 465 Optional argument THUNK is a function of one argument which is used to
 466 normalize OBJECT for comparison.
 467
 468 If there are several matching buttons, the first is returned.
 469 This function will not find spacers."
 470   (setq toolbar (or toolbar default-toolbar))
 471   (setq locale (or locale 'global))
 472   (if thunk (setq object (funcall thunk object)))
 473   (let ((desc (cdadar (specifier-spec-list toolbar locale)))
 474         (pos 0))
 475     ;; #### rewrite this as a catch ... throw
 476     (while (not (equal object (let ((el (aref (car desc) index)))
 477                                 (if thunk (funcall thunk el) el))))
 478       (setq desc (cdr desc))
 479       (setq pos (1+ pos)))
 480     (if toolbar pos nil)))
 481
 482 (provide 'toolbar-utils)
 483
 484 ;;; toolbar-utils.el ends here