;;; mh-tool-bar.el --- MH-E tool bar support
-;; Copyright (C) 2002, 2003, 2005, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 2002-2003, 2005-2013 Free Software Foundation, Inc.
;; Author: Satyaki Das <satyaki@theforce.stanford.edu>
;; Maintainer: Bill Wohler <wohler@newt.com>
;; This file is part of GNU Emacs.
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; 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.
+;; the Free Software Foundation, either version 3 of the License, 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
;; 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.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(require 'mh-e)
+(mh-do-in-gnu-emacs
+ (require 'tool-bar))
+(mh-do-in-xemacs
+ (require 'toolbar))
;;; Tool Bar Commands
;;; Tool Bar Creation
+;; Shush compiler.
+(defvar image-load-path)
+
(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
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
+ evaluates to nil, then the button is inactive, 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.
(name-str (symbol-name name))
(icon (nth 2 button))
(xemacs-icon (mh-do-in-xemacs
- (cdr (assoc (intern icon) mh-xemacs-icon-map))))
+ `(cdr (assoc (quote ,(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))
+ (enable-expr (if (eql (length button) 4) t (nth 4 button)))
(modes (nth 1 button))
functions show-sym)
(when (memq 'letter modes) (setq functions `(:letter ,name)))
(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)))
+ (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)
(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 vector-list `(vector ,xemacs-icon ',function t ,full-doc))
(add-to-list
setter `(when (member ',name ,list)
(mh-funcall-if-exists
letter-vectors (nreverse letter-vectors))
(dolist (x folder-defaults)
(unless (memq x folder-buttons)
- (error "Folder defaults contains unknown button '%s'" x)))
+ (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)))
+ (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
+ (defun mh-buffer-exists-p (mode)
+ "Test whether a buffer with major mode MODE is present."
+ (loop for buf in (buffer-list)
+ when (with-current-buffer buf
+ (eq major-mode mode))
+ return t))
;; 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))))
+ (let* ((load-path (mh-image-load-path-for-library "mh-e"
+ "mh-logo.xpm"))
+ (image-load-path (cons (car load-path)
+ (when (boundp 'image-load-path)
+ 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-folder-seq-tool-bar-map
+ (let ((tool-bar-map (copy-keymap mh-folder-tool-bar-map)))
+ ,@(nreverse sequence-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)))))
(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))))
+ (let* ((load-path (mh-image-load-path-for-library "mh-e"
+ "mh-logo.xpm"))
+ (image-load-path (cons (car load-path)
+ (when (boundp 'image-load-path)
+ 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-update (mode default-map sequence-map)
+ "Update `tool-bar-map' in all buffers of MODE.
+Use SEQUENCE-MAP if display is limited; DEFAULT-MAP otherwise."
+ (loop for buf in (buffer-list)
+ do (with-current-buffer buf
+ (if (eq mode major-mode)
+ (let ((map (if mh-folder-view-stack
+ sequence-map
+ default-map)))
+ ;; Yes, make-local-variable is necessary since we
+ ;; get here during initialization when loading
+ ;; mh-e.el, after the +inbox buffer has been
+ ;; created, but before mh-folder-mode has run and
+ ;; created the local map.
+ (set (make-local-variable 'tool-bar-map) map))))))
(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))
+ (mh-tool-bar-folder-buttons-init)
+ (mh-tool-bar-update 'mh-folder-mode mh-folder-tool-bar-map
+ mh-folder-seq-tool-bar-map)
+ (mh-tool-bar-update 'mh-show-mode mh-show-tool-bar-map
+ mh-show-seq-tool-bar-map))
(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)))
+ (mh-tool-bar-letter-buttons-init)
+ (mh-tool-bar-update 'mh-letter-mode mh-letter-tool-bar-map
+ mh-letter-tool-bar-map)))
;; 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)))
+ (list ,@(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)))
+ (list ,@(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)
+ (list ,@(loop for button in letter-buttons
+ for vector in letter-vectors
+ collect `(cons ',button ,vector))))
+ (defvar mh-tool-bar-folder-buttons)
+ (defvar mh-tool-bar-show-buttons)
+ (defvar mh-tool-bar-letter-buttons)
;; 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))))))
+ 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
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
+ (when mh-xemacs-use-tool-bar-flag
+ (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)))
(cond
((eq mh-xemacs-tool-bar-position 'top)
(set-specifier top-toolbar tool-bar buffer)
'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
+ :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))))
+ collect `(const :tag ,y ,x)))
+ ;;:package-version '(MH-E "7.1")
+ )
(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
+ :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)))))))
+ collect `(const :tag ,y ,x)))
+ ;;:package-version '(MH-E "7.1")
+ ))))
+;; The icon names are duplicated in the Makefile and mh-xemacs.el.
(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
+ ((: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 save-buffer mh-fully-kill-draft
+ mh-compose-insertion ispell-message undo
+ clipboard-kill-region clipboard-kill-ring-save
+ clipboard-yank mh-tool-bar-customize
+ mh-tool-bar-letter-help))
+ ;; Folder/Show buffer buttons
+ (mh-inc-folder (folder) "mail/inbox" "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
+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
+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'"))
+ (mh-page-msg (folder) "next-page" "Page the current message forwards
+This button runs `mh-page-msg'")
+ (mh-next-undeleted-msg (folder) "right-arrow" "Go to the next undeleted message
+The button runs `mh-next-undeleted-msg'")
+ (mh-delete-msg (folder) "delete" "Mark this message for deletion
+This button runs `mh-delete-msg'")
+ (mh-refile-msg (folder) "mail/move" "Refile this message
+This button runs `mh-refile-msg'")
+ (mh-undo (folder) "undo" "Undo last operation
+This button runs `undo'"
+ (mh-outstanding-commands-p))
+ (mh-execute-commands (folder) "data-save" "Perform moves and deletes
+This button runs `mh-execute-commands'"
+ (mh-outstanding-commands-p))
+ (mh-toggle-tick (folder) "mail/flag-for-followup" "Toggle tick mark
+This button runs `mh-toggle-tick'")
+ (mh-toggle-showing (folder) "show" "Toggle showing message
+This button runs `mh-toggle-showing'")
+ (mh-reply (folder) "mail/reply" "Reply to this message
+This button runs `mh-reply'")
+ (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-alias-grab-from-field (folder) "contact" "Create alias for sender
+This 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
+This button runs `mh-send'")
+ (mh-rescan-folder (folder) "refresh" "Rescan this folder
+This button runs `mh-rescan-folder'")
+ (mh-pack-folder (folder) "mail/repack" "Repack this folder
+This button runs `mh-pack-folder'")
+ (mh-tool-bar-search (folder) "search" "Search
+This button runs `mh-tool-bar-search-function'")
+ (mh-visit-folder (folder) "open" "Visit other folder
+This button runs `mh-visit-folder'")
+ ;; Letter buffer buttons
+ (mh-send-letter (letter) "mail/send" "Send this letter")
+ (save-buffer (letter) "save" "Save current buffer to its file"
+ (buffer-modified-p))
+ (mh-fully-kill-draft (letter) "delete" "Kill this draft")
+ (mh-compose-insertion (letter) "attach" "Insert attachment")
+ (ispell-message (letter) "spell" "Check spelling")
+ (undo (letter) "undo" "Undo last operation")
+ (clipboard-kill-region (letter) "cut"
+ "Cut (kill) text in region")
+ (clipboard-kill-ring-save (letter) "copy"
+ "Copy text in region")
+ (clipboard-yank (letter) "paste"
+ "Paste (yank) text cut or copied earlier")
+ ;; Common buttons
+ (mh-tool-bar-customize (folder letter) "preferences" "MH-E Preferences")
+ (mh-tool-bar-folder-help (folder) "help" "Help! (general help)
+This button runs `info'")
+ (mh-tool-bar-letter-help (letter) "help" "Help! (general help)
+This button runs `info'")
+ ;; Folder narrowed to sequence buttons
+ (mh-widen (sequence) "zoom-out" "Widen from the sequence
+This button runs `mh-widen'"))
(provide 'mh-tool-bar)
;; sentence-end-double-space: nil
;; End:
-;; arch-tag: 28c2436d-bb8d-486a-a8d7-5a4d9cae3513
;;; mh-tool-bar.el ends here
HCoop / bpt / emacs.git / blobdiff