home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / vm / vm-toolbar.el < prev    next >
Encoding:
Text File  |  1995-08-18  |  13.5 KB  |  360 lines
  1. ;;; Toolbar related functions and commands
  2. ;;; Copyright (C) 1995 Kyle E. Jones
  3. ;;;
  4. ;;; This program is free software; you can redistribute it and/or modify
  5. ;;; it under the terms of the GNU General Public License as published by
  6. ;;; the Free Software Foundation; either version 1, or (at your option)
  7. ;;; any later version.
  8. ;;;
  9. ;;; This program is distributed in the hope that it will be useful,
  10. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. ;;; GNU General Public License for more details.
  13. ;;;
  14. ;;; You should have received a copy of the GNU General Public License
  15. ;;; along with this program; if not, write to the Free Software
  16. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  17.  
  18. (provide 'vm-toolbar)
  19.  
  20. (defvar vm-toolbar-specifier nil)
  21. (defvar vm-toolbar 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. bound 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. bound 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. bound 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-print-button
  71.   [vm-toolbar-print-icon
  72.    vm-toolbar-print-command
  73.    (vm-toolbar-any-messages-p)
  74.    "Print the current message.\n
  75. The command `vm-toolbar-print-command' is run, which is normally
  76. bound to `vm-print-message'.
  77. You can make this button run some other command by using a Lisp
  78. s-expression like this one in your .vm file:
  79.    (fset 'vm-toolbar-print-command 'some-other-command)"])
  80. (defvar vm-toolbar-print-icon nil)
  81. (or (fboundp 'vm-toolbar-print-command)
  82.     (fset 'vm-toolbar-print-command 'vm-print-message))
  83.  
  84. (defvar vm-toolbar-visit-button
  85.   [vm-toolbar-visit-icon vm-toolbar-visit-command t
  86.    "Visit a different folder.\n
  87. The command `vm-toolbar-visit-command' is run, which is normally
  88. bound to `vm-visit-folder'.
  89. You can make this button run some other command by using a Lisp
  90. s-expression like this one in your .vm file:
  91.    (fset 'vm-toolbar-visit-command 'some-other-command)"])
  92. (defvar vm-toolbar-visit-icon nil)
  93. (or (fboundp 'vm-toolbar-visit-command)
  94.     (fset 'vm-toolbar-visit-command 'vm-visit-folder))
  95.  
  96. (defvar vm-toolbar-reply-button
  97.   [vm-toolbar-reply-icon
  98.    vm-toolbar-reply-command
  99.    (vm-toolbar-any-messages-p)
  100.    "Reply to the current message.\n
  101. The command `vm-toolbar-reply-command' is run, which is normally
  102. bound to `vm-followup-include-text'.
  103. You can make this button run some other command by using a Lisp
  104. s-expression like this one in your .vm file:
  105.    (fset 'vm-toolbar-reply-command 'some-other-command)"])
  106. (defvar vm-toolbar-reply-icon nil)
  107. (or (fboundp 'vm-toolbar-reply-command)
  108.     (fset 'vm-toolbar-reply-command 'vm-followup-include-text))
  109.  
  110. (defvar vm-toolbar-compose-button
  111.   [vm-toolbar-compose-icon vm-toolbar-compose-command t
  112.    "Compose a new message.\n
  113. The command `vm-toolbar-compose-command' is run, which is normally
  114. bound to `vm-mail'.
  115. You can make this button run some other command by using a Lisp
  116. s-expression like this one in your .vm file:
  117.    (fset 'vm-toolbar-compose-command 'some-other-command)"])
  118. (defvar vm-toolbar-compose-icon nil)
  119. (or (fboundp 'vm-toolbar-compose-command)
  120.     (fset 'vm-toolbar-compose-command 'vm-mail))
  121.  
  122. (defvar vm-toolbar-delete-icon nil)
  123.  
  124. (defvar vm-toolbar-undelete-icon nil)
  125.  
  126. (defvar vm-toolbar-delete/undelete-button
  127.   [vm-toolbar-delete/undelete-icon
  128.    vm-toolbar-delete/undelete-message
  129.    (vm-toolbar-any-messages-p)
  130.    "Delete the current message, or undelete it if it is already deleted."])
  131. (defvar vm-toolbar-delete/undelete-icon nil)
  132. (make-variable-buffer-local 'vm-toolbar-delete/undelete-icon)
  133.  
  134. (defvar vm-toolbar-help-icon nil)
  135.  
  136. (defvar vm-toolbar-recover-icon nil)
  137.  
  138. (defvar vm-toolbar-helper-icon nil)
  139. (make-variable-buffer-local 'vm-toolbar-helper-icon)
  140.  
  141. (defvar vm-toolbar-help-button
  142.   [vm-toolbar-helper-icon vm-toolbar-helper-command t
  143.    "Don't Panic.\n
  144. VM uses this button to offer help if you're in trouble.
  145. Under normal circumstances, this button runs `vm-help'.\n
  146. If the current folder looks out-of-date relative to its auto-save
  147. file then this button will run `recover-file'."])
  148.  
  149. (defvar vm-toolbar-helper-command nil)
  150. (make-variable-buffer-local 'vm-toolbar-helper-command)
  151.  
  152. (defun vm-toolbar-helper-command ()
  153.   (interactive)
  154.   (setq this-command vm-toolbar-helper-command)
  155.   (call-interactively vm-toolbar-helper-command))
  156.  
  157. (defvar vm-toolbar-quit-button
  158.   [vm-toolbar-quit-icon vm-toolbar-quit-command t
  159.    "Quit VM.\n
  160. The command `vm-toolbar-quit-command' is run, which is normally
  161. bound to `vm-quit'.
  162. You can make this button run some other command by using a Lisp
  163. s-expression like this one in your .vm file:
  164.    (fset 'vm-toolbar-quit-command 'some-other-command)"])
  165. (defvar vm-toolbar-quit-icon nil)
  166. (or (fboundp 'vm-toolbar-quit-command)
  167.     (fset 'vm-toolbar-quit-command 'vm-quit))
  168.  
  169. (defun vm-toolbar-any-messages-p ()
  170.   (save-excursion
  171.     (vm-check-for-killed-folder)
  172.     (vm-select-folder-buffer)
  173.     vm-message-list))
  174.  
  175. (defun vm-toolbar-delete/undelete-message (&optional prefix-arg)
  176.   (interactive "P")
  177.   (vm-follow-summary-cursor)
  178.   (vm-select-folder-buffer)
  179.   (vm-check-for-killed-summary)
  180.   (vm-error-if-folder-read-only)
  181.   (vm-error-if-folder-empty)
  182.   (let ((current-prefix-arg prefix-arg))
  183.     (if (vm-deleted-flag (car vm-message-pointer))
  184.     (call-interactively 'vm-undelete-message)
  185.       (call-interactively 'vm-delete-message))))
  186.  
  187. (defun vm-toolbar-can-autofile-p ()
  188.   (interactive)
  189.   (save-excursion
  190.     (vm-check-for-killed-folder)
  191.     (vm-select-folder-buffer)
  192.     (and vm-message-pointer
  193.      (vm-auto-select-folder vm-message-pointer vm-auto-folder-alist))))
  194.  
  195. (defun vm-toolbar-autofile-message ()
  196.   (interactive)
  197.   (vm-follow-summary-cursor)
  198.   (vm-select-folder-buffer)
  199.   (vm-check-for-killed-summary)
  200.   (vm-error-if-folder-read-only)
  201.   (vm-error-if-folder-empty)
  202.   (let ((file (vm-auto-select-folder vm-message-pointer vm-auto-folder-alist)))
  203.     (if file
  204.     (progn
  205.       (vm-save-message file 1)
  206.       (message "Message saved to %s" file))
  207.       (error "No match for message in vm-auto-folder-alist."))))
  208.  
  209. (defun vm-toolbar-can-recover-p ()
  210.   (save-excursion
  211.     (vm-check-for-killed-folder)
  212.     (vm-select-folder-buffer)
  213.     (and vm-folder-read-only
  214.      buffer-file-name
  215.      buffer-auto-save-file-name
  216.      (null (buffer-modified-p))
  217.      (file-newer-than-file-p
  218.       buffer-auto-save-file-name
  219.       buffer-file-name))))
  220.  
  221. (defun vm-toolbar-update-toolbar ()
  222.   (if (and vm-message-pointer (vm-deleted-flag (car vm-message-pointer)))
  223.       (setq vm-toolbar-delete/undelete-icon vm-toolbar-undelete-icon)
  224.     (setq vm-toolbar-delete/undelete-icon vm-toolbar-delete-icon))
  225.   (cond ((vm-toolbar-can-recover-p)
  226.      (setq vm-toolbar-helper-command 'recover-file
  227.            vm-toolbar-helper-icon vm-toolbar-recover-icon))
  228.     (t
  229.      (setq vm-toolbar-helper-command 'vm-help
  230.            vm-toolbar-helper-icon vm-toolbar-help-icon)))
  231.   (if vm-summary-buffer
  232.       (vm-copy-local-variables vm-summary-buffer
  233.                    'vm-toolbar-delete/undelete-icon
  234.                    'vm-toolbar-helper-command
  235.                    'vm-toolbar-helper-icon))
  236.   (and vm-toolbar-specifier
  237.        (progn
  238.      (set-specifier vm-toolbar-specifier (cons (current-buffer) nil))
  239.      (set-specifier vm-toolbar-specifier (cons (current-buffer)
  240.                            vm-toolbar)))))
  241.  
  242. (defun vm-toolbar-install-toolbar ()
  243.   (vm-toolbar-initialize)
  244.   (let ((toolbar (vm-toolbar-make-toolbar-spec))
  245.     (height (+ 4 (glyph-height (car vm-toolbar-help-icon))))
  246.     (width (+ 4 (glyph-width (car vm-toolbar-help-icon)))))
  247.     (setq vm-toolbar toolbar)
  248.     (cond ((eq vm-toolbar-orientation 'right)
  249.        (setq vm-toolbar-specifier right-toolbar)
  250.        (set-specifier right-toolbar (cons (current-buffer) toolbar))
  251.        (set-specifier right-toolbar-width
  252.               (cons (selected-frame) width)))
  253.       ((eq vm-toolbar-orientation 'left)
  254.        (setq vm-toolbar-specifier left-toolbar)
  255.        (set-specifier left-toolbar (cons (current-buffer) toolbar))
  256.        (set-specifier left-toolbar-width
  257.               (cons (selected-frame) width)))
  258.       ((eq vm-toolbar-orientation 'bottom)
  259.        (setq vm-toolbar-specifier bottom-toolbar)
  260.        (set-specifier bottom-toolbar (cons (current-buffer) toolbar))
  261.        (set-specifier bottom-toolbar-height
  262.               (cons (selected-frame) height)))
  263.       (t
  264.        (setq vm-toolbar-specifier top-toolbar)
  265.        (set-specifier top-toolbar (cons (current-buffer) toolbar))
  266.        (set-specifier top-toolbar-height
  267.               (cons (selected-frame) height))))))
  268.  
  269. (defun vm-toolbar-make-toolbar-spec ()
  270.   (let ((button-alist '(
  271.             (autofile . vm-toolbar-autofile-button)
  272.             (compose . vm-toolbar-compose-button)
  273.             (delete/undelete . vm-toolbar-delete/undelete-button)
  274.             (file . vm-toolbar-file-button)
  275.             (help . vm-toolbar-help-button)
  276.             (next . vm-toolbar-next-button)
  277.             (previous . vm-toolbar-previous-button)
  278.             (print . vm-toolbar-print-button)
  279.             (quit . vm-toolbar-quit-button)
  280.             (reply . vm-toolbar-reply-button)
  281.             (visit . vm-toolbar-visit-button)
  282.             ))
  283.     (button-list vm-use-toolbar)
  284.     cons
  285.     (toolbar nil))
  286.     (while button-list
  287.       (if (null (car button-list))
  288.       (setq toolbar (cons nil toolbar))
  289.     (setq cons (assq (car button-list) button-alist))
  290.     (if cons
  291.         (setq toolbar (cons (symbol-value (cdr cons)) toolbar))))
  292.       (setq button-list (cdr button-list)))
  293.     (nreverse toolbar) ))
  294.  
  295. (defun vm-toolbar-initialize ()
  296.   ;; drag these in now instead of waiting for them to be
  297.   ;; autoloaded.  the "loading..." messages could come at a bad
  298.   ;; moment and wipe an important echo area message, like "Auto
  299.   ;; save file is newer..."
  300.   (require 'vm-save)
  301.   (require 'vm-summary)
  302.   (cond
  303.    ((null vm-toolbar-help-icon)
  304.     (let ((tuples
  305.        (if (featurep 'xpm)
  306.            '(
  307.  (vm-toolbar-next-icon "next-up.xpm" "next-dn.xpm" "next-dn.xpm")
  308.  (vm-toolbar-previous-icon "previous-up.xpm" "previous-dn.xpm"
  309.                "previous-dn.xpm")
  310.  (vm-toolbar-delete-icon "delete-up.xpm" "delete-dn.xpm" "delete-dn.xpm")
  311.  (vm-toolbar-undelete-icon "undelete-up.xpm" "undelete-dn.xpm"
  312.                "undelete-dn.xpm")
  313.  (vm-toolbar-autofile-icon "autofile-up.xpm" "autofile-dn.xpm"
  314.                "autofile-dn.xpm")
  315.  (vm-toolbar-file-icon "file-up.xpm" "file-dn.xpm" "file-dn.xpm")
  316.  (vm-toolbar-reply-icon "reply-up.xpm" "reply-dn.xpm" "reply-dn.xpm")
  317.  (vm-toolbar-compose-icon "compose-up.xpm" "compose-dn.xpm" "compose-dn.xpm")
  318.  (vm-toolbar-print-icon "print-up.xpm" "print-dn.xpm" "print-dn.xpm")
  319.  (vm-toolbar-visit-icon "visit-up.xpm" "visit-dn.xpm" "visit-dn.xpm")
  320.  (vm-toolbar-quit-icon "quit-up.xpm" "quit-dn.xpm" "quit-dn.xpm")
  321.  (vm-toolbar-help-icon "help-up.xpm" "help-dn.xpm" "help-dn.xpm")
  322.  (vm-toolbar-recover-icon "recover-up.xpm" "recover-dn.xpm" "recover-dn.xpm")
  323.        )
  324.            '(
  325.  (vm-toolbar-next-icon "next-up.xbm" "next-dn.xbm" "next-xx.xbm")
  326.  (vm-toolbar-previous-icon "previous-up.xbm" "previous-dn.xbm"
  327.                "previous-xx.xbm")
  328.  (vm-toolbar-delete-icon "delete-up.xbm" "delete-dn.xbm" "delete-xx.xbm")
  329.  (vm-toolbar-undelete-icon "undelete-up.xbm" "undelete-dn.xbm"
  330.                "undelete-xx.xbm")
  331.  (vm-toolbar-autofile-icon "autofile-up.xbm" "autofile-dn.xbm"
  332.                "autofile-xx.xbm")
  333.  (vm-toolbar-file-icon "file-up.xbm" "file-dn.xbm" "file-xx.xbm")
  334.  (vm-toolbar-reply-icon "reply-up.xbm" "reply-dn.xbm" "reply-xx.xbm")
  335.  (vm-toolbar-compose-icon "compose-up.xbm" "compose-dn.xbm" "compose-xx.xbm")
  336.  (vm-toolbar-print-icon "print-up.xbm" "print-dn.xbm" "print-xx.xbm")
  337.  (vm-toolbar-visit-icon "visit-up.xbm" "visit-dn.xbm" "visit-xx.xbm")
  338.  (vm-toolbar-quit-icon "quit-up.xbm" "quit-dn.xbm" "quit-xx.xbm")
  339.  (vm-toolbar-help-icon "help-up.xbm" "help-dn.xbm" "help-xx.xpm")
  340.  (vm-toolbar-recover-icon "recover-up.xbm" "recover-dn.xbm" "recover-xx.xpm")
  341.        )))
  342.       tuple files var)
  343.       (if (not (file-directory-p vm-toolbar-pixmap-directory))
  344.       (error "Bad toolbar pixmap directory: %s"
  345.          vm-toolbar-pixmap-directory)
  346.     (while tuples
  347.       (setq tuple (car tuples)
  348.         var (car tuple)
  349.         files (cdr tuple))
  350.       (set var (mapcar
  351.             (function
  352.              (lambda (f)
  353.                (make-glyph
  354.             (expand-file-name f vm-toolbar-pixmap-directory))))
  355.             files))
  356.       (setq tuples (cdr tuples)))))))
  357.   (setq vm-toolbar-delete/undelete-icon vm-toolbar-delete-icon)
  358.   (setq vm-toolbar-helper-command 'vm-help)
  359.   (setq vm-toolbar-helper-icon vm-toolbar-help-icon))
  360.