diff options
Diffstat (limited to 'lisp/mh-e/mh-tool-bar.el')
| -rw-r--r-- | lisp/mh-e/mh-tool-bar.el | 420 |
1 files changed, 420 insertions, 0 deletions
diff --git a/lisp/mh-e/mh-tool-bar.el b/lisp/mh-e/mh-tool-bar.el new file mode 100644 index 00000000000..ebf07a77672 --- /dev/null +++ b/lisp/mh-e/mh-tool-bar.el @@ -0,0 +1,420 @@ +;;; mh-tool-bar.el --- MH-E tool bar support + +;; Copyright (C) 2002, 2003, 2005, 2006 Free Software Foundation, Inc. + +;; Author: Satyaki Das <satyaki@theforce.stanford.edu> +;; Maintainer: Bill Wohler <wohler@newt.com> +;; Keywords: mail +;; See: mh-e.el + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;;; Change Log: + +;;; Code: + +(require 'mh-e) + +;;; Tool Bar Commands + +(defun mh-tool-bar-search (&optional arg) + "Interactively call `mh-tool-bar-search-function'. +Optional argument ARG is not used." + (interactive "P") + (call-interactively mh-tool-bar-search-function)) + +(defun mh-tool-bar-customize () + "Call `mh-customize' from the tool bar." + (interactive) + (mh-customize t)) + +(defun mh-tool-bar-folder-help () + "Visit \"(mh-e)Top\"." + (interactive) + (info "(mh-e)Top") + (delete-other-windows)) + +(defun mh-tool-bar-letter-help () + "Visit \"(mh-e)Editing Drafts\"." + (interactive) + (info "(mh-e)Editing Drafts") + (delete-other-windows)) + +(defmacro mh-tool-bar-reply-generator (function recipient folder-buffer-flag) + "Generate FUNCTION that replies to RECIPIENT. +If FOLDER-BUFFER-FLAG is nil then the function generated... +When INCLUDE-FLAG is non-nil, include message body being replied to." + `(defun ,function (&optional arg) + ,(format "Reply to \"%s\".\nWhen ARG is non-nil include message in reply." + recipient) + (interactive "P") + ,(if folder-buffer-flag nil '(set-buffer mh-show-folder-buffer)) + (mh-reply (mh-get-msg-num nil) ,recipient arg))) + +(mh-tool-bar-reply-generator mh-tool-bar-reply-from "from" t) +(mh-tool-bar-reply-generator mh-show-tool-bar-reply-from "from" nil) +(mh-tool-bar-reply-generator mh-tool-bar-reply-to "to" t) +(mh-tool-bar-reply-generator mh-show-tool-bar-reply-to "to" nil) +(mh-tool-bar-reply-generator mh-tool-bar-reply-all "all" t) +(mh-tool-bar-reply-generator mh-show-tool-bar-reply-all "all" nil) + + + +;;; Tool Bar Creation + +(defmacro mh-tool-bar-define (defaults &rest buttons) + "Define a tool bar for MH-E. +DEFAULTS is the list of buttons that are present by default. It +is a list of lists where the sublists are of the following form: + + (:KEYWORD FUNC1 FUNC2 FUNC3 ...) + +Here :KEYWORD is one of :folder or :letter. If it is :folder then +the default buttons in the folder and show mode buffers are being +specified. If it is :letter then the default buttons in the +letter mode are listed. FUNC1, FUNC2, FUNC3, ... are the names of +the functions that the buttons would execute. + +Each element of BUTTONS is a list consisting of four mandatory +items and one optional item as follows: + + (FUNCTION MODES ICON DOC &optional ENABLE-EXPR) + +where, + + FUNCTION is the name of the function that will be executed when + the button is clicked. + + MODES is a list of symbols. List elements must be from \"folder\", + \"letter\" and \"sequence\". If \"folder\" is present then the button is + available in the folder and show buffer. If the name of FUNCTION is + of the form \"mh-foo\", where foo is some arbitrary string, then we + check if the function `mh-show-foo' exists. If it exists then that + function is used in the show buffer. Otherwise the original function + `mh-foo' is used in the show buffer as well. Presence of \"sequence\" + is handled similar to the above. The only difference is that the + button is shown only when the folder is narrowed to a sequence. If + \"letter\" is present in MODES, then the button is available during + draft editing and runs FUNCTION when clicked. + + ICON is the icon that is drawn in the button. + + DOC is the documentation for the button. It is used in tool-tips and + in providing other help to the user. GNU Emacs uses only the first + line of the string. So the DOC should be formatted such that the + first line is useful and complete without the rest of the string. + + Optional item ENABLE-EXPR is an arbitrary lisp expression. If it + evaluates to nil, then the button is deactivated, otherwise it is + active. If it isn't present then the button is always active." + ;; The following variable names have been carefully chosen to make code + ;; generation easier. Modifying the names should be done carefully. + (let (folder-buttons folder-docs folder-button-setter sequence-button-setter + show-buttons show-button-setter show-seq-button-setter + letter-buttons letter-docs letter-button-setter + folder-defaults letter-defaults + folder-vectors show-vectors letter-vectors) + (dolist (x defaults) + (cond ((eq (car x) :folder) (setq folder-defaults (cdr x))) + ((eq (car x) :letter) (setq letter-defaults (cdr x))))) + (dolist (button buttons) + (unless (and (listp button) + (or (equal (length button) 4) (equal (length button) 5))) + (error "Incorrect MH-E tool-bar button specification: %s" button)) + (let* ((name (nth 0 button)) + (name-str (symbol-name name)) + (icon (nth 2 button)) + (xemacs-icon (mh-do-in-xemacs + (cdr (assoc (intern icon) mh-xemacs-icon-map)))) + (full-doc (nth 3 button)) + (doc (if (string-match "\\(.*\\)\n" full-doc) + (match-string 1 full-doc) + full-doc)) + (enable-expr (or (nth 4 button) t)) + (modes (nth 1 button)) + functions show-sym) + (when (memq 'letter modes) (setq functions `(:letter ,name))) + (when (or (memq 'folder modes) (memq 'sequence modes)) + (setq functions + (append `(,(if (memq 'folder modes) :folder :sequence) ,name) + functions)) + (setq show-sym + (if (string-match "^mh-\\(.*\\)$" name-str) + (intern (concat "mh-show-" (match-string 1 name-str))) + name)) + (setq functions + (append `(,(if (memq 'folder modes) :show :show-seq) + ,(if (fboundp show-sym) show-sym name)) + functions))) + (do ((functions functions (cddr functions))) + ((null functions)) + (let* ((type (car functions)) + (function (cadr functions)) + (type1 (substring (symbol-name type) 1)) + (vector-list (cond ((eq type :show) 'show-vectors) + ((eq type :show-seq) 'show-vectors) + ((eq type :letter) 'letter-vectors) + (t 'folder-vectors))) + (list (cond ((eq type :letter) 'mh-tool-bar-letter-buttons) + (t 'mh-tool-bar-folder-buttons))) + (key (intern (concat "mh-" type1 "tool-bar-" name-str))) + (setter (intern (concat type1 "-button-setter"))) + (mbuttons (cond ((eq type :letter) 'letter-buttons) + ((eq type :show) 'show-buttons) + ((eq type :show-seq) 'show-buttons) + (t 'folder-buttons))) + (docs (cond ((eq mbuttons 'letter-buttons) 'letter-docs) + ((eq mbuttons 'folder-buttons) 'folder-docs)))) + (add-to-list vector-list `[,xemacs-icon ,function t ,full-doc]) + (add-to-list + setter `(when (member ',name ,list) + (mh-funcall-if-exists + tool-bar-add-item ,icon ',function ',key + :help ,doc :enable ',enable-expr))) + (add-to-list mbuttons name) + (if docs (add-to-list docs doc)))))) + (setq folder-buttons (nreverse folder-buttons) + letter-buttons (nreverse letter-buttons) + show-buttons (nreverse show-buttons) + letter-docs (nreverse letter-docs) + folder-docs (nreverse folder-docs) + folder-vectors (nreverse folder-vectors) + show-vectors (nreverse show-vectors) + letter-vectors (nreverse letter-vectors)) + (dolist (x folder-defaults) + (unless (memq x folder-buttons) + (error "Folder defaults contains unknown button '%s'" x))) + (dolist (x letter-defaults) + (unless (memq x letter-buttons) + (error "Letter defaults contains unknown button '%s'" x))) + `(eval-when (compile load eval) + (defun mh-buffer-exists-p (mode) + "Test whether a buffer with major mode MODE is present." + (loop for buf in (buffer-list) + when (save-excursion + (set-buffer buf) + (eq major-mode mode)) + return t)) + + ;; GNU Emacs tool bar specific code + (mh-do-in-gnu-emacs + ;; Tool bar initialization functions + (defun mh-tool-bar-folder-buttons-init () + (when (mh-buffer-exists-p 'mh-folder-mode) + (mh-image-load-path) + (setq mh-folder-tool-bar-map + (let ((tool-bar-map (make-sparse-keymap))) + ,@(nreverse folder-button-setter) + tool-bar-map)) + (setq mh-show-tool-bar-map + (let ((tool-bar-map (make-sparse-keymap))) + ,@(nreverse show-button-setter) + tool-bar-map)) + (setq mh-show-seq-tool-bar-map + (let ((tool-bar-map (copy-keymap mh-show-tool-bar-map))) + ,@(nreverse show-seq-button-setter) + tool-bar-map)) + (setq mh-folder-seq-tool-bar-map + (let ((tool-bar-map (copy-keymap mh-folder-tool-bar-map))) + ,@(nreverse sequence-button-setter) + tool-bar-map)))) + (defun mh-tool-bar-letter-buttons-init () + (when (mh-buffer-exists-p 'mh-letter-mode) + (mh-image-load-path) + (setq mh-letter-tool-bar-map + (let ((tool-bar-map (make-sparse-keymap))) + ,@(nreverse letter-button-setter) + tool-bar-map)))) + ;; Custom setter functions + (defun mh-tool-bar-folder-buttons-set (symbol value) + "Construct tool bar for `mh-folder-mode' and `mh-show-mode'." + (set-default symbol value) + (mh-tool-bar-folder-buttons-init)) + (defun mh-tool-bar-letter-buttons-set (symbol value) + "Construct tool bar for `mh-letter-mode'." + (set-default symbol value) + (mh-tool-bar-letter-buttons-init))) + ;; XEmacs specific code + (mh-do-in-xemacs + (defvar mh-tool-bar-folder-vector-map + ',(loop for button in folder-buttons + for vector in folder-vectors + collect (cons button vector))) + (defvar mh-tool-bar-show-vector-map + ',(loop for button in show-buttons + for vector in show-vectors + collect (cons button vector))) + (defvar mh-tool-bar-letter-vector-map + ',(loop for button in letter-buttons + for vector in letter-vectors + collect (cons button vector))) + (defvar mh-tool-bar-folder-buttons nil) + (defvar mh-tool-bar-show-buttons nil) + (defvar mh-tool-bar-letter-buttons nil) + ;; Custom setter functions + (defun mh-tool-bar-letter-buttons-set (symbol value) + (set-default symbol value) + (when mh-xemacs-has-tool-bar-flag + (setq mh-tool-bar-letter-buttons + (loop for b in value + collect (cdr (assoc b mh-tool-bar-letter-vector-map)))))) + (defun mh-tool-bar-folder-buttons-set (symbol value) + (set-default symbol value) + (when mh-xemacs-has-tool-bar-flag + (setq mh-tool-bar-folder-buttons + (loop for b in value + collect (cdr (assoc b mh-tool-bar-folder-vector-map)))) + (setq mh-tool-bar-show-buttons + (loop for b in value + collect (cdr (assoc b mh-tool-bar-show-vector-map)))))) + (defun mh-tool-bar-init (mode) + "Install tool bar in MODE." + (let ((tool-bar (cond ((eq mode :folder) mh-tool-bar-folder-buttons) + ((eq mode :letter) mh-tool-bar-letter-buttons) + ((eq mode :show) mh-tool-bar-show-buttons))) + (height 37) + (width 40) + (buffer (current-buffer))) + (when mh-xemacs-use-tool-bar-flag + (cond + ((eq mh-xemacs-tool-bar-position 'top) + (set-specifier top-toolbar tool-bar buffer) + (set-specifier top-toolbar-visible-p t) + (set-specifier top-toolbar-height height)) + ((eq mh-xemacs-tool-bar-position 'bottom) + (set-specifier bottom-toolbar tool-bar buffer) + (set-specifier bottom-toolbar-visible-p t) + (set-specifier bottom-toolbar-height height)) + ((eq mh-xemacs-tool-bar-position 'left) + (set-specifier left-toolbar tool-bar buffer) + (set-specifier left-toolbar-visible-p t) + (set-specifier left-toolbar-width width)) + ((eq mh-xemacs-tool-bar-position 'right) + (set-specifier right-toolbar tool-bar buffer) + (set-specifier right-toolbar-visible-p t) + (set-specifier right-toolbar-width width)) + (t (set-specifier default-toolbar tool-bar buffer))))))) + ;; Declare customizable tool bars + (custom-declare-variable + 'mh-tool-bar-folder-buttons + '(list ,@(mapcar (lambda (x) `(quote ,x)) folder-defaults)) + "List of buttons to include in MH-Folder tool bar." + :group 'mh-tool-bar :set 'mh-tool-bar-folder-buttons-set + :type '(set ,@(loop for x in folder-buttons + for y in folder-docs + collect `(const :tag ,y ,x)))) + (custom-declare-variable + 'mh-tool-bar-letter-buttons + '(list ,@(mapcar (lambda (x) `(quote ,x)) letter-defaults)) + "List of buttons to include in MH-Letter tool bar." + :group 'mh-tool-bar :set 'mh-tool-bar-letter-buttons-set + :type '(set ,@(loop for x in letter-buttons + for y in letter-docs + collect `(const :tag ,y ,x))))))) + +(mh-tool-bar-define + ((:folder mh-inc-folder mh-mime-save-parts mh-previous-undeleted-msg + mh-page-msg mh-next-undeleted-msg mh-delete-msg mh-refile-msg + mh-undo mh-execute-commands mh-toggle-tick mh-reply + mh-alias-grab-from-field mh-send mh-rescan-folder + mh-tool-bar-search mh-visit-folder + mh-tool-bar-customize mh-tool-bar-folder-help mh-widen) + (:letter mh-send-letter mh-compose-insertion ispell-message save-buffer + undo kill-region menu-bar-kill-ring-save yank mh-fully-kill-draft + mh-tool-bar-customize mh-tool-bar-letter-help)) + ;; Folder/Show buffer buttons + (mh-inc-folder (folder) "mail" + "Incorporate new mail in Inbox +This button runs `mh-inc-folder' which drags any +new mail into your Inbox folder.") + (mh-mime-save-parts (folder) "attach" + "Save MIME parts from this message +This button runs `mh-mime-save-parts' which saves a message's +different parts into separate files.") + (mh-previous-undeleted-msg (folder) "left-arrow" + "Go to the previous undeleted message +This button runs `mh-previous-undeleted-msg'") + (mh-page-msg (folder) "page-down" + "Page the current message forwards\nThis button runs `mh-page-msg'") + (mh-next-undeleted-msg (folder) "right-arrow" + "Go to the next undeleted message\nThe button runs `mh-next-undeleted-msg'") + (mh-delete-msg (folder) "close" + "Mark this message for deletion\nThis button runs `mh-delete-msg'") + (mh-refile-msg (folder) "mail/refile" + "Refile this message\nThis button runs `mh-refile-msg'") + (mh-undo (folder) "undo" "Undo last operation\nThis button runs `undo'" + (mh-outstanding-commands-p)) + (mh-execute-commands (folder) "execute" + "Perform moves and deletes\nThis button runs `mh-execute-commands'" + (mh-outstanding-commands-p)) + (mh-toggle-tick (folder) "highlight" + "Toggle tick mark\nThis button runs `mh-toggle-tick'") + (mh-toggle-showing (folder) "show" + "Toggle showing message\nThis button runs `mh-toggle-showing'") + (mh-tool-bar-reply-from (folder) "mail/reply-from" "Reply to \"from\"") + (mh-tool-bar-reply-to (folder) "mail/reply-to" "Reply to \"to\"") + (mh-tool-bar-reply-all (folder) "mail/reply-all" "Reply to \"all\"") + (mh-reply (folder) "mail/reply" + "Reply to this message\nThis button runs `mh-reply'") + (mh-alias-grab-from-field (folder) "mail/alias" + "Grab From alias\nThis button runs `mh-alias-grab-from-field'" + (and (mh-extract-from-header-value) (not (mh-alias-for-from-p)))) + (mh-send (folder) "mail/compose" + "Compose new message\nThis button runs `mh-send'") + (mh-rescan-folder (folder) "refresh" + "Rescan this folder\nThis button runs `mh-rescan-folder'") + (mh-pack-folder (folder) "mail/repack" + "Repack this folder\nThis button runs `mh-pack-folder'") + (mh-tool-bar-search (folder) "search" + "Search\nThis button runs `mh-tool-bar-search-function'") + (mh-visit-folder (folder) "fld-open" + "Visit other folder\nThis button runs `mh-visit-folder'") + ;; Letter buffer buttons + (mh-send-letter (letter) "mail/send" "Send this letter") + (mh-compose-insertion (letter) "attach" "Insert attachment") + (ispell-message (letter) "spell" "Check spelling") + (save-buffer (letter) "save" "Save current buffer to its file" + (buffer-modified-p)) + (undo (letter) "undo" "Undo last operation") + (kill-region (letter) "cut" + "Cut (kill) text in region between mark and current position") + (menu-bar-kill-ring-save (letter) "copy" + "Copy text in region between mark and current position") + (yank (letter) "paste" "Paste (yank) text cut or copied earlier") + (mh-fully-kill-draft (letter) "close" "Kill this draft") + ;; Common buttons + (mh-tool-bar-customize (folder letter) "preferences" "MH-E Preferences") + (mh-tool-bar-folder-help (folder) "help" + "Help! (general help)\nThis button runs `info'") + (mh-tool-bar-letter-help (letter) "help" + "Help! (general help)\nThis button runs `info'") + ;; Folder narrowed to sequence buttons + (mh-widen (sequence) "widen" + "Widen from the sequence\nThis button runs `mh-widen'")) + +(provide 'mh-tool-bar) + +;; Local Variables: +;; indent-tabs-mode: nil +;; sentence-end-double-space: nil +;; End: + +;; arch-tag: 28c2436d-bb8d-486a-a8d7-5a4d9cae3513 +;;; mh-tool-bar.el ends here |