cgit.sxemacs.org Git - packages/blob - xemacs-packages/auctex/toolbar-x.el

   1 ;;; toolbar-x.el --- fancy toolbar handling in Emacs and XEmacs
   2
   3 ;; Copyright (C) 2004, 2005, 2008, 2014, 2016 Free Software Foundation, Inc.
   4
   5 ;; This program is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the GNU General Public License as
   7 ;; published by the Free Software Foundation; either version 3 of
   8 ;; the License, or (at your option) any later version.
   9
  10 ;; This program is distributed in the hope that it will be
  11 ;; useful, but WITHOUT ANY WARRANTY; without even the implied
  12 ;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
  13 ;; PURPOSE.  See the GNU General Public License for more details.
  14
  15 ;; You should have received a copy of the GNU General Public
  16 ;; License along with this program; if not, write to the Free
  17 ;; Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
  18 ;; MA 02110-1301 USA
  19
  20 ;;; Author: Miguel Vinicius Santini Frasson
  21
  22 ;;; Commentary:
  23 ;; This program implements a common interface to display toolbar
  24 ;; buttons in both Emacs and XEmacs.  A toolbar should be basicly
  25 ;; defined by a image and a command to run when the button is pressed,
  26 ;; and additional properties could be added.  This is the idea of this
  27 ;; program.  See the documentation of function
  28 ;; `toolbarx-install-toolbar' for a description of how to specify
  29 ;; toolbars.
  30
  31 ;;; Features:
  32
  33 ;; * Button properties are given in the toolbar definition (BUTTON
  34 ;; paramenter in `toolbarx-install-toolbar') and/or in an alist with
  35 ;; associates the symbol with properties (MEANING-ALIST paramenter in
  36 ;; `toolbarx-install-toolbar').
  37
  38 ;; * Supported properties:
  39 ;; - All editors: `:insert', `:image', `:command', `:help', `:enable',
  40 ;;                `:append-command' and `:prepend-command';
  41 ;; - Emacs only: `:visible' and `:button';
  42 ;; - XEmacs only: `:toolbar'.
  43 ;; For the precise value-type for each property, see documentation of
  44 ;; the function `toolbarx-install-toolbar'.
  45 ;; (ps: properties that are particular to an editor are just ignored
  46 ;; the other editor flavour.)
  47
  48 ;; * Button properties may depend on the editor flavour, if the value
  49 ;; is a vector; the first element will be used for Emacs and the 2nd
  50 ;; for XEmacs. Example: `:image ["new" toolbar-file-icon]'
  51
  52 ;; * Properties can have value specified by function (with no
  53 ;; argument) or variables that evaluate to an object of the correct
  54 ;; type for a particular property.  The evaluation is done when the
  55 ;; roolbar is refresh (a call of `toolbarx-refresh'.)
  56 ;; (ps: this is valid only for properties that *not* have \`form\' as
  57 ;; value type.)
  58
  59 ;; * On `refresh time' (a call `toolbarx-refresh', necessary when the
  60 ;; toolbar should change), the `:insert' property (if present) is
  61 ;; evaluated to decide if button will be displayed.
  62
  63 ;; Properties can be distributed to several buttons, using \`groups\'.
  64 ;; Example: (for (bar baz :toolbar (bottom . top) :insert foo-form)
  65 ;; means that `foo', `bar' and `baz' have `:insert foo-form' and `bar' and
  66 ;; `baz' have the property `:toolbar (bottom .  top)'.  (ps: this type
  67 ;; of value for the `:toolbar' property (XEmacs only) means that the
  68 ;; buttons will be in the bottom toolbar unless the default toolbar is
  69 ;; in the bottom, and in this case, this buttons go to the top
  70 ;; toolbar).
  71
  72 ;; * (Part of) the toolbar definition can be stored in a variable,
  73 ;; evaluated in `installation time'.  See `:eval-group' on the
  74 ;; documentation of the function `toolbarx-install-toolbar'.
  75
  76 ;; * It is possible to define sets of buttons that appear according to
  77 ;; an option selected in a dropdown menu.  See `:dropdown-group' on
  78 ;; the documentation of the function `toolbarx-install-toolbar'.
  79
  80 ;;; Rough description of the implementation
  81 ;; There are 3 \`engines\' implemented:
  82
  83 ;; == the 1st one (parsing) parses the toolbar definition
  84 ;; independently of editor flavour and store the parsed buttons with
  85 ;; their properties, in the same order that they appear in the
  86 ;; definitions, in a variable `toolbarx-internal-button-switches';
  87
  88 ;; == the 2nd one (refresh for Emacs) inserts buttons in the Emacs
  89 ;; toolbar in the same order that they appear in the definitions;
  90 ;; buttons with a `:insert' property value that evaluates to nil are
  91 ;; ignored; if a (real) button does not have at least (valid) image
  92 ;; and command properties, they are silently ignored;
  93
  94 ;; == the 3rd engine (refresh for XEmacs) is similar to the 2nd, but
  95 ;; inserts buttons in XEmacs.
  96
  97 ;;; History:
  98
  99 ;; This program was motivated by the intention of implementation of a
 100 ;; good toolbar for AUCTeX, that would work in both Emacs and XEmacs.
 101 ;; Since toolbars are very different in behaviour and implementation
 102 ;; (for instance, in Emacs one can display as many toolbar buttons as
 103 ;; wanted, because it becomes mult-line, and in XEmacs, there is one
 104 ;; line, but toolbars and all sides of a frame.)
 105
 106 \f
 107 ;;; Code:
 108
 109 (eval-when-compile (require 'cl))
 110
 111 ;; Note that this just gives a useful default.  Icons are expected to
 112 ;; be in subdirectory "images" or "toolbar" relative to the load-path.
 113 ;; Packages loading toolbarx are advised to explicitly add their own
 114 ;; searchpath with add-to-list here even when they fulfill that
 115 ;; criterion: another package might have loaded toolbar-x previously
 116 ;; when load-path was not yet correctly set.  The default setting
 117 ;; really caters only for toolbar-x' stock icons.
 118 (globally-declare-boundp 'tool-bar-map)
 119
 120 (defvar toolbarx-image-path
 121   (nconc
 122    (delq nil (mapcar #'(lambda(x)
 123                          (and x
 124                               (member
 125                                (file-name-nondirectory
 126                                 (directory-file-name x))
 127                                '("toolbar" "images"))
 128                               ;;(file-directory-p x)
 129                               x))
 130                      load-path))
 131    (list data-directory))
 132   "List of directories where toolbarx finds its images.")
 133
 134 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 135 ;;; First engine: Parsing buttons
 136
 137 ;; it obtains button information, process it and stores result in
 138 ;; `toolbarx-internal-button-switches', which is a list with 1st
 139 ;; element the symbol `:switches', the 2nd element as a list of
 140 ;; processed buttons, and the 3rd element is used for Emacs to store
 141 ;; the keys used in ``constant'' buttons.
 142
 143 ;; The 2nd element of `toolbarx-internal-button-switches' is a list
 144 ;; where each element is either:
 145 ;;  * a button-list, that is, a list with elements to define a button.
 146 ;;  * a list where 1st elem is `:insert' and 2nd is a form, and the
 147 ;; following elements are in the same format of the 2nd element of
 148 ;; `toolbarx-internal-button-switches'.
 149
 150 (defun toolbarx-make-string-from-symbol (symbol)
 151   "Return a string from the name of a SYMBOL.
 152 Upcase initials and replace dashes by spaces."
 153   (let* ((str (upcase-initials (symbol-name symbol)))
 154          (str2))
 155     (dolist (i (append str nil))
 156       (if (eq i 45)                     ; if dash, push space
 157           (push 32 str2)
 158         (push i str2)))                 ; else push identical
 159     (concat (nreverse str2))))
 160
 161 (defun toolbarx-make-symbol-from-string (string)
 162   "Return a (intern) symbol from STRING.
 163 Downcase string and replace spaces by dashes."
 164   (let* ((str1 (append (downcase string) nil))
 165          (str2))
 166     (dolist (i str1)
 167       (if (eq i 32)                     ; if dash, push space
 168           (push 45 str2)
 169         (push i str2)))
 170     (intern (concat (nreverse str2)))))
 171
 172 (defun toolbarx-good-option-list-p (option-list valid-options)
 173   "Non-nil means the OPTION-LIST is of form (OPT FORM ... OPT FORM).
 174 Each OPT is member of VALID-OPTIONS and OPT are pairwise
 175 different.  OPTION-LIST equal to nil is a good option list."
 176   (let ((elt-in-valid t)
 177         (temp-opt-list option-list)
 178         (list-diff)
 179         (n (/ (length option-list) 2)))
 180     (dotimes (i n)
 181       (when (> i 0)
 182         (setq temp-opt-list (cddr temp-opt-list)))
 183       (pushnew (car temp-opt-list) list-diff :test #'equal)
 184       (setq elt-in-valid (and elt-in-valid
 185                               (memq (car temp-opt-list)
 186                                     valid-options))))
 187     (and elt-in-valid                   ; options are on VALID-OPTOPNS
 188          ;; OPTION-LIST has all option different from each other
 189          (eq (length list-diff) n)
 190          ;; OPTION-LIST has even number of elements
 191          (eq (% (length option-list) 2) 0))))
 192
 193 (defun toolbarx-separate-options (group-list valid-options &optional check)
 194   "Return a cons cell with non-options and options of GROUP-LIST.
 195 The options-part is the largest tail of the list GROUP-LIST that
 196 has an element of VALID-OPTIONS (the comparation is made with
 197 `memq'.)  The non-options-part is the beginning of GROUP-LIST
 198 less its tail.  Return a cons cell which `car' is the
 199 non-options-part and the `cdr' is the options-part.
 200
 201 If CHECK is non-nil, the tail is the largest that yield non-nil
 202 when applied to `toolbarx-good-option-list-p'."
 203   (let ((maximal)
 204         (temp))
 205     (dolist (i valid-options)
 206       (setq temp (memq i group-list))
 207       (when (and (> (length temp) (length maximal))
 208                  (if check
 209                      (toolbarx-good-option-list-p temp valid-options)
 210                    t))
 211         (setq maximal (memq i group-list))))
 212     (cons (butlast group-list (length maximal)) maximal)))
 213
 214
 215 (defun toolbarx-merge-props (inner-props outer-props override add)
 216   "Merge property lists INNER-PROPS and OUTER-PROPS.
 217 INNER-PROPS and OUTER-PROPS are two lists in the format
 218  (PROP VAL PROP VAL ... PROP VAL).
 219 Returns a list with properties and values merged.
 220
 221 OVERRIDE and ADD are supposed to be lists of symbols.  The value
 222 of a property in OVERRIDE is the one on OUTER-PROPS or
 223 INNER-PROPS, but if the property is in both, the value in
 224 INNER-PROPS is used.  The value of a property in ADD will be a
 225 list with first element the symbol `:add-value-list' and the rest
 226 are the properties, inner properties first."
 227   (let* ((merged)
 228          (inner-prop)
 229          (outer-prop))
 230     (dolist (prop override)
 231       (if (memq prop inner-props)
 232           (setq merged (append merged
 233                                (list prop (cadr (memq prop inner-props)))))
 234         (when (memq prop outer-props)
 235           (setq merged (append merged
 236                                (list prop (cadr (memq prop outer-props))))))))
 237     (dolist (prop add merged)
 238       (setq inner-prop (memq prop inner-props))
 239       (when inner-prop
 240         (if (and (listp (cadr inner-prop))
 241                  (eq (car (cadr inner-prop)) :add-value-list))
 242             (setq inner-prop (cdr (cadr inner-prop)))
 243           (setq inner-prop (list (cadr inner-prop)))))
 244       (setq outer-prop (memq prop outer-props))
 245       (when outer-prop
 246         (if (and (listp (cadr outer-prop))
 247                  (eq (car (cadr outer-prop)) :add-value-list))
 248             (setq outer-prop (cdr (cadr outer-prop)))
 249           (setq outer-prop (list (cadr outer-prop)))))
 250       (when (append inner-prop outer-prop)
 251         (setq merged (append merged
 252                              (list prop (cons :add-value-list
 253                                               (append inner-prop
 254                                                       outer-prop)))))))))
 255
 256 (defun toolbarx-make-command (comm prep app)
 257   "Return a command made from COMM, PREP and APP.
 258 COMM is a command or a form.  PREP and APP are forms.  If PREP or
 259 APP are non-nil, they are added to the resulting command at the
 260 beginning and end, respectively.  If both are nil and COMM is a
 261 command, COMM is returned."
 262   (let ((comm-is-command (commandp comm)))
 263     (if (and (not prep)
 264              (not app)
 265              comm-is-command)
 266         comm
 267       (append '(lambda nil (interactive))
 268               (when prep (list prep))
 269               (when comm
 270                 (if comm-is-command
 271                     `((call-interactively (function ,comm)))
 272                   (list comm)))
 273               (when app (list app))))))
 274
 275 ;; in Emacs, menus are made of keymaps (vectors are possible, but editors
 276 ;; handle `menu titles' differently) meanwhile in XEmacs, menus are lists of
 277 ;; vectors
 278
 279 (defmacro toolbarx--if-when-compile (test then else)
 280   (declare (indent 1) (debug t))
 281   (if (eval test) then else))
 282
 283 (toolbarx--if-when-compile (not (featurep 'xemacs))
 284 (defun toolbarx-emacs-mount-popup-menu
 285   (strings var type &optional title save)
 286   "Return an interactive `lambda'-expression that shows a popup menu.
 287 This function is the action of `toolbarx-mount-popup-menu' if
 288 inside Emacs. See documentation of that function for more."
 289   ;; making the menu keymap by adding each menu-item definition
 290   ;; see (info "(elisp)Menu keymaps")
 291   (let* ((keymap (make-sparse-keymap title))
 292          (count 1)
 293          (used-symbols '(nil))
 294          (key)
 295          (real-type (if (eq type 'toggle) 'toggle 'radio))
 296          (real-save (when save (if (eq save 'offer) 'offer 'always))))
 297     ;; warn if type is not `radio' ot `toggle'; use `radio' if incorrect.
 298     (unless (eq type real-type)
 299       (display-warning 'toolbarx
 300                        (format (concat "TYPE should be symbols `radio' or "
 301                                        "`toggle', but %s found; using `radio'")
 302                                type)))
 303     ;; warn if save is not `nil', `offer' or `always'; use nil when incorrect
 304     (unless (eq save real-save)
 305       (setq real-save nil)
 306       (display-warning 'toolbarx
 307                        (format (concat "SAVE should be symbols `nil', "
 308                                        "`offer' or `always', but %s found; "
 309                                        "using `nil'")
 310                                save)))
 311     (dolist (i strings)
 312       ;; finding a new symbol
 313       (let* ((aux-count 0)
 314             (i-symb (toolbarx-make-symbol-from-string i)))
 315         (setq key i-symb)
 316         (while (memq key used-symbols)
 317           (setq aux-count (1+ aux-count))
 318           (setq key (intern (format "%s-%d" i-symb aux-count))))
 319         (setq used-symbols (cons key used-symbols)))
 320       (define-key-after keymap (vector key)
 321         `(menu-item ,i
 322                     ,(append
 323                       `(lambda nil (interactive)
 324                          ,(if (eq real-type 'radio)
 325                               `(setq ,var ,count)
 326                             `(if (memq ,count ,var)
 327                                 (setq ,var (delete ,count ,var))
 328                                (setq ,var (sort (cons ,count ,var) '<))))
 329                          (toolbarx-refresh))
 330                       (when (eq real-save 'always)
 331                         `((customize-save-variable
 332                            (quote ,var) ,var)))
 333                       `(,var))
 334                     :button ,(if (eq real-type 'radio)
 335                                  `(:radio eq ,var ,count)
 336                                `(:toggle memq ,count ,var))))
 337       (setq count (1+ count)))
 338     (when (eq real-save 'offer)
 339       (define-key-after keymap [sep] '(menu-item "--shadow-etched-in-dash"))
 340       (let* ((aux-count 0)
 341              (i-symb 'custom-save))
 342         (setq key i-symb)
 343         (while (memq key used-symbols)
 344           (setq aux-count (1+ aux-count))
 345           (setq key (intern (format "%s-%d" i-symb aux-count))))
 346         (setq used-symbols (cons key used-symbols)))
 347       (define-key-after keymap (vector key)
 348         `(menu-item "Save state of this menu"
 349                    (lambda nil (interactive)
 350                      (customize-save-variable (quote ,var) ,var)))))
 351     ;; returns a `lambda'-expression
 352     `(lambda nil (interactive) (popup-menu (quote ,keymap)))))
 353
 354 (defun toolbarx-xemacs-mount-popup-menu
 355   (strings var type &optional title save)
 356   "Return an interactive `lambda'-expression that shows a popup menu.
 357 This function is the action of `toolbarx-mount-popup-menu' if
 358 inside XEmacs. See documentation of that function for more."
 359   (let* ((menu (if (and title (stringp title))
 360                    (list title)
 361                  (setq title nil)
 362                  (list "Dropdown menu")))
 363          (count 0)
 364          (menu-item)
 365          (menu-callback)
 366          (real-type (if (eq type 'toggle) 'toggle 'radio))
 367          (real-save (when save (if (eq save 'offer) 'offer 'always))))
 368     ;; warn if type is not `radio' ot `toggle'; use `radio' if incorrect.
 369     (unless (eq type real-type)
 370       (warn (concat "TYPE should be symbols `radio' or `toggle', "
 371                     "but %s found; using `radio'")
 372             type))
 373     ;; warn if save is not `nil', `offer' or `always'; use nil when incorrect
 374     (unless (eq save real-save)
 375       (setq real-save nil)
 376       (display-warning 'toolbarx
 377                        (format (concat "SAVE should be symbols `nil', "
 378                                        "`offer' or `always', but %s found; "
 379                                        "using `nil'")
 380                                save)))
 381     ;; making the menu list of vectors
 382     (dolist (str strings)
 383       (setq count (1+ count))
 384       (setq menu-callback (list 'progn
 385                                 (if (eq real-type 'radio)
 386                                     `(setq ,var ,count)
 387                                   `(if (memq ,count ,var)
 388                                        (setq ,var (delete ,count ,var))
 389                                      (setq ,var (sort (cons ,count ,var) '<))))
 390                                 '(toolbarx-refresh)))
 391       (when (eq real-save 'always)
 392         (setq menu-callback (append menu-callback
 393                                     (list (list 'customize-save-variable
 394                                                 (list 'quote var) var)))))
 395       (setq menu-item (vector str menu-callback
 396                               :style real-type
 397                               :selected (if (eq real-type 'radio)
 398                                              `(eq ,var ,count)
 399                                            `(memq ,count ,var))))
 400       (setq menu (append menu (list menu-item))))
 401     (when (eq real-save 'offer)
 402       (setq menu (append menu (list "--:shadowEtchedInDash")))
 403       (setq menu (append menu (list
 404                                (vector
 405                                 "Save state of this menu"
 406                                 `(customize-save-variable (quote ,var)
 407                                                           ,var))))))
 408     ;; returnung the lambda-expression
 409     `(lambda nil (interactive)
 410        (let ((popup-menu-titles ,(if title t nil)))
 411          (popup-menu (quote ,menu)))))))
 412
 413 (defun toolbarx-mount-popup-menu (strings var type &optional title save)
 414   "Return a command that show a popup menu.
 415 The return is a `lambda'-expression with a interactive declaration.
 416
 417 STRINGS is a list of strings which will be the itens of the menu.
 418
 419 VAR is a symbol that is set when an item is clicked.  TYPE should
 420 be one of the symbols `radio' or `toggle': `radio' means that the
 421 nth item is selected if VAR is `n' and this item sets VAR to `n';
 422 `toggle' means that VAR should be a list of integers and the nth
 423 item is selected if `n' belongs to VAR.  The item inserts or
 424 deletes `n' from VAR.
 425
 426 TITLE is a string (the title of the popup menu) or nil for no
 427 title.
 428
 429 SAVE is one of the symbols nil, `offer' or `always'.  If value
 430 is nil, do not try to save anything.  If it is `offer', a menu
 431 item is added offering the user the possibiity to save state of
 432 that dropdown menu for future sesseions (using `custom').  If it
 433 is `always', state is saved every time that a item is clicked."
 434   (if (featurep 'xemacs)
 435       (toolbarx-xemacs-mount-popup-menu strings var type title save)
 436     (toolbarx-emacs-mount-popup-menu strings var type title save)))
 437
 438 (defun toolbarx-option-value (opt)
 439   "Return option value according to Emacs flavour.
 440 If OPT is a vector, return first element if in Emacs or
 441 second if in XEmacs.  Otherwise, return OPT.
 442 If OPT is vector and length is smaller than the necessary (like
 443 if in XEmacs and vector has length 1), then nil is returned."
 444   (if (vectorp opt)
 445       (if (featurep 'xemacs)
 446           (when (> (length opt) 1)
 447             (aref opt 1))
 448         (when (> (length opt) 0)
 449           (aref opt 0)))
 450     opt))
 451
 452 (defun toolbarx-eval-function-or-symbol (object type-test-func)
 453   "Return a cons cell (GOOD-OBJ . VAL).
 454 GOOD-OBJ non-nil means that VAL is a valid value, according to
 455 the car of the result of TYPE-TEST-FUNCTION, that should return a
 456 cons cell in the same format as the return of this function.
 457
 458 If OBJECT applied to TYPE-TEST-FUNC return (GOOD-OBJ . VAL), and
 459 GOOD-OBJ is non-nil, return that.  Else, check if OBJECT is a
 460 function.  If so, evaluate and test again with TYPE-TEST-FUNC.  If
 461 not a function or if GOOD-OBJ is again nil, test if OBJECT is a
 462 bound symbol, evaluate that and return the result of
 463 TYPE-TEST-FUNC."
 464   (let* ((ret (funcall type-test-func object)))
 465     (unless (car ret)
 466       (if (functionp object)
 467           (progn
 468             (setq ret (funcall type-test-func (funcall object)))
 469             (unless (car ret)
 470               (when (and (symbolp object) (boundp object))
 471                 (setq ret (funcall type-test-func (symbol-value object))))))
 472         ;; ok, obj is not function; try symbol
 473         (when (and (symbolp object) (boundp object))
 474           (setq ret (funcall type-test-func (symbol-value object))))))
 475     ret))
 476
 477 (defun toolbarx-test-image-type (obj)
 478   "Return a cons cell (GOOD-OBJ . VAL).
 479 GOOD-OBJ is non-nil if OBJ yields a valid image object VAL (see
 480 documentation of function `toolbarx-process-symbol')."
 481   (let ((toolbarx-test-image-type-simple
 482          (lambda (img)
 483            (let* ((val (toolbarx-option-value img))
 484                   (all-obj-ok t)
 485                   (good-obj
 486                    (if (featurep 'xemacs)
 487                        ;; if XEmacs
 488                        (or (stringp val) ; a string
 489                            (glyphp val)  ; or a glyph
 490                            (and (symbolp val) ; or a symbol bound to a
 491                                 (boundp val)  ; glyph-list
 492                                 (check-toolbar-button-syntax
 493                                  (vector val
 494                                          (lambda nil (interactive))
 495                                          nil nil) t))
 496                            (and (listp val) ; or a glyph-or-string list
 497                                 (> (length val) 0)
 498                                 (< (length val) 7)
 499                                 (dolist (i val all-obj-ok)
 500                                   (setq all-obj-ok
 501                                         (and all-obj-ok
 502                                              (or (not i)
 503                                                  (stringp i)
 504                                                  (glyphp i)))))))
 505                      ;; if Emacs
 506                      (or (stringp val)    ; string
 507                          (and (consp val) ; or image descriptor
 508                               (eq (car val) 'image))
 509                          (and (symbolp val) ; or a symbol bound to a
 510                               (boundp val)  ; image descriptor
 511                                             ; (defined with `defimage')
 512                               (consp (eval val))
 513                               (eq (car (eval val)) 'image))
 514                          (and (listp val) ; or list with 4 strings or
 515                                           ; image descriptors
 516                               (= (length val) 4)
 517                               (dolist (i val all-obj-ok)
 518                                 (setq all-obj-ok
 519                                       (and all-obj-ok
 520                                            (or (stringp i)
 521                                                (and (consp i)
 522                                                     (eq (car i)
 523                                                         'image)))))))))))
 524              (cons good-obj val)))))
 525     (toolbarx-eval-function-or-symbol obj toolbarx-test-image-type-simple)))
 526
 527 (defun toolbarx-test-button-type (obj)
 528   "Return a cons cell (GOOD-OBJ . VAL).
 529 GOOD-OBJ is non-nil if OBJ yields a valid button object VAL (see
 530 documentation of function `toolbarx-process-symbol')."
 531   (let ((toolbarx-test-button-type-simple
 532          (lambda (but)
 533            (let* ((val (toolbarx-option-value but))
 534                   (good-obj (if (featurep 'xemacs)
 535                                 ;; if XEmacs
 536                                 t
 537                               ;; if Emacs
 538                               (and (consp val)
 539                                    (memq (car val) '(:toggle :radio))))))
 540              (cons good-obj val)))))
 541     (toolbarx-eval-function-or-symbol obj toolbarx-test-button-type-simple)))
 542
 543 (defun toolbarx-test-any-type (obj)
 544   "Return a cons cell (t . VAL).
 545 If OBJ is vector, return VAL according to editor.  Else, return
 546 OBJ, because it is a form anyway."
 547   (cons t (toolbarx-option-value obj)))
 548
 549 (defun toolbarx-test-string-or-nil (obj)
 550   "Return a cons cell (GOOD-OBJ . VAL).
 551 GOOD-OBJ is non-nil if OBJ yields a valid help object VAL (see
 552 documentation of function `toolbarx-process-symbol')."
 553   (let ((toolbarx-test-string-or-nil-simple
 554          (lambda (obj)
 555            (let* ((val (toolbarx-option-value obj))
 556                   (good-obj (or (stringp val)
 557                                 (not val))))
 558              (cons good-obj val)))))
 559     (toolbarx-eval-function-or-symbol obj toolbarx-test-string-or-nil-simple)))
 560
 561 (defun toolbarx-test-toolbar-type (obj)
 562   "Return a cons cell (GOOD-OBJ . VAL).
 563 GOOD-OBJ is non-nil if OBJ yields a valid toolbar property object
 564 VAL (see documentation of function `toolbarx-process-symbol')."
 565   (let ((toolbarx-test-toolbar-type-simple
 566          (lambda (obj)
 567            (let* ((val (toolbarx-option-value obj))
 568                   (all-but-def-opts '(top bottom left right))
 569                   (all-opts '(default top bottom left right))
 570                   (good-obj
 571                    (if (featurep 'xemacs)
 572                        ;; if XEmacs
 573                        (if (symbolp val)
 574                            (memq val all-opts)
 575                          (and (consp val)
 576                               (memq (car val) all-but-def-opts)
 577                               (memq (cdr val) all-but-def-opts)))
 578                      ;; if Emacs
 579                      t)))
 580              (cons good-obj val)))))
 581     (toolbarx-eval-function-or-symbol obj toolbarx-test-toolbar-type-simple)))
 582
 583 (defun toolbarx-test-dropdown-type (obj)
 584   "Return a cons cell (GOOD-OBJ . VAL).
 585 GOOD-OBJ is non-nil if OBJ yields a valid `:type' property object
 586 VAL of a dropdown group (see documentation of function
 587 `toolbarx-process-dropdown-group'."
 588   (let ((toolbarx-test-dropdown-type-simple
 589          (lambda (obj)
 590            (let* ((val (toolbarx-option-value obj))
 591                   (good-obj (memq val '(radio toggle))))
 592              (cons good-obj val)))))
 593     (toolbarx-eval-function-or-symbol obj toolbarx-test-dropdown-type-simple)))
 594
 595 (defun toolbarx-test-symbol (obj)
 596   "Return a cons cell (GOOD-OBJ . VAL).
 597 GOOD-OBJ is non-nil if OBJ yields a valid `:variable' property
 598 object VAL of a dropdown group (see documentation of function
 599 `toolbarx-process-dropdown-group'."
 600   (let ((toolbarx-test-symbol-simple
 601          (lambda (obj)
 602            (let* ((val (toolbarx-option-value obj))
 603                   (good-obj (symbolp val)))
 604              (cons good-obj val)))))
 605     (toolbarx-eval-function-or-symbol obj toolbarx-test-symbol-simple)))
 606
 607 (defun toolbarx-test-dropdown-default (obj)
 608   "Return a cons cell (GOOD-OBJ . VAL).
 609 GOOD-OBJ is non-nil if OBJ yields a valid `:default' property
 610 object VAL of a dropdown group (see documentation of function
 611 `toolbarx-process-dropdown-group'."
 612   (let ((toolbarx-test-dropdown-default-simple
 613          (lambda (obj)
 614            (let* ((val (toolbarx-option-value obj))
 615                   (good-obj (or (integerp val)
 616                                 (and (listp val)
 617                                      (let ((ok t))
 618                                        (dolist (i val ok)
 619                                          (setq ok (and ok (integerp i)))))))))
 620              (cons good-obj val)))))
 621     (toolbarx-eval-function-or-symbol obj
 622                                       toolbarx-test-dropdown-default-simple)))
 623
 624 (defun toolbarx-test-dropdown-save (obj)
 625   "Return a cons cell (GOOD-OBJ . VAL).
 626 GOOD-OBJ is non-nil if OBJ yields a valid `:save' property
 627 object VAL of a dropdown group (see documentation of function
 628 `toolbarx-process-dropdown-group'."
 629   (let ((toolbarx-test-dropdown-save-simple
 630          (lambda (obj)
 631            (let* ((val (toolbarx-option-value obj))
 632                   (good-obj (memq val '(nil offer always))))
 633              (cons good-obj val)))))
 634     (toolbarx-eval-function-or-symbol obj toolbarx-test-dropdown-save-simple)))
 635
 636 (defconst toolbarx-button-props
 637   (let* ((props-types-alist
 638           '((:image           toolbarx-test-image-type)
 639             (:command         toolbarx-test-any-type)
 640             (:enable          toolbarx-test-any-type)
 641             (:visible         toolbarx-test-any-type)
 642             (:help            toolbarx-test-string-or-nil)
 643             (:insert          toolbarx-test-any-type       . and)
 644             (:toolbar         toolbarx-test-toolbar-type)
 645             (:button          toolbarx-test-button-type)
 646             (:append-command  toolbarx-test-any-type       . progn)
 647             (:prepend-command toolbarx-test-any-type       . progn)))
 648          (possible-props (nreverse (let* ((props ()))
 649                                      (dolist (p props-types-alist props)
 650                                        (setq props (cons (car p) props))))))
 651          (props-override (nreverse (let* ((props ()))
 652                                      (dolist (p props-types-alist props)
 653                                        (unless (cddr p)
 654                                          (setq props (cons (car p) props)))))))
 655          (props-add (nreverse (let* ((props ()))
 656                                 (dolist (p props-types-alist props)
 657                                   (when (cddr p)
 658                                     (setq props (cons (car p) props))))))))
 659     (list props-types-alist possible-props props-override props-add))
 660   "List yielding all encarnations of properties of a button.
 661 First element: alist, where each element is of form
 662  (PROP . (TYPE-TEST-FUNCTION . ADD-OR-NIL))
 663 Second is a list with all properties.
 664 Third, a list with properties that override when merging.
 665 Fourth, a list of lists, each in the format (PROP ADD).")
 666
 667 (defconst toolbarx-dropdown-props
 668   ;; for naming dropdown properties see `Convention' in the doc string
 669   (let* ((props-types-alist
 670           '((:type                     toolbarx-test-dropdown-type)
 671             (:variable                 toolbarx-test-symbol)
 672             (:default                  toolbarx-test-dropdown-default)
 673             (:save                     toolbarx-test-dropdown-save)
 674             (:title                    toolbarx-test-string-or-nil)
 675             (:dropdown-image           toolbarx-test-image-type)
 676             (:dropdown-enable          toolbarx-test-any-type)
 677             (:dropdown-visible         toolbarx-test-any-type)
 678             (:dropdown-insert          toolbarx-test-any-type       . and)
 679             (:dropdown-help            toolbarx-test-string-or-nil)
 680             (:dropdown-toolbar         toolbarx-test-toolbar-type)
 681             (:dropdown-append-command  toolbarx-test-any-type       . progn)
 682             (:dropdown-prepend-command toolbarx-test-any-type       . progn)))
 683          (possible-props (nreverse (let* ((props ()))
 684                                      (dolist (p props-types-alist props)
 685                                        (setq props (cons (car p) props))))))
 686          (props-override (nreverse (let* ((props ()))
 687                                      (dolist (p props-types-alist props)
 688                                        (unless (cddr p)
 689                                          (setq props (cons (car p) props)))))))
 690          (props-add (nreverse (let* ((props ()))
 691                                 (dolist (p props-types-alist props)
 692                                   (when (cddr p)
 693                                     (setq props (cons (car p) props))))))))
 694     (list props-types-alist possible-props props-override props-add))
 695   "List yielding all encarnations of properties of a dropdown group.
 696 First element: alist, where each element is of form
 697  (PROP . (TYPE-TEST-FUNCTION . ADD-OR-NIL))
 698 Second is a list with all properties.
 699 Third, a list with properties that override when merging.
 700 Fourth, a list of lists, each in the format (PROP ADD).
 701
 702 Convention: properties for the dropdown button should be formed
 703 with the strings \":dropdown-\" with the button property name
 704 without `:'. This is used on the implementation.")
 705
 706 (defun toolbarx-process-group-without-insert (group-without-props
 707                                               merged-props-without-insert
 708                                               meaning-alist switches)
 709   "Return an updated version of SWITCHES.
 710 GROUP-WITHOUT-PROPS and MERGED-PROPS-WITHOUT-INSERT are
 711 preprocessed variables in `toolbarx-process-group'."
 712   (let ((current-switches switches))
 713     (dolist (i group-without-props current-switches)
 714       (setq i (toolbarx-option-value i))
 715       (if (symbolp i)
 716           (setq current-switches
 717                 (toolbarx-process-symbol i meaning-alist
 718                                          merged-props-without-insert
 719                                          current-switches))
 720         (when (listp i)
 721           (setq current-switches
 722                 (toolbarx-process-group i meaning-alist
 723                                         merged-props-without-insert
 724                                         current-switches)))))))
 725
 726 (defun toolbarx-process-group (group meaning-alist props switches)
 727   "Return an updated version of SWITCHES.
 728 Append to already processed buttons (stored in SWITCHES) a
 729 processed version of GROUP.  Groups are useful to distribute
 730 properties.  External properties are given in PROPS, and merged
 731 with the internal properties that are in the end of GROUP.  If
 732 properties (after merge) contain a `:insert' property, return a
 733 list where the first and second elements are `:insert' and its
 734 value, and after that a list in the same format as SWITCHES."
 735   (cond
 736    ;; if DROPDOWN group
 737    ((eq (car group) :dropdown-group)
 738     (toolbarx-process-dropdown-group group meaning-alist props switches))
 739    ;; if EVAL group
 740    ((eq (car group) :eval-group)
 741     (let ((current-switches switches))
 742       (dolist (elt (cdr group) current-switches)
 743         (let ((eval-elt (eval elt)))
 744           (setq current-switches
 745                 (toolbarx-process-group (if (listp eval-elt)
 746                                             eval-elt
 747                                           (list eval-elt))
 748                                         meaning-alist props
 749                                         current-switches))))))
 750    ;; if normal group
 751    (t
 752     (let* ((splited-props
 753             (toolbarx-separate-options
 754              group (append (nth 1 toolbarx-button-props)
 755                            (nth 1 toolbarx-dropdown-props))))
 756            (intern-props (cdr splited-props))
 757            (group-without-props (car splited-props))
 758            (merged-props
 759             (toolbarx-merge-props intern-props props
 760                                   (append (nth 2 toolbarx-button-props)
 761                                           (nth 2 toolbarx-dropdown-props))
 762                                   (append (nth 3 toolbarx-button-props)
 763                                           (nth 3 toolbarx-dropdown-props)))))
 764       ;; check whether merged props have an `:insert'
 765       (if (memq :insert merged-props)
 766           ;; if yes, prepend switches with a (:insert cond elements)
 767           (let* ((memq-ins (memq :insert merged-props))
 768                  (ins-val (if (and (listp (cadr memq-ins))
 769                                    (eq :add-value-list
 770                                        (car (cadr memq-ins))))
 771                               ;; if property is add-value property
 772                               (let* ((p (assq
 773                                          :insert
 774                                          (nth 0 toolbarx-button-props)))
 775                                      (add-list (list (cddr p)))
 776                                      (prop-good-val))
 777                                 (dolist (val (cdr (cadr memq-ins)))
 778                                   (setq prop-good-val (funcall (cadr p) val))
 779                                   (when (car prop-good-val)
 780                                     (setq add-list (cons (cdr prop-good-val)
 781                                                          add-list))))
 782                                 ;; return: (nreverse add-list)
 783                                 (setq add-list (nreverse add-list))
 784                                 (if (eq 2 (length add-list))
 785                                     (cadr add-list) ; just 1 value, no
 786                                   add-list))        ; add-function
 787                             ;; if property is not add-value
 788                             (cadr memq-ins)))
 789                  (merged-props-without-insert
 790                   (append (butlast merged-props (length memq-ins))
 791                           (cddr memq-ins)))
 792                  (group-switches
 793                   (toolbarx-process-group-without-insert
 794                    group-without-props merged-props-without-insert
 795                    meaning-alist nil)))
 796             ;; return
 797             (nreverse (cons (append (list :insert ins-val)
 798                                     group-switches)
 799                             (nreverse switches))))
 800         ;; if not, just append what is processed to switches
 801         (toolbarx-process-group-without-insert group-without-props
 802                                                merged-props meaning-alist
 803                                                switches))))))
 804
 805 (defun toolbarx-process-symbol (symbol meaning-alist props switches)
 806   "Process a button given by SYMBOL in MEANING-ALIST.
 807 The processed button is appended in SWITCHES, which is returned.
 808 Look for a association of SYMBOL in MEANING-ALIST for collecting
 809 properties.  Such association is a list that represents either a
 810 normal button (a description of the button) or an alias
 811 group (the symbol is an alias for a group of buttons).  PROPS is
 812 a externel list of properties that are merged and then applied to
 813 the button.  Scope is given by GLOBAL-FLAG."
 814   ;; there are 3 situations: symbol is :new-line, there is an alias group
 815   ;; or a normal button
 816   (let ((button-assq (cdr (assq symbol meaning-alist))))
 817     (cond
 818      ((eq (car button-assq) :alias)
 819       ;; button association is ALIAS GROUP is passed to
 820       ;; `toolbarx-process-group' as is but without the car.
 821       ;; return: (toolbarx-process-group... returns updates switch
 822       (toolbarx-process-group (cdr button-assq) meaning-alist props switches))
 823      (t
 824       ;; NORMAL BUTTON (association is a list of properties)
 825       ;;
 826       ;; properties need to be processed, that is, merge internal
 827       ;; and external (given by PROPS) properties
 828       (let* (;; button properties defined in `toolbarx-button-props'
 829              (props-override    (nth 2 toolbarx-button-props))
 830              (props-add         (nth 3 toolbarx-button-props))
 831              ;; split considering also dropdown-group properties
 832              (button-assq-split
 833               (toolbarx-separate-options
 834                button-assq
 835                (append (nth 1 toolbarx-button-props)
 836                        (nth 1 toolbarx-dropdown-props))))
 837              (button-split-no-props (car button-assq-split))
 838              (button-split-props (cdr button-assq-split))
 839              ;; if there is no :image or :command in the props,
 840              ;; try to get them from no-props part
 841              (button-image-no-prop
 842               (unless (memq :image button-split-props)
 843                 (when (> (length button-split-no-props) 0)
 844                   (list :image (nth 0 button-split-no-props)))))
 845              (button-command-no-prop
 846               (unless (memq :command button-split-props)
 847                 (when (> (length button-split-no-props) 1)
 848                   (list :command (nth 1 button-split-no-props)))))
 849              (button-props (append button-split-props
 850                                    button-image-no-prop
 851                                    button-command-no-prop))
 852              ;; merge props
 853              (merged-props (toolbarx-merge-props button-props props
 854                                                  props-override
 855                                                  props-add)))
 856         ;; return:
 857         (nreverse (cons (cons symbol merged-props) (nreverse switches))))))))
 858
 859 (defun toolbarx-process-dropdown-group (dropdown meaning-alist props switches)
 860   "Process buttons that appear according to dropdown menu.
 861 Process a dropdown group DROPDOWN with meaning alist
 862 MEANING-ALIST, external property list PROP and GLOBAL-FLAG
 863 specifying scope. For a complete description, see documentation
 864 of `toolbarx-install-toolbar'.  The processed buttons are stored
 865 in the end of SWITCHES, which is returned."
 866   (let* ((dropdown-group (if (eq (car dropdown) :dropdown-group)
 867                              (cdr dropdown)
 868                            dropdown))
 869          (dropdown-list-splited
 870           (toolbarx-separate-options dropdown-group
 871                                      (append
 872                                       (nth 1 toolbarx-button-props)
 873                                       (nth 1 toolbarx-dropdown-props))))
 874          (dropdown-list  (car dropdown-list-splited))
 875          (dropdown-props (cdr dropdown-list-splited))
 876          (merged-props
 877           (toolbarx-merge-props dropdown-props props
 878                                 (append (nth 2 toolbarx-button-props)
 879                                         (nth 2 toolbarx-dropdown-props))
 880                                 (append (nth 3 toolbarx-button-props)
 881                                         (nth 3 toolbarx-dropdown-props))))
 882          (merged-props-button-only
 883           (let* ((props-button-only)
 884                  (prop))
 885             (dolist (p (nth 1 toolbarx-button-props) props-button-only)
 886               (setq prop (memq p merged-props))
 887               (when prop
 888                 (setq props-button-only
 889                       (append (list p (cadr prop))
 890                               props-button-only))))))
 891          (merged-props-dropdown-only
 892           (let* ((props-dropdown-only)
 893                  (prop))
 894             (dolist (p (nth 1 toolbarx-dropdown-props) props-dropdown-only)
 895               (setq prop (memq p merged-props))
 896               (when prop
 897                 (setq props-dropdown-only
 898                       (append (list p (cadr prop))
 899                               props-dropdown-only))))))
 900          ;; get value for each property and check type ONLY for props that do
 901          ;; not concern the dropdown button, like `:type', `:save', etc. The
 902          ;; props that concern the button are going to be handled in refresh
 903          ;; time.
 904          (filtered-dropdown-group-props-only
 905           (let* ((filtered-props-temp)
 906                  (prop-good-val)
 907                  (prop))
 908             (save-match-data
 909               (dolist (p (nth 0 toolbarx-dropdown-props) filtered-props-temp)
 910                 (unless (string-match "^:dropdown-.*$"
 911                                       (symbol-name (car p)))
 912                   ;;    property           -> (car p)
 913                   ;;    test type function -> (cadr p)
 914                   (setq prop (memq (car p) merged-props-dropdown-only))
 915                   ;; if so, check if value is of correct type
 916                   (when prop
 917                     (setq prop-good-val (funcall (cadr p) (cadr prop)))
 918                     (if (car prop-good-val)
 919                         (setq filtered-props-temp
 920                               (append filtered-props-temp
 921                                       (list (car p) (cdr prop-good-val))))
 922                       (display-warning
 923                        'toolbarx
 924                        (format (concat "Wrong type for value in "
 925                                        "property `%s' in dropdown group")
 926                                (car p))))))))))
 927          ;; properties for the dropdown button from dropdown merged properties
 928          (dropdown-button-props
 929           (let* ((props))
 930             (save-match-data
 931               (dolist (pr (nth 1 toolbarx-dropdown-props))
 932                 (when (and (memq pr merged-props-dropdown-only)
 933                            (string-match "^:dropdown-\\(.*\\)$"
 934                                          (symbol-name pr)))
 935                   (let* ((new-pr (intern (concat ":"
 936                                                  (substring (symbol-name pr)
 937                                                             (match-beginning 1)
 938                                                             (match-end 1)))))
 939                          (val (cadr (memq pr merged-props-dropdown-only))))
 940                     (setq props (append (list new-pr val) props))))))
 941             (unless (memq :image props)
 942               (setq props (append (list :image "dropdown") props)))
 943             props))
 944          (dropdown-button-without-command
 945           (cons 'dropdown dropdown-button-props))
 946          ;; `:type' defaults to `radio'
 947          (type (if (memq :type filtered-dropdown-group-props-only)
 948                    (cadr (memq :type filtered-dropdown-group-props-only))
 949                  'radio))
 950          ;; `:default' defaults to 1 or nil depending on `type'
 951          ;; if type is toggle and default is not a list, but a
 952          ;; integer, set as the list with integer
 953          (default
 954            (let* ((memq-default (memq :default
 955                                       filtered-dropdown-group-props-only))
 956                   (def-temp (cadr memq-default))
 957                   (default-temp (if memq-default
 958                                     def-temp
 959                                   (if (eq type 'radio) 1 (list 1)))))
 960              default-temp))
 961          ;; `:save' defaults to nil and require `:variable'
 962          (save (let* ((save-temp
 963                        (when (memq :save filtered-dropdown-group-props-only)
 964                          (cadr (memq :save
 965                                      filtered-dropdown-group-props-only)))))
 966                  (if (and save-temp
 967                           (not (memq :variable
 968                                      filtered-dropdown-group-props-only)))
 969                      (progn
 970                        (display-warning
 971                         'toolbarx
 972                         (concat "`:save' property with non-nil value should "
 973                                 "be used only with the `:variable' property; "
 974                                 "using value nil for `:save'."))
 975                        nil)
 976                    save-temp)))
 977          ;; `:title' defaults to nil
 978          (title (when (memq :title filtered-dropdown-group-props-only)
 979                   (cadr (memq :title filtered-dropdown-group-props-only))))
 980          ;; the menu variable is buildt from the `:variable' option or
 981          ;; make a symbol not used
 982          (variable (if (memq :variable filtered-dropdown-group-props-only)
 983                        (cadr (memq :variable
 984                                    filtered-dropdown-group-props-only))
 985                      (let* ((count 0)
 986                             (symb (intern (format
 987                                            "toolbarx-internal-menu-var-%d"
 988                                            count))))
 989                        (while (boundp symb)
 990                          (setq count (1+ count))
 991                          (setq symb
 992                                (intern (format "toolbarx-internal-menu-var-%d"
 993                                                count))))
 994                        symb)))
 995          ;; auxiliary variables
 996          (list-strings)
 997          (list-buttons))
 998     ;; setting `variable'
 999     (if save
1000         (custom-declare-variable
1001          variable default
1002          "Used as variable of dropdown menu defined with `toolbarx'.")
1003       (when (not (boundp variable))
1004         (set variable default)))
1005     ;; now check `variable' content
1006     (set variable
1007          (let ((val (eval variable)))
1008            (if (eq type 'toggle)
1009                (if (listp val)
1010                    val
1011                  (if (integerp val)
1012                      (list val)
1013                    (list 1)))
1014              ;; then, type is radio
1015              (if (integerp val)
1016                  val
1017                (if (and val
1018                         (listp val)
1019                         (integerp (car val)))
1020                    (car val)
1021                  1)))))
1022     ;; === buiding `list-strings' and `list-buttons' ===
1023     ;; if only symbols, build `list-strings' and `list-buttons' from symbols
1024     (if (let ((only-symbols-flag t))
1025           (dolist (i dropdown-list only-symbols-flag)
1026             (setq only-symbols-flag (and only-symbols-flag (symbolp i)))))
1027         (let ((count 0))
1028           (dolist (i dropdown-list)
1029             ;; list-strings and list-buttons are buildt reversed
1030             (setq list-strings (cons (toolbarx-make-string-from-symbol i)
1031                                      list-strings))
1032             (setq count (1+ count))
1033             (setq list-buttons (cons (list i
1034                                            :insert
1035                                            (if (eq type 'radio)
1036                                                (list 'eq count variable)
1037                                              (list 'memq count variable)))
1038                                      list-buttons))))
1039       ;; if not, the it must start with string
1040       (unless (stringp (car dropdown-list))
1041         (error "%s %s %s"
1042                "If not all itens on dropdown are symbols, then a string"
1043                "must come before each set of buttons; no string found"
1044                "in first position."))
1045       (let ((count 0)
1046             (elem)
1047             (temp-list-buttons))
1048         (while dropdown-list
1049           (setq elem (car dropdown-list))
1050           (setq dropdown-list (cdr dropdown-list))
1051           (if (stringp elem)
1052               ;; if string, output `temp-list-buttons' and prepair it again
1053               (progn
1054                 ;; list-strings and list-buttons are buildt reversed
1055                 (setq list-strings (cons elem list-strings))
1056                 (when temp-list-buttons
1057                   (setq list-buttons (cons (append (nreverse temp-list-buttons)
1058                                                    (list :insert
1059                                                          (if (eq type 'radio)
1060                                                              (list 'eq count
1061                                                                    variable)
1062                                                            (list 'memq count
1063                                                                  variable))))
1064                                            list-buttons)))
1065                 (setq temp-list-buttons nil)
1066                 (setq count (1+ count)))
1067             ;; else, if not string, just insert it to `temp-list-buttons'
1068             ;; which is also buildt reversed
1069             (setq temp-list-buttons (cons elem temp-list-buttons))))
1070         ;; output last temp list, left behind
1071         (when temp-list-buttons
1072           (setq list-buttons (cons (append (nreverse
1073                                             temp-list-buttons)
1074                                            (list
1075                                             :insert (if (eq type 'radio)
1076                                                         (list 'eq count
1077                                                               variable)
1078                                                       (list 'memq count
1079                                                             variable))))
1080                                    list-buttons)))))
1081     ;; lists were made reversed (elements inserted at the beginning)
1082     (setq list-strings (nreverse list-strings))
1083     (setq list-buttons (nreverse list-buttons))
1084     ;; now, pass `list-buttons' as a group to `toolbarx-process-group'
1085     (let ((current-switches switches))
1086       (setq current-switches
1087             (toolbarx-process-group list-buttons meaning-alist
1088                                     merged-props ; pass non-processed props
1089                                     current-switches))
1090       (setq current-switches
1091             ;; outputing dropdown button
1092             (toolbarx-process-group (append dropdown-button-without-command
1093                                             (list :command
1094                                                   (toolbarx-mount-popup-menu
1095                                                    list-strings variable type
1096                                                    title save)))
1097                                     meaning-alist merged-props-button-only
1098                                     switches))
1099       current-switches)))
1100
1101
1102
1103 ;; Still functions `toolbarx-install-toolbar' and `toolbarx-refresh'to
1104 ;; complete the parsing engine.  Since they interface with other engines,
1105 ;; they must come in the end.
1106
1107 ;;; How a image is made, giving a string as (part of) file name.
1108
1109 ;; look at function `image-type-available-p' for Emacs !!!!
1110
1111 (defun toolbarx-find-image (image)
1112   "Return image descriptor or glyph for IMAGE.
1113 In Emacs, return an image descriptor for IMAGE.  In XEmacs,
1114 return a glyph.
1115
1116 IMAGE is string.  Usually IMAGE neither contains a directory nor
1117 an extension.  If the extension is omitted, `xpm', `xbm' and
1118 `pbm' are tried.  If the directory is omitted,
1119 `toolbarx-image-path' is searched."
1120   ;; `find-image' in Emacs 21 looks in `load-path' and `data-directory'.  In
1121   ;; Emacs 22, we have `image-load-path' which includes `load-path' and
1122   ;; `data-directory'.
1123   ;;
1124   ;; If there's some API in XEmacs to find the images, we should use it
1125   ;; instead of locate-library.
1126   ;;
1127   ;; Emacs 22 has locate-file, but the other Emacsen don't.  The
1128   ;; following should hopefully get us to all images ultimately.
1129
1130   (let ((file))
1131     (dolist (i '("" ".xpm" ".xbm" ".pbm"))
1132       (unless file
1133         (setq file (locate-library (concat image i) t toolbarx-image-path))))
1134     (if (featurep 'xemacs)
1135         (and file (make-glyph file))
1136       (if file
1137           (create-image file)
1138         (find-image `((:type xpm :file ,(concat image ".xpm"))
1139                       (:type xbm :file ,(concat image ".xbm"))
1140                       (:type pbm :file ,(concat image ".pbm"))))))))
1141
1142 ;; next variable interfaces between parsing and display engines
1143 (defvar toolbarx-internal-button-switches nil
1144   "Store the list of processed buttons, used by `toolbarx-refresh'.
1145 This variable can store different values for the different buffers.")
1146
1147 \f
1148 (toolbarx--if-when-compile (not (featurep 'xemacs))
1149 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1150 ;;; Second engine: display parsed buttons in Emacs
1151 (progn
1152 (defun toolbarx-emacs-add-button (button used-keys keymap)
1153   "Insert a button where BUTTON is its description.
1154 USED-KEYS should be a list of symbols, where the first element is
1155 `:used-symbols'.  This list should store the symbols of the
1156 buttons already inserted.  This list is changed by side effect.
1157 KEYMAP is the keymap where the menu-item corresponding to the
1158 tool-bal button is going to be inserted.  Insertion is made in
1159 the end of KEYMAP.
1160
1161 BUTTON should be a list of form (SYMBOL . PROP-LIST).  SYMBOL is
1162 a symbol that \"names\" this button.  PROP-LIST is a list in the
1163 format (PROP VAL ... PROP VAL).  The supported properties are
1164 `:image', `:command', `:append-command', `:prepend-command',
1165 `:help', `:enable', `:visible', `:button', `:insert' and
1166 `:toolbar'. For a description of properties, see documentation of
1167 function `toolbar-install-toolbar'."
1168   (let* ((symbol (nth 0 button))
1169          (used-keys-list (when used-keys
1170                            (cdr used-keys)))
1171          (filtered-props
1172           (let* ((filtered-props-temp)
1173                  (prop-good-val)
1174                  (prop))
1175             (dolist (p (nth 0 toolbarx-button-props) filtered-props-temp)
1176               ;;    property           -> (car p)
1177               ;;    test type function -> (cadr p)
1178               ;;    add-function       -> (cddr p)
1179               (setq prop (memq (car p) button))
1180               ;; if so, check if value is of correct type
1181               (when prop
1182                 ;; if property is of add-type, them the value is a list
1183                 ;; (:add-value-list VAL VAL). Each VAL should be checked.
1184                 (if (and (cddr p) (eq :add-value-list (car (cadr prop))))
1185                     (let* ((add-list (list (cddr p))))
1186                       (dolist (val (cdr (cadr prop)))
1187                         (setq prop-good-val (funcall (cadr p) val))
1188                         (when (car prop-good-val)
1189                           (setq add-list (cons (cdr prop-good-val) add-list))))
1190                       (setq add-list (nreverse add-list))
1191                       (when (eq 2 (length add-list)) ; just 1 value, no
1192                                                      ; add-function
1193                         (setq add-list (cadr add-list)))
1194                       (setq filtered-props-temp (append
1195                                                  (list (car p) add-list)
1196                                                  filtered-props-temp)))
1197                   ;; if override-property
1198                   (setq prop-good-val (funcall (cadr p) (cadr prop)))
1199                   (when (car prop-good-val)
1200                     (setq filtered-props-temp (append
1201                                                (list (car p)
1202                                                      (cdr prop-good-val))
1203                                                filtered-props-temp))))))))
1204          (insert (or (not (memq :insert filtered-props))
1205                      ;; (memq :insert filtered-props)
1206                      (eval (nth 1 (memq :insert filtered-props))))))
1207     (when insert
1208       (cond
1209        (t
1210         ;; symbol is not :new-line, therefore a normal button
1211         (let* ((image (cadr (memq :image filtered-props)))
1212                (image-descriptor
1213                 (when (memq :image filtered-props)
1214                   (cond
1215                    ((stringp image)     ; string
1216                     (toolbarx-find-image image))
1217                    ((and (consp image)  ; or image descriptor
1218                          (eq (car image) 'image))
1219                     image)
1220                    ((and (symbolp image) ; or a symbol bound to a
1221                          (boundp image)  ; image descriptor (defined
1222                                        ; with `defimage')g
1223                          (consp (eval image))
1224                          (eq (car (eval image)) 'image))
1225                     (eval image))
1226                    (t                   ; otherwise, must be a list
1227                                         ; with 4 strings or image
1228                                         ; descriptors
1229                     (apply 'vector (mapcar (lambda (img)
1230                                               (if (stringp img)
1231                                                   (toolbarx-find-image img)
1232                                                 img))
1233                                            image))))))
1234                (command
1235                 (let* ((com (nth 1 (memq :command filtered-props)))
1236                        (app (nth 1 (memq :append-command filtered-props)))
1237                        (prep (nth 1 (memq :prepend-command filtered-props))))
1238                   (when (or com app prep)
1239                     (toolbarx-make-command com prep app))))
1240                (help (cons (memq :help filtered-props)
1241                            (cadr (memq :help filtered-props))))
1242                (enable (cons (memq :enable filtered-props)
1243                              (cadr (memq :enable filtered-props))))
1244                (visible (cons (memq :visible filtered-props)
1245                               (cadr (memq :visible filtered-props))))
1246                (button (cons (memq :button filtered-props)
1247                              (cadr (memq :button filtered-props))))
1248                (menuitem (append
1249                           (list 'menu-item
1250                                 (toolbarx-make-string-from-symbol symbol)
1251                                 command
1252                                 :image image-descriptor)
1253                           (when (car help)
1254                             (list :help (cdr help)))
1255                           (when (car enable)
1256                             (list :enable (cdr enable)))
1257                           (when (car visible)
1258                             (list :visible (cdr visible)))
1259                           (when (car button)
1260                             (list :button (cdr button)))))
1261                (key-not-used
1262                 (let* ((count 0)
1263                        (symb symbol))
1264                   (while (memq symb used-keys-list)
1265                     (setq count (1+ count))
1266                     (setq symb (intern (format "%s-%d" symbol count))))
1267                   symb)))
1268           (when (and image-descriptor command)
1269             (setq used-keys-list (cons key-not-used used-keys-list))
1270             (define-key-after keymap
1271               (vector key-not-used) menuitem))))))
1272     (when used-keys (setcdr used-keys used-keys-list))))
1273
1274
1275 (defun toolbarx-emacs-refresh-process-button-or-insert-list (switches
1276                                                              used-keys
1277                                                              keymap)
1278   "Process SWITCHES, inserting buttons in `tool-bar-map'.
1279 If a button is actually a `:insert' clause group (if `car' is
1280 `:insert') and evaluation of `cdr' yields non-nil, process `cddr'
1281 recursively as SWITCHES.  USED-KEYS is a list which `car' is
1282 `:used-symbols' and which `cdr' is a list of symbols that have already
1283 been used as keys in the keymap `tool-bar-map'."
1284   (dolist (button switches)
1285     (if (eq (car button) :insert)
1286         (when (eval (cadr button))
1287           (toolbarx-emacs-refresh-process-button-or-insert-list (cddr button)
1288                                                                 used-keys
1289                                                                 keymap))
1290       (toolbarx-emacs-add-button button used-keys keymap))))
1291
1292
1293
1294 (defun toolbarx-emacs-refresh (&optional global-flag)
1295   "Refresh and redraw the toolbar in Emacs.
1296 If GLOBAL-FLAG is non-nil, the default value of toolbar switches
1297 is used and the default value of `toolbarx-map' is changed."
1298   (let* ((switches (if global-flag
1299                        (if (default-boundp 'toolbarx-internal-button-switches)
1300                            (default-value 'toolbarx-internal-button-switches)
1301                          toolbarx-internal-button-switches)
1302                      toolbarx-internal-button-switches))
1303          (used-keys (list :used-symbols nil))
1304          (tool-bar-map-temp (make-sparse-keymap)))
1305     (toolbarx-emacs-refresh-process-button-or-insert-list switches used-keys
1306                                                           tool-bar-map-temp)
1307     (if global-flag
1308         (setq-default tool-bar-map tool-bar-map-temp)
1309       (setq tool-bar-map tool-bar-map-temp)))))
1310
1311 \f
1312 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1313 ;;; Third engine: display parsed buttons in XEmacs
1314 (progn
1315 (defun toolbarx-xemacs-image-properties (image)
1316   "Return a list of properties of IMAGE.
1317 IMAGE should be a string or a list of one to six strings or
1318 glyphs or nil, or a symbol bound to a list of one to six
1319 glyphs (them must be a valid image list, like one created with
1320 the function `toolbar-make-button-list').  Return a
1321 list (GLYPH-LIST HEIGHT WIDTH) where HEIGHT (resp. WIDTH) is the
1322 maximum of the heights (resp. widths) of all glyphs (or strings
1323 converted to glyphs) in GLYPH-LIST.  If IMAGE is not a list, it
1324 is treated as a list with IMAGE as only element.  Strings are
1325 converted to glyphs with the function `toolbarx-find-image'.  If,
1326 after possible string-to-glyph convertions, the list of glyphs
1327 has nil as first element, GLYPH-LIST becomes nil."
1328   (let* ((glyph-list
1329           (if (symbolp image)           ; if symbol, them must be a
1330                                         ; valid image list, like
1331                                         ; created by function
1332                                         ; `toolbar-make-button-list'
1333               (eval image)
1334             (let ((img-list (if (listp image)
1335                                 image
1336                               (list image)))
1337                   (glyph-list-temp))
1338               ;; glyph-list-temp
1339               (setq glyph-list-temp
1340                     (dolist (glyph img-list (nreverse glyph-list-temp))
1341                       (if (stringp glyph)
1342                           (setq glyph-list-temp
1343                                 (cons (toolbarx-find-image glyph)
1344                                       glyph-list-temp))
1345                         (setq glyph-list-temp (cons glyph glyph-list-temp)))))
1346               (unless (car glyph-list-temp)
1347                 (setq glyph-list-temp nil))
1348               glyph-list-temp)))
1349          (usable-buttons
1350           ;; computing inheritage
1351           (let* ((usable-temp))
1352             (if toolbar-captioned-p     ; problematic point :-(
1353                 (progn
1354                   ;; CAP-UP:  cap-up -> up
1355                   (setq usable-temp (cons (cond
1356                                            ((nth 3 glyph-list))
1357                                            ((nth 0 glyph-list)))
1358                                           usable-temp))
1359                   ;; CAP-DOWN:  cap-down -> cap-up -> down -> up
1360                   (setq usable-temp (cons (cond
1361                                            ((nth 4 glyph-list))
1362                                            ((nth 3 glyph-list))
1363                                            ((nth 1 glyph-list))
1364                                            ((nth 0 glyph-list)))
1365                                           usable-temp))
1366                   ;; CAP-DISABLED:  cap-disabled -> cap-up -> disabled -> up
1367                   (setq usable-temp (cons (cond
1368                                            ((nth 5 glyph-list))
1369                                            ((nth 3 glyph-list))
1370                                            ((nth 2 glyph-list))
1371                                            ((nth 0 glyph-list)))
1372                                           usable-temp)))
1373               ;; UP:  up
1374               (setq usable-temp (cons (nth 0 glyph-list) usable-temp))
1375               ;; DOWN:  down -> up
1376               (setq usable-temp (cons (cond
1377                                        ((nth 1 glyph-list))
1378                                        ((nth 0 glyph-list)))
1379                                       usable-temp))
1380               ;; DISABLED:  disabled -> up
1381               (setq usable-temp (cons (cond
1382                                        ((nth 2 glyph-list))
1383                                        ((nth 0 glyph-list)))
1384                                       usable-temp)))
1385             usable-temp))
1386          (height (apply 'max 0 (mapcar (lambda (glyph)
1387                                          (if glyph
1388                                              (glyph-height glyph)
1389                                            0))
1390                                        usable-buttons)))
1391          (width (apply 'max 0 (mapcar (lambda (glyph)
1392                                         (if glyph
1393                                             (glyph-width glyph)
1394                                           0))
1395                                       usable-buttons))))
1396     (list (if (symbolp image) image glyph-list) height width)))
1397
1398
1399
1400 (defun toolbarx-xemacs-button-properties (button)
1401   "Return a list of properties of BUTTON.
1402 The result is either nil (if not to be inserted) or a list in the format
1403  (TOOLBAR HEIGHT WIDTH BUTTON-DESCRIPTION)
1404 where
1405
1406 TOOLBAR is one of the symbols `default', `top', `right', `bottom'
1407   or `left'.
1408
1409 HEIGHT and WIDTH are the maximal dimentions of all the glyphs
1410   involved.
1411
1412 BUTTON-DESCRIPTION is button definition in XEmacs; see the
1413   documentation of variable `default-toolbar'."
1414   (let* ((filtered-props
1415           (let* ((filtered-props-temp)
1416                  (prop-good-val)
1417                  (prop))
1418             (dolist (p (nth 0 toolbarx-button-props) filtered-props-temp)
1419               ;;    property           -> (car p)
1420               ;;    test type function -> (cadr p)
1421               ;;    add-function       -> (cddr p)
1422               (setq prop (memq (car p) button))
1423               ;; if so, check if value is of correct type
1424               (when prop
1425                 ;; if property is of add-type, them the value is a list
1426                 ;; (:add-value-list VAL VAL). Each VAL should be checked.
1427                 (if (and (cddr p) (eq :add-value-list (car (cadr prop))))
1428                     (let* ((add-list (list (cddr p))))
1429                       (dolist (val (cdr (cadr prop)))
1430                         (setq prop-good-val (funcall (cadr p) val))
1431                         (when (car prop-good-val)
1432                           (setq add-list (cons (cdr prop-good-val) add-list))))
1433                       (setq add-list (nreverse add-list))
1434                       (when (eq 2 (length add-list)) ; just 1 value, no
1435                                                      ; add-function
1436                         (setq add-list (cadr add-list)))
1437                       (setq filtered-props-temp (append
1438                                                  (list (car p) add-list)
1439                                                  filtered-props-temp)))
1440                   ;; if override-property
1441                   (setq prop-good-val (funcall (cadr p) (cadr prop)))
1442                   (when (car prop-good-val)
1443                     (setq filtered-props-temp (append
1444                                                (list (car p)
1445                                                      (cdr prop-good-val))
1446                                                filtered-props-temp))))))))
1447          (insert (or (not (memq :insert filtered-props))
1448                      ;; (memq :insert filtered-props) holds
1449                      (eval (nth 1 (memq :insert filtered-props))))))
1450     (when insert
1451       (let* ((image-props (toolbarx-xemacs-image-properties
1452                            (cadr (memq :image filtered-props))))
1453              (glyph-list (car image-props))
1454              (image-height (nth 1 image-props))
1455              (image-width (nth 2 image-props))
1456              (command
1457               (let* ((com (nth 1 (memq :command filtered-props)))
1458                      (app (nth 1 (memq :append-command filtered-props)))
1459                      (prep (nth 1 (memq :prepend-command filtered-props))))
1460                 (when (or com app prep)
1461                   (toolbarx-make-command com prep app))))
1462              ;; enable defaults to `t'
1463              (enable (if (memq :enable filtered-props)
1464                          (cadr (memq :enable filtered-props))
1465                        t))
1466             ;; help defaults to nil
1467              (help (when (memq :help filtered-props)
1468                      (cadr (memq :help filtered-props))))
1469              ;; toolbar defaults to `default'
1470              (toolbar-prop (cons (memq :toolbar filtered-props)
1471                                  (cadr (memq :toolbar filtered-props))))
1472              (toolbar (if (car toolbar-prop)
1473                           (if (symbolp (cdr toolbar-prop))
1474                               (cdr toolbar-prop)
1475                             ;; (cdr toolbar-prop) is cons cell
1476                             (if (eq (cadr toolbar-prop)
1477                                           (default-toolbar-position))
1478                                       (cddr toolbar-prop)
1479                                    (cadr toolbar-prop)))
1480                         'default)))
1481         (when glyph-list
1482           (list toolbar image-height image-width
1483                 (vector glyph-list command enable help)))))))
1484
1485 (defun toolbarx-xemacs-refresh-process-button-or-insert-list (switches
1486                                                               toolbar-props)
1487   "Process SWITCHES, returning an updated version of TOOLBAR-PROPS.
1488 TOOLBAR-PROPS should be a list with 12 elements, each one representing
1489 properties (in this order) `locale', `default', `top', `right',
1490 `bottom', `left', `default-height', `default-width', `top-height',
1491 `right-width', `bottom-height' and `left-width'.  The return is a list
1492 with the same properties updated.
1493
1494 NB: Buttons (vectors) are inserted in front of the lists
1495 represented by `default', `top', `right', `bottom' and `left', so
1496 the lists are built reversed."
1497   (let ((locale          (nth 0  toolbar-props))
1498         (default         (nth 1  toolbar-props))
1499         (top             (nth 2  toolbar-props))
1500         (right           (nth 3  toolbar-props))
1501         (bottom          (nth 4  toolbar-props))
1502         (left            (nth 5  toolbar-props))
1503         (default-height  (nth 6  toolbar-props))
1504         (default-width   (nth 7  toolbar-props))
1505         (top-height      (nth 8  toolbar-props))
1506         (right-width     (nth 9  toolbar-props))
1507         (bottom-height   (nth 10 toolbar-props))
1508         (left-width      (nth 11 toolbar-props))
1509         (toolbar-props-temp))
1510     (dolist (button switches)
1511       (if (eq (car button) :insert)
1512           (when (eval (cadr button))
1513             ;; if insert group, process `cddr'
1514             (progn
1515               (setq toolbar-props-temp
1516                     (toolbarx-xemacs-refresh-process-button-or-insert-list
1517                      (cddr button)
1518                      (list locale default top right bottom left
1519                            default-height default-width top-height
1520                            right-width bottom-height left-width)))
1521               (setq default        (nth 1  toolbar-props-temp))
1522               (setq top            (nth 2  toolbar-props-temp))
1523               (setq right          (nth 3  toolbar-props-temp))
1524               (setq bottom         (nth 4  toolbar-props-temp))
1525               (setq left           (nth 5  toolbar-props-temp))
1526               (setq default-height (nth 6  toolbar-props-temp))
1527               (setq default-width  (nth 7  toolbar-props-temp))
1528               (setq top-height     (nth 8  toolbar-props-temp))
1529               (setq right-width    (nth 9  toolbar-props-temp))
1530               (setq bottom-height  (nth 10 toolbar-props-temp))
1531               (setq left-width     (nth 11 toolbar-props-temp))))
1532         ;; else, if normal button
1533         (let* ((button-props (toolbarx-xemacs-button-properties button))
1534                (toolbar (nth 0 button-props))
1535                (height (nth 1 button-props))
1536                (width (nth 2 button-props))
1537                (button-description (nth 3 button-props)))
1538           (when button-props
1539             (cond
1540              ;; default
1541              ((eq toolbar 'default)
1542               (setq default (cons button-description default))
1543               (setq default-height (max default-height height))
1544               (setq default-width (max default-width width)))
1545              ;; top
1546              ((eq toolbar 'top)
1547               (setq top (cons button-description top))
1548               (setq top-height (max top-height height)))
1549              ;; right
1550              ((eq toolbar 'right)
1551               (setq right (cons button-description right))
1552               (setq right-width (max right-width width)))
1553              ;; bottom
1554              ((eq toolbar 'bottom)
1555               (setq bottom (cons button-description bottom))
1556               (setq bottom-height (max bottom-height height)))
1557              ;; left
1558              ((eq toolbar 'left)
1559               (setq left (cons button-description left))
1560               (setq left-width (max left-width width))))))))
1561     ;; return a list similar to toolbar-props
1562     (list locale default top right bottom left default-height
1563           default-width top-height right-width bottom-height left-width)))
1564
1565
1566 (defun toolbarx-xemacs-refresh (&optional global-flag)
1567   "Refresh the toolbar in XEmacs."
1568   (let* ((switches (if global-flag
1569                        (if (default-boundp 'toolbarx-internal-button-switches)
1570                            (default-value 'toolbarx-internal-button-switches)
1571                          toolbarx-internal-button-switches)
1572                      toolbarx-internal-button-switches))
1573          (locale  (if global-flag 'global (current-buffer)))
1574          (toolbar-init (list locale     ; locale
1575                              nil        ; default
1576                              nil        ; top
1577                              nil        ; right
1578                              nil        ; bottom
1579                              nil        ; left
1580                              0          ; default-height
1581                              0          ; default-width
1582                              0          ; top-height
1583                              0          ; right-width
1584                              0          ; bottom-height
1585                              0))        ; left-width
1586          (toolbar-props
1587           (toolbarx-xemacs-refresh-process-button-or-insert-list switches
1588                                                                  toolbar-init))
1589          ;; NB: Buttons (vectors) are inserted in front of the lists
1590          ;; represented by `default', `top', `right', `bottom' and
1591          ;; `left', so the lists are built reversed.
1592          (default         (nreverse (nth 1  toolbar-props)))
1593          (top             (nreverse (nth 2  toolbar-props)))
1594          (right           (nreverse (nth 3  toolbar-props)))
1595          (bottom          (nreverse (nth 4  toolbar-props)))
1596          (left            (nreverse (nth 5  toolbar-props)))
1597          (default-height  (nth 6  toolbar-props))
1598          (default-width   (nth 7  toolbar-props))
1599          (top-height      (nth 8  toolbar-props))
1600          (right-width     (nth 9  toolbar-props))
1601          (bottom-height   (nth 10 toolbar-props))
1602          (left-width      (nth 11 toolbar-props))
1603          (button-raised-border 2)
1604          (default-border (specifier-instance default-toolbar-border-width))
1605          (top-border (specifier-instance top-toolbar-border-width))
1606          (right-border (specifier-instance right-toolbar-border-width))
1607          (bottom-border (specifier-instance bottom-toolbar-border-width))
1608          (left-border (specifier-instance left-toolbar-border-width)))
1609     ;; adding borders
1610     (when default
1611       (setq default-height (+ (* 2 button-raised-border)
1612                               (* 2 default-border)
1613                               default-height))
1614       (setq default-width (+ (* 2 button-raised-border)
1615                              (* 2 default-border)
1616                              default-width)))
1617     (when top
1618       (setq top-height (+ (* 2 button-raised-border)
1619                           (* 2 top-border)
1620                           top-height)))
1621     (when right
1622       (setq right-width (+ (* 2 button-raised-border)
1623                            (* 2 right-border)
1624                            right-width)))
1625     (when bottom
1626       (setq bottom-height (+ (* 2 button-raised-border)
1627                              (* 2 bottom-border)
1628                              bottom-height)))
1629     (when left
1630       (setq left-width (+ (* 2 button-raised-border)
1631                           (* 2 left-border)
1632                           left-width)))
1633     ;; deal with specifiers
1634     ;; - remove all specifiers for toolbars witout buttons
1635     (if default
1636         (progn
1637           ;; Only activate the tool bar if it is already visible.
1638           (when toolbar-visible-p
1639             (set-specifier default-toolbar-visible-p (not (not default)) locale)
1640             (if (memq (default-toolbar-position) '(top bottom))
1641                 (set-specifier default-toolbar-height default-height locale)
1642               (set-specifier default-toolbar-width default-width locale)))
1643           (set-specifier default-toolbar default locale))
1644       (remove-specifier default-toolbar locale)
1645       (remove-specifier default-toolbar-visible-p locale)
1646       (remove-specifier default-toolbar-height locale)
1647       (remove-specifier default-toolbar-width locale))
1648     (if top
1649         (progn
1650           (set-specifier top-toolbar-visible-p (not (not top)) locale)
1651           (set-specifier top-toolbar-height top-height locale)
1652           (set-specifier top-toolbar top locale))
1653       (remove-specifier top-toolbar locale)
1654       (remove-specifier top-toolbar-visible-p locale)
1655       (remove-specifier top-toolbar-height locale))
1656     (if right
1657         (progn
1658           (set-specifier right-toolbar-visible-p (not (not right))
1659                          locale)
1660           (set-specifier right-toolbar-width right-width locale)
1661           (set-specifier right-toolbar right locale))
1662       (remove-specifier right-toolbar locale)
1663       (remove-specifier right-toolbar-visible-p locale)
1664       (remove-specifier right-toolbar-width locale))
1665     (if bottom
1666         (progn
1667           (set-specifier bottom-toolbar-visible-p (not (not bottom)) locale)
1668           (set-specifier bottom-toolbar-height bottom-height locale)
1669           (set-specifier bottom-toolbar bottom locale))
1670       (remove-specifier bottom-toolbar locale)
1671       (remove-specifier bottom-toolbar-visible-p locale)
1672       (remove-specifier bottom-toolbar-height locale))
1673     (if left
1674         (progn
1675           (set-specifier left-toolbar-visible-p (not (not left)) locale)
1676           (set-specifier left-toolbar-width left-width locale)
1677           (set-specifier left-toolbar left locale))
1678       (remove-specifier left-toolbar locale)
1679       (remove-specifier left-toolbar-visible-p locale)
1680       (remove-specifier left-toolbar-width locale))))))
1681
1682
1683 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1684 ;;; finishing parsing engine
1685
1686 (defun toolbarx-refresh (&optional global-flag)
1687   "Redraw the toolbar, peviously installed with `toolbarx'.
1688 Force global refresh if GLOBAL-FLAG is non-nil."
1689   (interactive "P")
1690   (if (featurep 'xemacs)
1691       (toolbarx-xemacs-refresh global-flag)
1692     (toolbarx-emacs-refresh global-flag)))
1693
1694 ;;;###autoload (autoload 'toolbarx-install-toolbar "toolbar-x")
1695
1696 (defun toolbarx-install-toolbar (buttons &optional meaning-alist global-flag)
1697   "Install toolbar buttons given in BUTTONS.
1698 Button properties are optionally given in MEANING-ALIST.  If
1699 GLOBAL-FLAG is non-nil, toolbar is installed globally (on every
1700 buffer that does not have a toolbar set locally).  BUTTONS is a
1701 list of format
1702   (ELEM ... ELEM . PROPS),
1703 where each ELEM is either
1704
1705  - a list in the same format od BUTTONS, which is going to be
1706    refered as a *group*; groups are used to distribute properties
1707    recursively to its elements; there are groups with special
1708    format for special purpose: *dropdown groups* and also *eval
1709    groups*.
1710
1711  - a symbol, which could be associated in MEANING-ALIST with a
1712    list of button properties (symbol + properties = a *button*)
1713    or associated to a special kind of group (an *alias group*).
1714
1715  - a vector, which elements are on the previous formats (but not
1716    another vector); this is useful to specify different
1717    ingredients to the toolbar depending if editor is Emacs or
1718    XEmacs; the first element will be used in Emacs; the second
1719    element is going to be used in XEmacs.
1720
1721 Meaning alist
1722 =============
1723
1724 MEANING-ALIST is a list where each element is in one of the
1725 formats (SYMB . BUTTON-PROPS-LIST) or (SYMB .  ALIAS-GROUP).
1726 BUTTON-PROPS-LIST is a list in one of the formats
1727   (IMAGE COMMAND PROP VAL PROP VAL ... PROP VAL)  or
1728   (PROP VAL PROP VAL ... PROP VAL).
1729 The IMAGE is going to be used as the `:image' property of the
1730 button (see button properties bellow), and COMMAND shall be used
1731 as the `:command' property of the button.  Each PROP is one of
1732 the button properties, and VAL is its respective value.
1733 ALIAS-GROUP is a list which first element is the symbol `:alias'
1734 and the cdr shall be processed as a group.
1735
1736 However, a symbol is not required to have an association in
1737 MEANING-ALIST, which is only a way to specify properties to a
1738 button.  One can use groups to specify properties.  Nil is a good
1739 MEANING-ALIST.
1740
1741 Buttons
1742 =======
1743
1744 A toolbar button in `toolbarx' is the set with a symbol and
1745 properties used to display the button, like a image and a command
1746 to call when the button is pressed (which are the minimal
1747 elements that a button should have.)  The supported properties
1748 for buttons and their `basic types' (see note on how values of
1749 properties are obtained!) are:
1750
1751  :image -- in Emacs, either a string or image descriptor (see
1752    info for a definition), or a variable bound to a image
1753    descriptor (like those defined with `defimage') or a list of 4
1754    strings or image descriptors; in XEmacs, either a string or a
1755    glyph, or a symbol bount to a glyph, or a list of at least 1
1756    and at most 6 strings or glyphs or nil (not the first element
1757    though); defines the image file displayed by the button.  If
1758    it is a string, the image file found with that name (always
1759    using the function `toolbarx-find-image' to make the
1760    \`internal\' image descriptor) is used as button image.  For
1761    the other formats, the button image is handled in the same way
1762    as it is treated by the editors; see info nodes bellow for a
1763    description of the capabilities of each editor
1764       Emacs: info file \"elisp\", node \"Tool Bar\" (see `:image'
1765              property);
1766              PS: a *vector* of four strings is used in the Emacs
1767              Lisp documentation as the `more ellaborated' image
1768              property format, but here we reserve vectors to
1769              provide editor-dependent values; this motivates our
1770              choice for a list instead of vector (however,
1771              internally the list becomes a vector when displaying
1772              the button).
1773      XEmacs: info file \"lispref\", node \"Toolbar Descriptor
1774              Format\" (see GLYPH-LIST) or the documentation of
1775              the variable `default-toolbar'; check the inheritage
1776              in case of a ommited glyph or nil instead of glyph.
1777
1778  :command -- a form; if the form happens to be a command, it will
1779    be called with `call-interactively'.
1780
1781  :append-command -- a form added to the end of the value of
1782    `:command'.
1783
1784  :prepend-command -- a form added at the beginning of the value
1785    of `:command'.
1786
1787  :help -- either a string or nil; defined the help string of the
1788    button;
1789
1790  :enable -- a form, evaluated constantly by both editors to
1791    determine if a button is active (enabled) or not.
1792
1793  :visible -- in Emacs, a form that is evaluated constantly to
1794    determine if a button is visible; in XEmacs, this property is
1795    ignored.
1796
1797  :button -- in Emacs, a cons cell (TYPE .  SELECTED) where the
1798    TYPE should be `:toggle' or `:radio' and the cdr should be a
1799    form.  SELECTED is evaluated to determine when the button is
1800    selected.  This property is ignored in XEmacs.
1801
1802  :insert -- a form that is evaluated every time that the toolbar
1803    is refresh (a call of `toolbarx-refresh') to determine if the
1804    button is inserted or just ignored (until next refresh).
1805
1806  :toolbar -- in XEmacs, either one of the symbols `default',
1807    `top', `bottom', `left', `right', or a cons cell
1808    (POS . POS-AVOID-DEFAULT) where POS and POS-AVOID-DEFAULT
1809    should be one of the symbols `top', `bottom', `left', `right';
1810    if a symbol, the button will be inserted in one of these
1811    toolbars; if a cons cell, button will be inserted in toolbar
1812    POS unless the position of the default toolbar is POS (then,
1813    the default toolbar would override the position-specific
1814    toolbar), and in this case, button will be inserted in toolbar
1815    POS-AVOID-DEFAULT; in Emacs, this property is meaningless, and
1816    therefore ignored.  Hint of use of this property: in a
1817    program, use or everything with `default' and the cons format
1818    to avoid the default toolbar, or use only the position
1819    specific buttons (symbols that are not `default'), because of
1820    the `overriding' system in XEmacs, when a position-specific
1821    toolbar overrides the default toolbar; for instance, if you
1822    put a button in the default toolbar and another in the top
1823    toolbar (and the default toolbar is in the top), then *only*
1824    the ones in the top toolbar will be visible!
1825
1826 How to specify a button
1827 =======================
1828
1829 One can specify a button by its symbol or by a group to specify
1830 properties.  For example,
1831   BUTTON =
1832     ( foo
1833       (bar :image [\"bar-Emacs\" \"bar-XEmacs\"]
1834            :command bar-function :help \"Bar help string\")
1835       :insert foo-bar )
1836   MEANING-ALIST = ( (foo :image \"foo\" :command foo-function) )
1837 specifiy two buttons `foo' and `bar', each one with its necessary
1838 :image and :command properties, and both use the :insert property
1839 specified ate the end of BUTTONS (because groups distribute
1840 properties to all its elements).  `foo' and `bar' will be
1841 inserted only if `foo-bar' evaluation yields non-nil.  `bar' used
1842 a different :image property depending if editor is Emacs or
1843 XEmacs.
1844
1845 Note on how values of properties are obtained
1846 =============================================
1847
1848 For each property PROP, its value should be either:
1849    i) a vector of 2 elements; then each element should be of the
1850       basic type of PROP.
1851   ii) an element on the basic type of PROP.
1852  iii) a function (that does not need arguments); it is evaluated
1853       and the return should be ot type i) or ii) above
1854   iv) a symbol bound to a element of type i) or ii).
1855
1856 The type is cheched in the order i), ii) iii) and iv).  This
1857 evaluations are done every time that the oolbar is refresh.
1858
1859 Ps.: in order to specify a vector as value of a property (like
1860 the :image in Emacs), it is necessary to provide the vector as
1861 element of another vector.
1862
1863 Special groups
1864 ==============
1865
1866 Eval groups
1867 -----------
1868
1869 If the first element of a group is the symbol `:eval-group', each
1870 element is evaluated (with `eval'), put inside a list and
1871 processed like a group.  Eval groups are useful to store
1872 definition of buttons in a variable.
1873
1874 Dropdown groups
1875 ---------------
1876
1877 The idea is to specify a set of buttons that appear when a
1878 determined menu item of a dropdown menu is active.  The dropdown
1879 menu appears when a button (by default with a triangle pointing
1880 down) is clicked.  This button is called `dropdown button'.  The
1881 dropdown button appears on the left of the currently visible
1882 buttons of the dropdown group.
1883
1884 A dropdown group is a list which first element is the symbol
1885 `:dropdown-group' and in one of the following formats
1886   (:dropdown-group SYMBOL-1 ... SYMBOL-n  PROP-1 VAL-1 ... PROP-k VAL-k)
1887 or
1888   (:dropdown-group
1889      STRING-1 ITEM-11 ... ITEM-1n
1890      STRING-2 ITEM-21 ... ITEM-2m
1891            . . .
1892      STRING-n ITEM-n1 ... ITEM-np
1893        PROP-1 VAL-1 ... PROP-j VAL-j)
1894 where
1895  SYMBOL-* is a symbol that defines a button in MEANING-ALIST;
1896  STRING-* is a string that will appear in the dropdown menu;
1897  ITEM-* is any format that define buttons or groups.
1898
1899 \(a dropdown group of first format is internally converted to the
1900 second by making strings from the symbols and each symbol is the
1901 item)
1902
1903 The same rules for obtaining property values, described above,
1904 apply here.  Properties are also distributed by groups.  The
1905 supported properties and their basic type are:
1906
1907  :type -- one of the symbols `radio' (default) or `toggle'; if
1908    type is radio, only one of the itens may be active, and if
1909    type is toggle, any item number of itens can be active.
1910
1911  :variable -- a symbol; it is the variable that govern the
1912    dropdown button; every time the value should be an integer
1913    starting from 1 (if type is radio) or a list of integers (if
1914    type is toggle).  The Nth set of buttons is :insert'ed.
1915
1916  :default -- determines the default value when the menu is
1917    installed; it is ignored if a value was saved with custom; it
1918    defaults to 1 if type is radio or nil if type is toggle.  If
1919    value is a integer and type is `toggle', value used is a list
1920    with that integer.
1921
1922  :save -- one of the symbols nil (default), `offer' or
1923    `always'; determined if it is possible for the user to save
1924    the which menu itens are active, for a next session.  If value
1925    is `offer', a item (offering to save) is added to the
1926    popup menu.  If the value is `always', every time that a item
1927    is selected, the variable is saved.  If value is nil, variable
1928    shall not be saved.  If value is non-nil then `:variable' is
1929    mandatory.
1930
1931  :title -- a string or nil; if a string, the popup menu will show
1932    is as menu title; if nil, no title is shown.
1933
1934  :dropdown-help -- a string or nil; the help string of the
1935    dropdown button.
1936
1937  :dropdown-image -- in Emacs, either a string or a vector of 4
1938    strings; in XEmacs, either a string or a glyph or a list of at
1939    least 1 and at most 6 strings or glyphs; defines the image
1940    file displayed by the dropdown button; by default, it is the
1941    string \"dropdown\".
1942
1943  :dropdown-append-command,
1944  :dropdownprepend-command -- a form; append or prepend forms to
1945    the command that shows the dropdown menu, allowing extra code
1946    to run before or after the menu appears (remember that every
1947    menu item clicked refresh the toolbar.)
1948
1949  :dropdown-enable -- a form; evaluated constantly by both editors
1950    to determine if the dropdown button is active (enabled) or
1951    not.
1952
1953  :dropdown-visible -- a form; in Emacs, it is evaluated
1954    constantly to determine if the dropdown button is visible; in
1955    XEmacs, this property is ignored.
1956
1957  :dropdown-toolbar -- in XEmacs, one of the symbols `default',
1958    `opposite', `top', `bottom', `left' or `right'; ignored in
1959    Emacs; in XEmacs, the toolbar where the dropdown button will
1960    appear.
1961
1962 Also, if the symbol `dropdown' is associted in MEANING-ALIST
1963 with some properties, these properties override (or add) with
1964 higher precedence.
1965
1966 Special buttons
1967 ===============
1968
1969 If the symbol of a button is `:new-line', it is inserted
1970 a (faked) return, and the next button will be displayed a next
1971 line of buttons.  The only property supported for this button is
1972 `:insert'.  This feature is available only in Emacs.  In XEmacs,
1973 this button is ignored."
1974   (let ((switches (toolbarx-process-group buttons meaning-alist nil nil)))
1975     (if global-flag
1976         (setq-default toolbarx-internal-button-switches
1977                       switches)
1978       (set (make-local-variable 'toolbarx-internal-button-switches)
1979            switches)
1980       (unless (featurep 'xemacs)
1981         (make-local-variable 'tool-bar-map))))
1982   (toolbarx-refresh global-flag))
1983
1984
1985 (defconst toolbarx-default-toolbar-meaning-alist
1986   `((separator :image "sep" :command t :enable nil :help "")
1987
1988     (,(if (and (not (featurep 'xemacs)) (>= emacs-major-version 22))
1989           'new-file
1990         'open-file)
1991      :image ["new" toolbar-file-icon]
1992      :command [find-file toolbar-open]
1993      :enable [(not (window-minibuffer-p
1994                     (frame-selected-window menu-updating-frame)))
1995               t]
1996      :help ["Specify a new file's name, to edit the file" "Visit new file"])
1997
1998     ,(when (and (not (featurep 'xemacs)) (>= emacs-major-version 22))
1999        '(open-file :image ["open" toolbar-file-icon]
2000                    :command [menu-find-file-existing toolbar-open]
2001                    :enable [(not (window-minibuffer-p
2002                                   (frame-selected-window menu-updating-frame)))
2003                             t]
2004                    :help ["Read a file into an Emacs buffer" "Open a file"]))
2005
2006     (dired :image [,(if (>= emacs-major-version 22)
2007                         "diropen"
2008                       "open")
2009                    toolbar-folder-icon]
2010            :command [dired toolbar-dired]
2011            :help ["Read a directory, operate on its files" "Edit a directory"])
2012
2013     (save-buffer :image ["save" toolbar-disk-icon]
2014                  :command [save-buffer toolbar-save]
2015                  :enable [(and
2016                            (buffer-modified-p)
2017                            (buffer-file-name)
2018                            (not (window-minibuffer-p
2019                                  (frame-selected-window menu-updating-frame))))
2020                           t]
2021                  :help ["Save current buffer to its file"  "Save buffer"]
2022                  :visible (or buffer-file-name
2023                               (not (eq 'special
2024                                        (get major-mode 'mode-class)))))
2025
2026     ;; Emacs only
2027     (write-file :image "saveas"
2028                 :command write-file
2029                 :enable (not
2030                          (window-minibuffer-p
2031                           (frame-selected-window menu-updating-frame)))
2032                 :insert [t nil]
2033                 :help "Write current buffer to another file"
2034                 :visible (or buffer-file-name
2035                              (not (eq 'special (get major-mode 'mode-class)))))
2036
2037     (undo :image ["undo" toolbar-undo-icon]
2038           :command [undo toolbar-undo]
2039           :enable [(and (not buffer-read-only)
2040                         (not (eq t buffer-undo-list))
2041                         (if (eq last-command 'undo)
2042                             pending-undo-list
2043                           (consp buffer-undo-list)))
2044                    t]
2045           :help ["Undo last operation" "Undo edit"]
2046           :visible (not (eq 'special (get major-mode 'mode-class))))
2047
2048     (cut :image ["cut" toolbar-cut-icon]
2049          :help ["Delete text in region and copy it to the clipboard"
2050                 "Kill region"]
2051          :command [clipboard-kill-region toolbar-cut]
2052          :visible (not (eq 'special (get major-mode 'mode-class))))
2053
2054     (copy :image ["copy" toolbar-copy-icon]
2055           :help ["Copy text in region to the clipboard" "Copy region"]
2056           :command [clipboard-kill-ring-save toolbar-copy])
2057
2058     (paste :image ["paste" toolbar-paste-icon]
2059            :help ["Paste text from clipboard" "Paste from clipboard"]
2060            :command [clipboard-yank toolbar-paste]
2061            :visible (not (eq 'special (get major-mode 'mode-class))))
2062
2063     ;; Emacs only
2064     (search-forward :command nonincremental-search-forward
2065                     :help "Search forward for a string"
2066                     :image "search"
2067                     :insert [t nil])
2068
2069     (search-replace
2070      :image ["search-replace" toolbar-replace-icon]
2071      :command [query-replace toolbar-replace]
2072      :help ["Replace string interactively, ask about each occurrence"
2073             "Search & Replace"])
2074
2075     (print-buffer :image ["print" toolbar-printer-icon]
2076                   :command [print-buffer toolbar-print]
2077                   :help ["Print current buffer with page headings"
2078                          "Print buffer"])
2079
2080     ;; Emacs only
2081     (customize :image "preferences"
2082                :command customize
2083                :help "Edit preferences (customize)"
2084                :insert [t nil])
2085
2086     ;; Emacs only
2087     (help :image "help"
2088           :command (lambda () (interactive) (popup-menu menu-bar-help-menu))
2089           :help "Pop up the Help menu"
2090           :insert [t nil])
2091
2092     ;; Emacs only
2093     (kill-buffer :command kill-this-buffer
2094                  :enable (kill-this-buffer-enabled-p)
2095                  :help "Discard current buffer"
2096                  :image "close"
2097                  :insert [t nil])
2098
2099     ;; Emacs only
2100     (exit-emacs :image "exit"
2101                 :command save-buffers-kill-emacs
2102                 :help "Offer to save unsaved buffers, then exit Emacs"
2103                 :insert [t nil])
2104
2105     (spell-buffer :image ["spell" toolbar-spell-icon]
2106                   :command [ispell-buffer toolbar-ispell]
2107                   :help ["Check spelling of selected buffer" "Check spelling"])
2108
2109     (info :image ["info" toolbar-info-icon]
2110           :command [info toolbar-info]
2111           :help ["Enter Info, the documentation browser" "Info documentation"])
2112
2113     ;; XEmacs only
2114     (mail :image toolbar-mail-icon
2115           :command toolbar-mail
2116           :help "Read mail"
2117           :insert [nil t])
2118
2119     ;; XEmacs only
2120     (compile :image toolbar-compile-icon
2121              :command toolbar-compile
2122              :help "Start a compilation"
2123              :insert [nil t])
2124
2125     ;; XEmacs only
2126     (debug :image toolbar-debug-icon
2127            :command toolbar-debug
2128            :help "Start a debugger"
2129            :insert [nil t])
2130
2131     ;; XEmacs only
2132     (news :image toolbar-news-icon
2133           :command toolbar-news
2134           :help "Read news"
2135           :insert [nil t]))
2136   "A meaning alist with definition of the default buttons.
2137 The following buttons are available:
2138
2139 * Both Emacs and XEmacs: `open-file', `dired', `save-buffer',
2140   `undo', `cut', `copy', `paste', `search-replace', `print-buffer',
2141   `spell-buffer', `info'.
2142
2143 * Emacs only: `new-file' (Emacs 22+) `write-file', `search-forward',
2144   `customize', `help', `kill-buffer', `exit-emacs'.
2145
2146 * XEmacs only: `mail', `compile', `debug', `news'.
2147
2148 To reproduce the default toolbar in both editors with use as BUTTON
2149 in `toolbarx-install-toolbar':
2150
2151 \(toolbarx-install-toolbar
2152  '([(open-file dired kill-buffer save-buffer write-file undo cut
2153                copy paste search-forward print-buffer customize help)
2154     (open-file dired save-buffer print-buffer cut copy paste undo
2155                spell-buffer search-replace mail info compile debug news)])
2156  toolbarx-default-toolbar-meaning-alist)
2157
2158 Ps.: there are more buttons available than suggested in the
2159 expression above.")
2160
2161 (provide 'toolbar-x)
2162
2163 ;;; toolbar-x.el ends here