cgit.sxemacs.org Git - packages/blob - xemacs-packages/vm/lisp/vm-toolbar.el

   1 ;;; vm-toolbar.el --- Toolbar related functions and commands
   2 ;;
   3 ;; Copyright (C) 1995-1997, 2000, 2001 Kyle E. Jones
   4 ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk
   5 ;;
   6 ;; This program is free software; you can redistribute it and/or modify
   7 ;; it under the terms of the GNU General Public License as published by
   8 ;; the Free Software Foundation; either version 2 of the License, or
   9 ;; (at your option) any later version.
  10 ;;
  11 ;; This program is distributed in the hope that it will be useful,
  12 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;; GNU General Public License for more details.
  15 ;;
  16 ;; You should have received a copy of the GNU General Public License along
  17 ;; with this program; if not, write to the Free Software Foundation, Inc.,
  18 ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  19
  20 ;;; Code:
  21 (defvar vm-toolbar-specifier nil)
  22
  23 (defvar vm-toolbar-next-button
  24   [vm-toolbar-next-icon
  25    vm-toolbar-next-command
  26    (vm-toolbar-any-messages-p)
  27    "Go to the next message.\n
  28 The command `vm-toolbar-next-command' is run, which is normally
  29 fbound to `vm-next-message'.
  30 You can make this button run some other command by using a Lisp
  31 s-expression like this one in your .vm file:
  32    (fset 'vm-toolbar-next-command 'some-other-command)"])
  33 (defvar vm-toolbar-next-icon nil)
  34 (or (fboundp 'vm-toolbar-next-command)
  35     (fset 'vm-toolbar-next-command 'vm-next-message))
  36
  37 (defvar vm-toolbar-previous-button
  38   [vm-toolbar-previous-icon
  39    vm-toolbar-previous-command
  40    (vm-toolbar-any-messages-p)
  41    "Go to the previous message.\n
  42 The command `vm-toolbar-previous-command' is run, which is normally
  43 fbound to `vm-previous-message'.
  44 You can make this button run some other command by using a Lisp
  45 s-expression like this one in your .vm file:
  46    (fset 'vm-toolbar-previous-command 'some-other-command)"])
  47 (defvar vm-toolbar-previous-icon nil)
  48 (or (fboundp 'vm-toolbar-previous-command)
  49     (fset 'vm-toolbar-previous-command 'vm-previous-message))
  50
  51 (defvar vm-toolbar-autofile-button
  52   [vm-toolbar-autofile-icon
  53    vm-toolbar-autofile-message
  54    (vm-toolbar-can-autofile-p)
  55   "Save the current message to a folder selected using vm-auto-folder-alist."])
  56 (defvar vm-toolbar-autofile-icon nil)
  57
  58 (defvar vm-toolbar-file-button
  59   [vm-toolbar-file-icon vm-toolbar-file-command (vm-toolbar-any-messages-p)
  60    "Save the current message to a folder.\n
  61 The command `vm-toolbar-file-command' is run, which is normally
  62 fbound to `vm-save-message'.
  63 You can make this button run some other command by using a Lisp
  64 s-expression like this one in your .vm file:
  65    (fset 'vm-toolbar-file-command 'some-other-command)"])
  66 (defvar vm-toolbar-file-icon nil)
  67 (or (fboundp 'vm-toolbar-file-command)
  68     (fset 'vm-toolbar-file-command 'vm-save-message))
  69
  70 (defvar vm-toolbar-getmail-button
  71   [vm-toolbar-getmail-icon vm-toolbar-getmail-command
  72    (vm-toolbar-mail-waiting-p)
  73    "Retrieve spooled mail for the current folder.\n
  74 The command `vm-toolbar-getmail-command' is run, which is normally
  75 fbound to `vm-get-new-mail'.
  76 You can make this button run some other command by using a Lisp
  77 s-expression like this one in your .vm file:
  78    (fset 'vm-toolbar-getmail-command 'some-other-command)"])
  79 (defvar vm-toolbar-getmail-icon nil)
  80 (or (fboundp 'vm-toolbar-getmail-command)
  81     (fset 'vm-toolbar-getmail-command 'vm-get-new-mail))
  82
  83 (defvar vm-toolbar-print-button
  84   [vm-toolbar-print-icon
  85    vm-toolbar-print-command
  86    (vm-toolbar-any-messages-p)
  87    "Print the current message.\n
  88 The command `vm-toolbar-print-command' is run, which is normally
  89 fbound to `vm-print-message'.
  90 You can make this button run some other command by using a Lisp
  91 s-expression like this one in your .vm file:
  92    (fset 'vm-toolbar-print-command 'some-other-command)"])
  93 (defvar vm-toolbar-print-icon nil)
  94 (or (fboundp 'vm-toolbar-print-command)
  95     (fset 'vm-toolbar-print-command 'vm-print-message))
  96
  97 (defvar vm-toolbar-visit-button
  98   [vm-toolbar-visit-icon vm-toolbar-visit-command t
  99    "Visit a different folder.\n
 100 The command `vm-toolbar-visit-command' is run, which is normally
 101 fbound to `vm-visit-folder'.
 102 You can make this button run some other command by using a Lisp
 103 s-expression like this one in your .vm file:
 104    (fset 'vm-toolbar-visit-command 'some-other-command)"])
 105 (defvar vm-toolbar-visit-icon nil)
 106 (or (fboundp 'vm-toolbar-visit-command)
 107     (fset 'vm-toolbar-visit-command 'vm-visit-folder))
 108
 109 (defvar vm-toolbar-reply-button
 110   [vm-toolbar-reply-icon
 111    vm-toolbar-reply-command
 112    (vm-toolbar-any-messages-p)
 113    "Reply to the current message.\n
 114 The command `vm-toolbar-reply-command' is run, which is normally
 115 fbound to `vm-followup-include-text'.
 116 You can make this button run some other command by using a Lisp
 117 s-expression like this one in your .vm file:
 118    (fset 'vm-toolbar-reply-command 'some-other-command)"])
 119 (defvar vm-toolbar-reply-icon nil)
 120 (or (fboundp 'vm-toolbar-reply-command)
 121     (fset 'vm-toolbar-reply-command 'vm-followup-include-text))
 122
 123 (defvar vm-toolbar-forward-button
 124   [vm-toolbar-forward-icon
 125    vm-toolbar-forward-command
 126    (vm-toolbar-any-messages-p)
 127    "Forward the current message.\n
 128 The command `vm-toolbar-forward-command' is run, which is normally
 129 fbound to `vm-forward-message'.
 130 You can make this button run some other command by using a Lisp
 131 s-expression like this one in your .vm file:
 132    (fset 'vm-toolbar-forward-command 'some-other-command)"])
 133 (defvar vm-toolbar-forward-icon nil)
 134 (or (fboundp 'vm-toolbar-forward-command)
 135     (fset 'vm-toolbar-forward-command 'vm-forward-message))
 136
 137 (defvar vm-toolbar-followup-button
 138   [vm-toolbar-followup-icon
 139    vm-toolbar-followup-command
 140    (vm-toolbar-any-messages-p)
 141    "Follow up the current message.\n
 142 The command `vm-toolbar-followup-command' is run, which is normally
 143 fbound to `vm-followup-message'.
 144 You can make this button run some other command by using a Lisp
 145 s-expression like this one in your .vm file:
 146    (fset 'vm-toolbar-followup-command 'some-other-command)"])
 147 (defvar vm-toolbar-followup-icon nil)
 148 (or (fboundp 'vm-toolbar-followup-command)
 149     (fset 'vm-toolbar-followup-command 'vm-followup))
 150
 151 (defvar vm-toolbar-compose-button
 152   [vm-toolbar-compose-icon vm-toolbar-compose-command t
 153    "Compose a new message.\n
 154 The command `vm-toolbar-compose-command' is run, which is normally
 155 fbound to `vm-mail'.
 156 You can make this button run some other command by using a Lisp
 157 s-expression like this one in your .vm file:
 158    (fset 'vm-toolbar-compose-command 'some-other-command)"])
 159 (defvar vm-toolbar-compose-icon nil)
 160 (or (fboundp 'vm-toolbar-compose-command)
 161     (fset 'vm-toolbar-compose-command 'vm-mail))
 162
 163 (defvar vm-toolbar-decode-mime-button
 164   [vm-toolbar-decode-mime-icon vm-toolbar-decode-mime-command
 165    (vm-toolbar-can-decode-mime-p)
 166    "Decode the MIME objects in the current message.\n
 167 The objects might be displayed immediately, or buttons might be
 168 displayed that you need to click on to view the object.  See the
 169 documentation for the variables vm-mime-internal-content-types
 170 and vm-mime-external-content-types-alist to see how to control
 171 whether you see buttons or objects.\n
 172 The command `vm-toolbar-decode-mime-command' is run, which is normally
 173 fbound to `vm-decode-mime-messages'.
 174 You can make this button run some other command by using a Lisp
 175 s-expression like this one in your .vm file:
 176    (fset 'vm-toolbar-decode-mime-command 'some-other-command)"])
 177 (defvar vm-toolbar-decode-mime-icon nil)
 178 (or (fboundp 'vm-toolbar-decode-mime-command)
 179     (fset 'vm-toolbar-decode-mime-command 'vm-decode-mime-message))
 180
 181 ;; The values of these two are used by the FSF Emacs toolbar
 182 ;; code.  The values don't matter as long as they are different
 183 ;; (as compared with eq).  Under XEmacs these values are ignored
 184 ;; and overwritten.
 185 (defvar vm-toolbar-delete-icon t)
 186 (defvar vm-toolbar-undelete-icon nil)
 187
 188 (defvar vm-toolbar-delete/undelete-button
 189   [vm-toolbar-delete/undelete-icon
 190    vm-toolbar-delete/undelete-message
 191    (vm-toolbar-any-messages-p)
 192    "Delete the current message, or undelete it if it is already deleted."])
 193 (defvar vm-toolbar-delete/undelete-icon nil)
 194 (make-variable-buffer-local 'vm-toolbar-delete/undelete-icon)
 195
 196 (defvar vm-toolbar-help-icon nil)
 197
 198 (defvar vm-toolbar-recover-icon nil)
 199
 200 (defvar vm-toolbar-helper-icon nil)
 201 (make-variable-buffer-local 'vm-toolbar-helper-icon)
 202
 203 (defvar vm-toolbar-help-button
 204   [vm-toolbar-helper-icon vm-toolbar-helper-command
 205    (vm-toolbar-can-help-p)
 206    "Don't Panic.\n
 207 VM uses this button to offer help if you're in trouble.
 208 Under normal circumstances, this button runs `vm-help'.
 209 If the current folder looks out-of-date relative to its auto-save
 210 file then this button will run `vm-recover-folder'.
 211 If there is mail waiting in one of the spool files associated
 212 with the current folder, and the `getmail' button is not on the
 213 toolbar, this button will run `vm-get-new-mail'.
 214 If the current message needs to be MIME decoded then this button
 215 will run 'vm-decode-mime-message'."])
 216
 217 (defvar vm-toolbar-helper-command nil)
 218 (make-variable-buffer-local 'vm-toolbar-helper-command)
 219
 220 ;;;###autoload
 221 (defun vm-toolbar-helper-command ()
 222   (interactive)
 223   (setq this-command vm-toolbar-helper-command)
 224   (call-interactively vm-toolbar-helper-command))
 225
 226 (defvar vm-toolbar-quit-button
 227   [vm-toolbar-quit-icon vm-toolbar-quit-command
 228    (vm-toolbar-can-quit-p)
 229    "Quit visiting this folder.\n
 230 The command `vm-toolbar-quit-command' is run, which is normally
 231 fbound to `vm-quit'.
 232 You can make this button run some other command by using a Lisp
 233 s-expression like this one in your .vm file:
 234    (fset 'vm-toolbar-quit-command 'some-other-command)"])
 235 (defvar vm-toolbar-quit-icon nil)
 236 (or (fboundp 'vm-toolbar-quit-command)
 237     (fset 'vm-toolbar-quit-command 'vm-quit))
 238
 239 (defun vm-toolbar-any-messages-p ()
 240   (condition-case nil
 241       (save-excursion
 242         (vm-check-for-killed-folder)
 243         (vm-select-folder-buffer-if-possible)
 244         vm-message-list)
 245     (error nil)))
 246
 247 ;;;###autoload
 248 (defun vm-toolbar-delete/undelete-message (&optional prefix-arg)
 249   (interactive "P")
 250   (vm-follow-summary-cursor)
 251   (vm-select-folder-buffer)
 252   (vm-check-for-killed-summary)
 253   (vm-error-if-folder-read-only)
 254   (vm-error-if-folder-empty)
 255   (let ((current-prefix-arg prefix-arg))
 256     (if (vm-deleted-flag (car vm-message-pointer))
 257         (call-interactively 'vm-undelete-message)
 258       (call-interactively 'vm-delete-message))))
 259
 260 ;;;###autoload
 261 (defun vm-toolbar-can-autofile-p ()
 262   (interactive)
 263   (condition-case nil
 264       (save-excursion
 265         (vm-check-for-killed-folder)
 266         (vm-select-folder-buffer-if-possible)
 267         (and vm-message-pointer
 268              (vm-auto-select-folder vm-message-pointer vm-auto-folder-alist)))
 269     (error nil)))
 270
 271 ;;;###autoload
 272 (defun vm-toolbar-autofile-message ()
 273   (interactive)
 274   (vm-follow-summary-cursor)
 275   (vm-select-folder-buffer)
 276   (vm-check-for-killed-summary)
 277   (vm-error-if-folder-read-only)
 278   (vm-error-if-folder-empty)
 279   (let ((file (vm-auto-select-folder vm-message-pointer vm-auto-folder-alist)))
 280     (if file
 281         (progn
 282           (vm-save-message file 1)
 283           (message "Message saved to %s" file))
 284       (error "No match for message in vm-auto-folder-alist."))))
 285
 286 (defun vm-toolbar-can-recover-p ()
 287   (condition-case nil
 288       (save-excursion
 289         (vm-select-folder-buffer)
 290         (and vm-folder-read-only
 291              buffer-file-name
 292              buffer-auto-save-file-name
 293              (null (buffer-modified-p))
 294              (file-newer-than-file-p
 295               buffer-auto-save-file-name
 296               buffer-file-name)))
 297     (error nil)))
 298
 299 (defun vm-toolbar-can-decode-mime-p ()
 300   (condition-case nil
 301       (save-excursion
 302         (vm-select-folder-buffer)
 303         (and
 304          vm-display-using-mime
 305          vm-message-pointer
 306          vm-presentation-buffer
 307          (not (vm-mime-plain-message-p (car vm-message-pointer)))))
 308     (error nil)))
 309
 310 (defun vm-toolbar-can-quit-p ()
 311   (condition-case nil
 312       (save-excursion
 313         (vm-select-folder-buffer)
 314         (memq major-mode '(vm-mode vm-virtual-mode)))
 315     (error nil)))
 316
 317 (defun vm-toolbar-mail-waiting-p ()
 318   (condition-case nil
 319       (save-excursion
 320         (vm-select-folder-buffer)
 321         (or (not (natnump vm-mail-check-interval))
 322             vm-spooled-mail-waiting))
 323     (error nil)))
 324
 325 (fset 'vm-toolbar-can-help-p 'vm-toolbar-can-quit-p)
 326
 327 (defun vm-toolbar-update-toolbar ()
 328   (if (and vm-message-pointer (vm-deleted-flag (car vm-message-pointer)))
 329       (setq vm-toolbar-delete/undelete-icon vm-toolbar-undelete-icon)
 330     (setq vm-toolbar-delete/undelete-icon vm-toolbar-delete-icon))
 331   (cond ((vm-toolbar-can-recover-p)
 332          (setq vm-toolbar-helper-command 'vm-recover-folder
 333                vm-toolbar-helper-icon vm-toolbar-recover-icon))
 334         ((and (vm-toolbar-mail-waiting-p)
 335               (not (memq 'getmail vm-use-toolbar)))
 336          (setq vm-toolbar-helper-command 'vm-get-new-mail
 337                vm-toolbar-helper-icon vm-toolbar-getmail-icon))
 338         ((and (vm-toolbar-can-decode-mime-p) (not vm-mime-decoded)
 339               (not (memq 'mime vm-use-toolbar)))
 340          (setq vm-toolbar-helper-command 'vm-decode-mime-message
 341                vm-toolbar-helper-icon vm-toolbar-decode-mime-icon))
 342         (t
 343          (setq vm-toolbar-helper-command 'vm-help
 344                vm-toolbar-helper-icon vm-toolbar-help-icon)))
 345   (if vm-summary-buffer
 346       (vm-copy-local-variables vm-summary-buffer
 347                                'vm-toolbar-delete/undelete-icon
 348                                'vm-toolbar-helper-command
 349                                'vm-toolbar-helper-icon))
 350   (if vm-presentation-buffer
 351       (vm-copy-local-variables vm-presentation-buffer
 352                                'vm-toolbar-delete/undelete-icon
 353                                'vm-toolbar-helper-command
 354                                'vm-toolbar-helper-icon))
 355   (and vm-toolbar-specifier
 356        (progn
 357          (set-specifier vm-toolbar-specifier (cons (current-buffer) nil))
 358          (set-specifier vm-toolbar-specifier (cons (current-buffer)
 359                                                    vm-toolbar)))))
 360
 361 (defun vm-toolbar-install-or-uninstall-toolbar ()
 362   (and (vm-toolbar-support-possible-p) vm-use-toolbar
 363        (vm-toolbar-install-toolbar))
 364   (if (and vm-fsfemacs-p (not vm-use-toolbar))
 365       (vm-toolbar-fsfemacs-uninstall-toolbar)))
 366
 367 (defcustom vm-toolbar-height nil
 368   "*Desired height of the toolbar."
 369   :group 'vm
 370   :type '(choice (const  :tag "Automatic" nil) integer))
 371
 372 (defun vm-toolbar-install-toolbar ()
 373   ;; drag these in now instead of waiting for them to be
 374   ;; autoloaded.  the "loading..." messages could come at a bad
 375   ;; moment and wipe an important echo area message, like "Auto
 376   ;; save file is newer..."
 377   (require 'vm-save)
 378   (require 'vm-summary)
 379   (if vm-fsfemacs-p
 380       (if (not vm-fsfemacs-toolbar-installed-p)
 381           (vm-toolbar-fsfemacs-install-toolbar))
 382     (if (not (vm-toolbar-pixmap-directory))
 383         (progn
 384           (message "Bad toolbar pixmap directory, can't setup toolbar.")
 385           (sit-for 2))
 386       (vm-toolbar-initialize)
 387       (let ((height (or vm-toolbar-height
 388                         (+ 5 (glyph-height (car vm-toolbar-help-icon)))))
 389             (width (+ 5 (glyph-width (car vm-toolbar-help-icon))))
 390             (frame (selected-frame))
 391             (buffer (current-buffer))
 392             (tag-set '(win))
 393             (myframe (vm-created-this-frame-p))
 394             toolbar )
 395         ;; glyph-width and glyph-height return 0 at startup sometimes
 396         ;; use reasonable values if they fail.
 397         (if (= width 4)
 398             (setq width 38))
 399         (if (= height 4)
 400             (setq height 38))
 401         ;; honor user setting of vm-toolbar if they are daring enough
 402         ;; to set it.
 403         (if vm-toolbar
 404             (setq toolbar vm-toolbar)
 405           (setq toolbar (vm-toolbar-make-toolbar-spec)
 406                 vm-toolbar toolbar))
 407         (cond ((eq vm-toolbar-orientation 'right)
 408                (setq vm-toolbar-specifier right-toolbar)
 409                (if myframe
 410                    (set-specifier right-toolbar toolbar frame tag-set))
 411                (set-specifier right-toolbar toolbar buffer)
 412                (set-specifier right-toolbar-width width frame tag-set))
 413               ((eq vm-toolbar-orientation 'left)
 414                (setq vm-toolbar-specifier left-toolbar)
 415                (if myframe
 416                    (set-specifier left-toolbar toolbar frame tag-set))
 417                (set-specifier left-toolbar toolbar buffer)
 418                (set-specifier left-toolbar-width width frame tag-set))
 419               ((eq vm-toolbar-orientation 'bottom)
 420                (setq vm-toolbar-specifier bottom-toolbar)
 421                (if myframe
 422                    (set-specifier bottom-toolbar toolbar frame tag-set))
 423                (set-specifier bottom-toolbar toolbar buffer)
 424                (set-specifier bottom-toolbar-height height frame tag-set))
 425               (t
 426                (setq vm-toolbar-specifier top-toolbar)
 427                (if myframe
 428                    (set-specifier top-toolbar toolbar frame tag-set))
 429                (set-specifier top-toolbar toolbar buffer)
 430                (set-specifier top-toolbar-height height frame tag-set)))))))
 431
 432 (defun vm-toolbar-make-toolbar-spec ()
 433   (let ((button-alist '(
 434                         (autofile . vm-toolbar-autofile-button)
 435                         (compose . vm-toolbar-compose-button)
 436                         (delete/undelete . vm-toolbar-delete/undelete-button)
 437                         (file . vm-toolbar-file-button)
 438                         (getmail . vm-toolbar-getmail-button)
 439                         (help . vm-toolbar-help-button)
 440                         (mime . vm-toolbar-decode-mime-button)
 441                         (next . vm-toolbar-next-button)
 442                         (previous . vm-toolbar-previous-button)
 443                         (print . vm-toolbar-print-button)
 444                         (quit . vm-toolbar-quit-button)
 445                         (reply . vm-toolbar-reply-button)
 446                         (forward . vm-toolbar-forward-button)
 447                         (followup . vm-toolbar-followup-button)
 448                         (visit . vm-toolbar-visit-button)
 449                         ))
 450         (button-list vm-use-toolbar)
 451         cons
 452         (toolbar nil))
 453     (while button-list
 454       (cond ((null (car button-list))
 455              (setq toolbar (cons nil toolbar)))
 456             ((integerp (car button-list))
 457              (if (< 0 (car button-list))
 458                  (setq toolbar (cons (vector ':size (car button-list)
 459                                              ':style '2d)
 460                                      toolbar))))
 461             (t
 462              (setq cons (assq (car button-list) button-alist))
 463              (if cons
 464                  (setq toolbar (cons (symbol-value (cdr cons)) toolbar)))))
 465       (setq button-list (cdr button-list)))
 466     (nreverse toolbar) ))
 467
 468 (defun vm-toolbar-initialize ()
 469   (cond
 470    (vm-fsfemacs-p nil)
 471    ((null vm-toolbar-help-icon)
 472     (let ((tuples
 473            (list
 474             '(vm-toolbar-decode-mime-icon
 475               "mime-up.xpm" "mime-dn.xpm" "mime-xx.xpm")
 476             '(vm-toolbar-next-icon
 477               "next-up.xpm" "next-dn.xpm" "next-dn.xpm")
 478             '(vm-toolbar-previous-icon
 479               "previous-up.xpm" "previous-dn.xpm" "previous-dn.xpm")
 480             '(vm-toolbar-delete-icon
 481               "delete-up.xpm" "delete-dn.xpm" "delete-dn.xpm")
 482             '(vm-toolbar-undelete-icon
 483               "undelete-up.xpm" "undelete-dn.xpm" "undelete-dn.xpm")
 484             '(vm-toolbar-autofile-icon
 485               "autofile-up.xpm" "autofile-dn.xpm" "autofile-dn.xpm")
 486             '(vm-toolbar-getmail-icon
 487               "getmail-up.xpm" "getmail-dn.xpm" "getmail-dn.xpm")
 488             '(vm-toolbar-file-icon
 489               "file-up.xpm" "file-dn.xpm" "file-dn.xpm")
 490             '(vm-toolbar-reply-icon
 491               "reply-up.xpm" "reply-dn.xpm" "reply-dn.xpm")
 492             '(vm-toolbar-forward-icon
 493               "forward-up.xpm" "forward-dn.xpm" "forward-dn.xpm")
 494             '(vm-toolbar-followup-icon
 495               "followup-up.xpm" "followup-dn.xpm" "followup-dn.xpm")
 496             '(vm-toolbar-compose-icon
 497               "compose-up.xpm" "compose-dn.xpm" "compose-dn.xpm")
 498             '(vm-toolbar-print-icon
 499               "print-up.xpm" "print-dn.xpm" "print-dn.xpm")
 500             '(vm-toolbar-visit-icon
 501               "visit-up.xpm" "visit-dn.xpm" "visit-dn.xpm")
 502             '(vm-toolbar-quit-icon
 503               "quit-up.xpm" "quit-dn.xpm" "quit-dn.xpm")
 504             '(vm-toolbar-help-icon
 505               "help-up.xpm" "help-dn.xpm" "help-dn.xpm")
 506             '(vm-toolbar-recover-icon
 507               "recover-up.xpm" "recover-dn.xpm" "recover-dn.xpm")
 508             ))
 509           tuple files var)
 510       (while tuples
 511         (setq tuple (car tuples)
 512               var (car tuple)
 513               files (cdr tuple))
 514         (set var (mapcar
 515                   (function
 516                    (lambda (f)
 517                      (make-glyph
 518                       (expand-file-name f (vm-toolbar-pixmap-directory)))))
 519                   files))
 520         (setq tuples (cdr tuples))))))
 521   (setq vm-toolbar-delete/undelete-icon vm-toolbar-delete-icon)
 522   (setq-default vm-toolbar-delete/undelete-icon vm-toolbar-delete-icon)
 523   (setq vm-toolbar-helper-command 'vm-help)
 524   (setq vm-toolbar-helper-icon vm-toolbar-help-icon)
 525   (setq-default vm-toolbar-helper-icon vm-toolbar-help-icon))
 526
 527 (defun vm-toolbar-fsfemacs-uninstall-toolbar ()
 528   (define-key vm-mode-map [toolbar] nil)
 529   (setq vm-fsfemacs-toolbar-installed-p nil))
 530
 531 (defun vm-toolbar-fsfemacs-install-toolbar ()
 532   (let ((button-list (reverse vm-use-toolbar))
 533         (dir (vm-toolbar-pixmap-directory))
 534         (extension "xpm")
 535         item t-spec sym name images)
 536     (defvar tool-bar-map)
 537     ;; hide the toolbar entries that are in the global keymap so
 538     ;; VM has full control of the toolbar in its buffers.
 539     (if (and (boundp 'tool-bar-map)
 540              (consp tool-bar-map))
 541         (let ((map (cdr tool-bar-map))
 542               (v [tool-bar x]))
 543           (while map
 544             (aset v 1 (car (car map)))
 545             (define-key vm-mode-map v 'undefined)
 546             (setq map (cdr map)))))
 547     (while button-list
 548       (setq sym (car button-list))
 549       (cond ((null sym)
 550              ;; can't do flushright in FSF Emacs
 551              t)
 552             ((integerp sym)
 553              ;; can't do separators in FSF Emacs
 554              t)
 555             ((memq sym '(autofile compose file getmail
 556                          mime next previous print quit
 557                          reply followup forward visit))
 558              (setq t-spec (symbol-value
 559                            (intern (format "vm-toolbar-%s-button"
 560                                            (if (eq sym 'mime)
 561                                                'decode-mime
 562                                              sym)))))
 563              (setq name (symbol-name sym))
 564              (setq images (vm-toolbar-make-fsfemacs-toolbar-image-spec
 565                            name extension dir
 566                            (if (eq sym 'mime) nil 'heuristic)))
 567              (setq item
 568                    (list 'menu-item
 569                          (aref t-spec 3)
 570                          (aref t-spec 1)
 571                          ':enable (aref t-spec 2)
 572 ;                        ':button '(:toggle nil)
 573                          ':image images))
 574              (define-key vm-mode-map (vector 'tool-bar sym) item))
 575             ((eq sym 'delete/undelete)
 576              (setq t-spec vm-toolbar-delete/undelete-button)
 577              (setq name "delete")
 578              (setq images (vm-toolbar-make-fsfemacs-toolbar-image-spec
 579                            name extension dir 'heuristic))
 580              (setq item
 581                    (list 'menu-item
 582                          (aref t-spec 3)
 583                          (aref t-spec 1)
 584                          ':visible '(eq vm-toolbar-delete/undelete-icon
 585                                         vm-toolbar-delete-icon)
 586                          ':enable (aref t-spec 2)
 587 ;                        ':button '(:toggle nil)
 588                          ':image images))
 589              (define-key vm-mode-map (vector 'tool-bar 'delete) item)
 590              (setq name "undelete")
 591              (setq images (vm-toolbar-make-fsfemacs-toolbar-image-spec
 592                            name extension dir 'heuristic))
 593              (setq item
 594                    (list 'menu-item
 595                          (aref t-spec 3)
 596                          (aref t-spec 1)
 597                          ':visible '(eq vm-toolbar-delete/undelete-icon
 598                                         vm-toolbar-undelete-icon)
 599                          ':enable (aref t-spec 2)
 600 ;                        ':button '(:toggle nil)
 601                          ':image images))
 602              (define-key vm-mode-map (vector 'tool-bar 'undelete) item))
 603             ((eq sym 'help)
 604              (setq t-spec vm-toolbar-help-button)
 605              (setq name "help")
 606              (setq images (vm-toolbar-make-fsfemacs-toolbar-image-spec
 607                            name extension dir 'heuristic))
 608              (setq item
 609                    (list 'menu-item
 610                          (aref t-spec 3)
 611                          (aref t-spec 1)
 612                          ':visible '(eq vm-toolbar-helper-command 'vm-help)
 613                          ':enable (aref t-spec 2)
 614 ;                        ':button '(:toggle nil)
 615                          ':image images))
 616              (define-key vm-mode-map (vector 'tool-bar 'help-help) item)
 617              (setq name "recover")
 618              (setq images (vm-toolbar-make-fsfemacs-toolbar-image-spec
 619                            name extension dir 'heuristic))
 620              (setq item
 621                    (list 'menu-item
 622                          (aref t-spec 3)
 623                          (aref t-spec 1)
 624                          ':visible '(eq vm-toolbar-helper-command
 625                                         'recover-file)
 626                          ':enable (aref t-spec 2)
 627 ;                        ':button '(:toggle nil)
 628                          ':image images))
 629              (define-key vm-mode-map (vector 'tool-bar 'help-recover) item)
 630              (setq name "getmail")
 631              (setq images (vm-toolbar-make-fsfemacs-toolbar-image-spec
 632                            name extension dir 'heuristic))
 633              (setq item
 634                    (list 'menu-item
 635                          (aref t-spec 3)
 636                          (aref t-spec 1)
 637                          ':visible '(eq vm-toolbar-helper-command
 638                                         'vm-get-new-mail)
 639                          ':enable (aref t-spec 2)
 640 ;                        ':button '(:toggle nil)
 641                          ':image images))
 642              (define-key vm-mode-map (vector 'tool-bar 'help-getmail) item)
 643              (setq name "mime")
 644              (setq images (vm-toolbar-make-fsfemacs-toolbar-image-spec
 645                            name extension dir nil))
 646              (setq item
 647                    (list 'menu-item
 648                          (aref t-spec 3)
 649                          (aref t-spec 1)
 650                          ':visible '(eq vm-toolbar-helper-command
 651                                         'vm-decode-mime-message)
 652                          ':enable (aref t-spec 2)
 653 ;                        ':button '(:toggle nil)
 654                          ':image images))
 655              (define-key vm-mode-map (vector 'tool-bar 'help-mime) item)))
 656       (setq button-list (cdr button-list))))
 657   (setq vm-fsfemacs-toolbar-installed-p t))
 658
 659 (defun vm-toolbar-make-fsfemacs-toolbar-image-spec (name extension dir mask)
 660   (if (string= extension "xpm")
 661       (vector
 662        (list 'image
 663              ':type (intern extension)
 664              ':mask mask
 665              ':file (expand-file-name
 666                      (format "%s-dn.%s"
 667                              name extension)
 668                      dir))
 669        (list 'image
 670              ':type (intern extension)
 671              ':mask mask
 672              ':file (expand-file-name
 673                      (format "%s-up.%s"
 674                              name extension)
 675                      dir))
 676        (list 'image
 677              ':type (intern extension)
 678              ':mask mask
 679              ':file (expand-file-name
 680                      (format "%s-dn.%s"
 681                              name extension)
 682                      dir))
 683        (list 'image
 684              ':type (intern extension)
 685              ':mask mask
 686              ':file (expand-file-name
 687                      (format "%s-dn.%s"
 688                              name extension)
 689                      dir)))
 690     (vector
 691      (list 'image
 692            ':type (intern extension)
 693            ':mask mask
 694            ':file (expand-file-name
 695                    (format "%s-dn.%s"
 696                            name extension)
 697                    dir))
 698      (list 'image
 699            ':type (intern extension)
 700            ':mask mask
 701            ':file (expand-file-name
 702                    (format "%s-up.%s"
 703                            name extension)
 704                    dir))
 705      (list 'image
 706            ':type (intern extension)
 707            ':mask mask
 708            ':file (expand-file-name
 709                    (format "%s-xx.%s"
 710                            name extension)
 711                    dir))
 712      (list 'image
 713            ':type (intern extension)
 714            ':mask mask
 715            ':file (expand-file-name
 716                    (format "%s-xx.%s"
 717                            name extension)
 718                    dir)))))
 719
 720 (provide 'vm-toolbar)
 721
 722 ;;; vm-toolbar.el ends here