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