diff options
Diffstat (limited to 'lisp/mh-e/mh-utils.el')
| -rw-r--r-- | lisp/mh-e/mh-utils.el | 2374 |
1 files changed, 401 insertions, 1973 deletions
diff --git a/lisp/mh-e/mh-utils.el b/lisp/mh-e/mh-utils.el index 111dfd2e6cd..a777cbfa68a 100644 --- a/lisp/mh-e/mh-utils.el +++ b/lisp/mh-e/mh-utils.el @@ -1,4 +1,4 @@ -;;; mh-utils.el --- MH-E code needed for both sending and reading +;;; mh-utils.el --- MH-E general utilities ;; Copyright (C) 1993, 1995, 1997, ;; 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. @@ -27,53 +27,18 @@ ;;; Commentary: -;; Internal support for MH-E package. - ;;; Change Log: ;;; Code: -;;(message "> mh-utils") -(eval-and-compile - (defvar recursive-load-depth-limit) - (if (and (boundp 'recursive-load-depth-limit) - (integerp recursive-load-depth-limit) - (< recursive-load-depth-limit 50)) - (setq recursive-load-depth-limit 50))) - -(eval-when-compile (require 'mh-acros)) +(require 'mh-e) (mh-require-cl) (require 'font-lock) -(require 'gnus-util) -(require 'mh-buffers) -(require 'mh-customize) -(require 'mh-inc) -(require 'mouse) -(require 'sendmail) -;;(message "< mh-utils") - -;; Non-fatal dependencies -(load "hl-line" t t) -(load "mm-decode" t t) -(load "mm-view" t t) -(load "tool-bar" t t) -(load "vcard" t t) - - - -;;; Autoloads - -(autoload 'gnus-article-highlight-citation "gnus-cite") -(autoload 'message-fetch-field "message") -(autoload 'message-tokenize-header "message") -(unless (fboundp 'make-hash-table) - (autoload 'make-hash-table "cl")) - - ;;; CL Replacements +;;;###mh-autoload (defun mh-search-from-end (char string) "Return the position of last occurrence of CHAR in STRING. If CHAR is not present in STRING then return nil. The function is @@ -82,476 +47,104 @@ used in lieu of `search' in the CL package." when (equal (aref string index) char) return index finally return nil)) -;; Additional header fields that might someday be added: -;; "Sender: " "Reply-to: " - - - -;;; Scan Line Formats - -(defvar mh-scan-msg-number-regexp "^ *\\([0-9]+\\)" - "This regular expression extracts the message number. - -It must match from the beginning of the line. Note that the -message number must be placed in a parenthesized expression as in -the default of \"^ *\\\\([0-9]+\\\\)\".") - -(defvar mh-scan-msg-overflow-regexp "^[?0-9][0-9]" - "This regular expression matches overflowed message numbers.") - -(defvar mh-scan-msg-format-regexp "%\\([0-9]*\\)(msg)" - "This regular expression finds the message number width in a scan format. - -Note that the message number must be placed in a parenthesized -expression as in the default of \"%\\\\([0-9]*\\\\)(msg)\". This -variable is only consulted if `mh-scan-format-file' is set to -\"Use MH-E scan Format\".") - -(defvar mh-scan-msg-format-string "%d" - "This is a format string for width of the message number in a scan format. - -Use \"0%d\" for zero-filled message numbers. This variable is only -consulted if `mh-scan-format-file' is set to \"Use MH-E scan -Format\".") - -(defvar mh-scan-msg-search-regexp "^[^0-9]*%d[^0-9]" - "This regular expression matches a particular message. - -It is a format string; use \"%d\" to represent the location of the -message number within the expression as in the default of -\"^[^0-9]*%d[^0-9]\".") - -(defvar mh-cmd-note 4 - "Column for notations. - -This variable should be set with the function `mh-set-cmd-note'. -This variable may be updated dynamically if -`mh-adaptive-cmd-note-flag' is on. - -Note that columns in Emacs start with 0.") -(make-variable-buffer-local 'mh-cmd-note) - -(defvar mh-note-seq ?% - "Messages in a user-defined sequence are marked by this character. - -Messages in the \"search\" sequence are marked by this character as -well.") - - - -(defvar mh-show-buffer-mode-line-buffer-id " {show-%s} %d" - "Format string to produce `mode-line-buffer-identification' for show buffers. - -First argument is folder name. Second is message number.") - - - -(defvar mh-mail-header-separator "--------" - "*Line used by MH to separate headers from text in messages being composed. - -This variable should not be used directly in programs. Programs -should use `mail-header-separator' instead. -`mail-header-separator' is initialized to -`mh-mail-header-separator' in `mh-letter-mode'; in other -contexts, you may have to perform this initialization yourself. - -Do not make this a regular expression as it may be the argument -to `insert' and it is passed through `regexp-quote' before being -used by functions like `re-search-forward'.") - -(defvar mh-signature-separator-regexp "^-- $" - "This regular expression matches the signature separator. -See `mh-signature-separator'.") - -(defvar mh-signature-separator "-- \n" - "Text of a signature separator. - -A signature separator is used to separate the body of a message -from the signature. This can be used by user agents such as MH-E -to render the signature differently or to suppress the inclusion -of the signature in a reply. Use `mh-signature-separator-regexp' -when searching for a separator.") - -(defun mh-signature-separator-p () - "Return non-nil if buffer includes \"^-- $\"." - (save-excursion - (goto-char (point-min)) - (re-search-forward mh-signature-separator-regexp nil t))) - -;; Variables for MIME display - -;; Structure to keep track of MIME handles on a per buffer basis. -(mh-defstruct (mh-buffer-data (:conc-name mh-mime-) - (:constructor mh-make-buffer-data)) - (handles ()) ; List of MIME handles - (handles-cache (make-hash-table)) ; Cache to avoid multiple decodes of - ; nested messages - (parts-count 0) ; The button number is generated from - ; this number - (part-index-hash (make-hash-table))) ; Avoid incrementing the part number - ; for nested messages - -;; This has to be a macro, since we do: (setf (mh-buffer-data) ...) -(defmacro mh-buffer-data () - "Convenience macro to get the MIME data structures of the current buffer." - `(gethash (current-buffer) mh-globals-hash)) - -(defvar mh-globals-hash (make-hash-table) - "Keeps track of MIME data on a per buffer basis.") - -(defvar mh-mm-inline-media-tests - `(("image/jpeg" - mm-inline-image - (lambda (handle) - (mm-valid-and-fit-image-p 'jpeg handle))) - ("image/png" - mm-inline-image - (lambda (handle) - (mm-valid-and-fit-image-p 'png handle))) - ("image/gif" - mm-inline-image - (lambda (handle) - (mm-valid-and-fit-image-p 'gif handle))) - ("image/tiff" - mm-inline-image - (lambda (handle) - (mm-valid-and-fit-image-p 'tiff handle)) ) - ("image/xbm" - mm-inline-image - (lambda (handle) - (mm-valid-and-fit-image-p 'xbm handle))) - ("image/x-xbitmap" - mm-inline-image - (lambda (handle) - (mm-valid-and-fit-image-p 'xbm handle))) - ("image/xpm" - mm-inline-image - (lambda (handle) - (mm-valid-and-fit-image-p 'xpm handle))) - ("image/x-pixmap" - mm-inline-image - (lambda (handle) - (mm-valid-and-fit-image-p 'xpm handle))) - ("image/bmp" - mm-inline-image - (lambda (handle) - (mm-valid-and-fit-image-p 'bmp handle))) - ("image/x-portable-bitmap" - mm-inline-image - (lambda (handle) - (mm-valid-and-fit-image-p 'pbm handle))) - ("text/plain" mm-inline-text identity) - ("text/enriched" mm-inline-text identity) - ("text/richtext" mm-inline-text identity) - ("text/x-patch" mm-display-patch-inline - (lambda (handle) - (locate-library "diff-mode"))) - ("application/emacs-lisp" mm-display-elisp-inline identity) - ("application/x-emacs-lisp" mm-display-elisp-inline identity) - ("text/html" - ,(if (fboundp 'mm-inline-text-html) 'mm-inline-text-html 'mm-inline-text) - (lambda (handle) - (or (and (boundp 'mm-inline-text-html-renderer) - mm-inline-text-html-renderer) - (and (boundp 'mm-text-html-renderer) mm-text-html-renderer)))) - ("text/x-vcard" - mm-inline-text-vcard - (lambda (handle) - (or (featurep 'vcard) - (locate-library "vcard")))) - ("message/delivery-status" mm-inline-text identity) - ("message/rfc822" mh-mm-inline-message identity) - ;;("message/partial" mm-inline-partial identity) - ;;("message/external-body" mm-inline-external-body identity) - ("text/.*" mm-inline-text identity) - ("audio/wav" mm-inline-audio - (lambda (handle) - (and (or (featurep 'nas-sound) (featurep 'native-sound)) - (device-sound-enabled-p)))) - ("audio/au" - mm-inline-audio - (lambda (handle) - (and (or (featurep 'nas-sound) (featurep 'native-sound)) - (device-sound-enabled-p)))) - ("application/pgp-signature" ignore identity) - ("application/x-pkcs7-signature" ignore identity) - ("application/pkcs7-signature" ignore identity) - ("application/x-pkcs7-mime" ignore identity) - ("application/pkcs7-mime" ignore identity) - ("multipart/alternative" ignore identity) - ("multipart/mixed" ignore identity) - ("multipart/related" ignore identity) - ;; Disable audio and image - ("audio/.*" ignore ignore) - ("image/.*" ignore ignore) - ;; Default to displaying as text - (".*" mm-inline-text mm-readable-p)) - "Alist of media types/tests saying whether types can be displayed inline.") - -;; Copy of `goto-address-mail-regexp' -(defvar mh-address-mail-regexp - "[-a-zA-Z0-9._]+@\\([-a-zA-z0-9_]+\\.\\)+[a-zA-Z0-9]+" - "A regular expression probably matching an e-mail address.") - -;; From goto-addr.el, which we don't want to force-load on users. - -(defun mh-goto-address-find-address-at-point () - "Find e-mail address around or before point. - -Then search backwards to beginning of line for the start of an -e-mail address. If no e-mail address found, return nil." - (re-search-backward "[^-_A-z0-9.@]" (line-beginning-position) 'lim) - (if (or (looking-at mh-address-mail-regexp) ; already at start - (and (re-search-forward mh-address-mail-regexp - (line-end-position) 'lim) - (goto-char (match-beginning 0)))) - (match-string-no-properties 0))) - -(defun mh-mail-header-end () - "Substitute for `mail-header-end' that doesn't widen the buffer. - -In MH-E we frequently need to find the end of headers in nested -messages, where the buffer has been narrowed. This function works -in this situation." - (save-excursion - ;; XXX: The following replaces a call to rfc822-goto-eoh. Occasionally, - ;; mail headers that MH-E has to read contains lines of the form: - ;; From xxx@yyy Mon May 10 11:48:07 2004 - ;; In this situation, rfc822-goto-eoh doesn't go to the end of the - ;; header. The replacement allows From_ lines in the mail header. - (goto-char (point-min)) - (loop for p = (re-search-forward - "^\\([:\n]\\|[^: \t\n]+[ \t\n]\\)" nil 'move) - do (cond ((null p) (return)) - (t (goto-char (match-beginning 0)) - (unless (looking-at "From ") (return)) - (goto-char p)))) - (point))) - -(defun mh-in-header-p () - "Return non-nil if the point is in the header of a draft message." - (< (point) (mh-mail-header-end))) - -(defun mh-header-field-beginning () - "Move to the beginning of the current header field. -Handles RFC 822 continuation lines." - (beginning-of-line) - (while (looking-at "^[ \t]") - (forward-line -1))) - -(defun mh-header-field-end () - "Move to the end of the current header field. -Handles RFC 822 continuation lines." - (forward-line 1) - (while (looking-at "^[ \t]") - (forward-line 1)) - (backward-char 1)) ;to end of previous line - -(defun mh-letter-header-font-lock (limit) - "Return the entire mail header to font-lock. -Argument LIMIT limits search." - (if (= (point) limit) - nil - (let* ((mail-header-end (save-match-data (mh-mail-header-end))) - (lesser-limit (if (< mail-header-end limit) mail-header-end limit))) - (when (mh-in-header-p) - (set-match-data (list 1 lesser-limit)) - (goto-char lesser-limit) - t)))) - -(defun mh-header-field-font-lock (field limit) - "Return the value of a header field FIELD to font-lock. -Argument LIMIT limits search." - (if (= (point) limit) - nil - (let* ((mail-header-end (mh-mail-header-end)) - (lesser-limit (if (< mail-header-end limit) mail-header-end limit)) - (case-fold-search t)) - (when (and (< (point) mail-header-end) ;Only within header - (re-search-forward (format "^%s" field) lesser-limit t)) - (let ((match-one-b (match-beginning 0)) - (match-one-e (match-end 0))) - (mh-header-field-end) - (if (> (point) limit) ;Don't search for end beyond limit - (goto-char limit)) - (set-match-data (list match-one-b match-one-e - (1+ match-one-e) (point))) - t))))) - -(defun mh-header-to-font-lock (limit) - "Return the value of a header field To to font-lock. -Argument LIMIT limits search." - (mh-header-field-font-lock "To:" limit)) - -(defun mh-header-cc-font-lock (limit) - "Return the value of a header field cc to font-lock. -Argument LIMIT limits search." - (mh-header-field-font-lock "cc:" limit)) - -(defun mh-header-subject-font-lock (limit) - "Return the value of a header field Subject to font-lock. -Argument LIMIT limits search." - (mh-header-field-font-lock "Subject:" limit)) - -(eval-and-compile - ;; Otherwise byte-compilation fails on `mh-show-font-lock-keywords-with-cite' - (defvar mh-show-font-lock-keywords - '(("^\\(From:\\|Sender:\\)\\(.*\\)" - (1 'default) - (2 'mh-show-from)) - (mh-header-to-font-lock - (0 'default) - (1 'mh-show-to)) - (mh-header-cc-font-lock - (0 'default) - (1 'mh-show-cc)) - ("^\\(Reply-To:\\|Return-Path:\\)\\(.*\\)$" - (1 'default) - (2 'mh-show-from)) - (mh-header-subject-font-lock - (0 'default) - (1 'mh-show-subject)) - ("^\\(Apparently-To:\\|Newsgroups:\\)\\(.*\\)" - (1 'default) - (2 'mh-show-cc)) - ("^\\(In-reply-to\\|Date\\):\\(.*\\)$" - (1 'default) - (2 'mh-show-date)) - (mh-letter-header-font-lock - (0 'mh-show-header append t))) - "Additional expressions to highlight in MH-Show buffers.")) - -(defvar mh-show-font-lock-keywords-with-cite - (eval-when-compile - (let* ((cite-chars "[>|}]") - (cite-prefix "A-Za-z") - (cite-suffix (concat cite-prefix "0-9_.@-`'\""))) - (append - mh-show-font-lock-keywords - (list - ;; Use MATCH-ANCHORED to effectively anchor the regexp left side. - `(,cite-chars - (,(concat "\\=[ \t]*" - "\\(\\([" cite-prefix "]+[" cite-suffix "]*\\)?" - "\\(" cite-chars "[ \t]*\\)\\)+" - "\\(.*\\)") - (beginning-of-line) (end-of-line) - (2 font-lock-constant-face nil t) - (4 font-lock-comment-face nil t))))))) - "Additional expressions to highlight in MH-Show buffers.") - -(defvar mh-letter-font-lock-keywords - `(,@mh-show-font-lock-keywords-with-cite - (mh-font-lock-field-data - (1 'mh-letter-header-field prepend t))) - "Additional expressions to highlight in MH-Letter buffers.") - -(defun mh-show-font-lock-fontify-region (beg end loudly) - "Limit font-lock in `mh-show-mode' to the header. - -Used when the option `mh-highlight-citation-style' is set to -\"Gnus\", leaving the body to be dealt with by Gnus highlighting. -The region between BEG and END is given over to be fontified and -LOUDLY controls if a user sees a message about the fontification -operation." - (let ((header-end (mh-mail-header-end))) - (cond - ((and (< beg header-end)(< end header-end)) - (font-lock-default-fontify-region beg end loudly)) - ((and (< beg header-end)(>= end header-end)) - (font-lock-default-fontify-region beg header-end loudly)) - (t - nil)))) - -;; Shush compiler. -(if mh-xemacs-flag - (eval-and-compile - (require 'gnus) - (require 'gnus-art) - (require 'gnus-cite))) - -(defun mh-gnus-article-highlight-citation () - "Highlight cited text in current buffer using Gnus." - (interactive) - ;; Requiring gnus-cite should have been sufficient. However for Emacs21.1, - ;; recursive-load-depth-limit is only 10, so an error occurs. Also it may be - ;; better to have an autoload at top-level (though that won't work because - ;; of recursive-load-depth-limit). That gets rid of a compiler warning as - ;; well. - (unless mh-xemacs-flag - (require 'gnus-art) - (require 'gnus-cite)) - ;; Don't allow Gnus to create buttons while highlighting, maybe this is bad - ;; style? - (flet ((gnus-article-add-button (&rest args) nil)) - (let* ((modified (buffer-modified-p)) - (gnus-article-buffer (buffer-name)) - (gnus-cite-face-list `(,@(cdr gnus-cite-face-list) - ,(car gnus-cite-face-list)))) - (gnus-article-highlight-citation t) - (set-buffer-modified-p modified)))) - -;;; Internal bookkeeping variables: - -(defvar mh-user-path nil - "Cached value of the \"Path:\" MH profile component. -User's mail folder directory.") - -(defvar mh-draft-folder nil - "Cached value of the \"Draft-Folder:\" MH profile component. -Name of folder containing draft messages. -Nil means do not use a draft folder.") - -(defvar mh-unseen-seq nil - "Cached value of the \"Unseen-Sequence:\" MH profile component. -Name of the Unseen sequence.") +;;; General Utilities -(defvar mh-previous-seq nil - "Cached value of the \"Previous-Sequence:\" MH profile component. -Name of the Previous sequence.") +(require 'mailabbrev nil t) +(mh-defun-compat mail-abbrev-make-syntax-table () + "Emacs 21 and XEmacs don't have this function." + nil) -(defvar mh-inbox nil - "Cached value of the \"Inbox:\" MH profile component. -Set to \"+inbox\" if no such component. -Name of the Inbox folder.") - -(defvar mh-previous-window-config nil - "Window configuration before MH-E command.") +;;;###mh-autoload +(defun mh-beginning-of-word (&optional n) + "Return position of the N th word backwards." + (unless n (setq n 1)) + (let ((syntax-table (syntax-table))) + (unwind-protect + (save-excursion + (mail-abbrev-make-syntax-table) + (set-syntax-table mail-abbrev-syntax-table) + (backward-word n) + (point)) + (set-syntax-table syntax-table)))) + +;;;###mh-autoload +(defun mh-colors-available-p () + "Check if colors are available in the Emacs being used." + (or mh-xemacs-flag + (let ((color-cells (display-color-cells))) + (and (numberp color-cells) (>= color-cells 8))))) + +;;;###mh-autoload +(defun mh-colors-in-use-p () + "Check if colors are being used in the folder buffer." + (and mh-colors-available-flag font-lock-mode)) + +;;;###mh-autoload +(defun mh-delete-line (lines) + "Delete the next LINES lines." + (delete-region (point) (progn (forward-line lines) (point)))) -(defvar mh-page-to-next-msg-flag nil - "Non-nil means next SPC or whatever goes to next undeleted message.") +(defvar mh-image-load-path-called-flag nil) + +;;;###mh-autoload +(defun mh-image-load-path () + "Ensure that the MH-E images are accessible by `find-image'. +Images for MH-E are found in ../../etc/images relative to the +files in \"lisp/mh-e\". If `image-load-path' exists (since Emacs +22), then the images directory is added to it if isn't already +there. Otherwise, the images directory is added to the +`load-path' if it isn't already there." + (unless mh-image-load-path-called-flag + (let (mh-library-name mh-image-load-path) + ;; First, find mh-e in the load-path. + (setq mh-library-name (locate-library "mh-e")) + (if (not mh-library-name) + (error "Can not find MH-E in load-path")) + (setq mh-image-load-path + (expand-file-name (concat (file-name-directory mh-library-name) + "../../etc/images"))) + (if (not (file-exists-p mh-image-load-path)) + (error "Can not find image directory %s" mh-image-load-path)) + (if (boundp 'image-load-path) + (add-to-list 'image-load-path mh-image-load-path) + (add-to-list 'load-path mh-image-load-path))) + (setq mh-image-load-path-called-flag t))) + +;;;###mh-autoload +(defun mh-make-local-vars (&rest pairs) + "Initialize local variables according to the variable-value PAIRS." + (while pairs + (set (make-local-variable (car pairs)) (car (cdr pairs))) + (setq pairs (cdr (cdr pairs))))) + +;;;###mh-autoload +(defun mh-mapc (function list) + "Apply FUNCTION to each element of LIST for side effects only." + (while list + (funcall function (car list)) + (setq list (cdr list)))) + +;;;###mh-autoload +(defun mh-replace-string (old new) + "Replace all occurrences of OLD with NEW in the current buffer. +Ignores case when searching for OLD." + (goto-char (point-min)) + (let ((case-fold-search t)) + (while (search-forward old nil t) + (replace-match new t t)))) -;;; Internal variables local to a folder. - -(defvar mh-current-folder nil - "Name of current folder, a string.") - -(defvar mh-show-buffer nil - "Buffer that displays message for this folder.") - -(defvar mh-folder-filename nil - "Full path of directory for this folder.") - -(defvar mh-msg-count nil - "Number of msgs in buffer.") - -(defvar mh-showing-mode nil - "If non-nil, show the message in a separate window.") - -(defvar mh-show-mode-map (make-sparse-keymap) - "Keymap used by the show buffer.") - -(defvar mh-show-folder-buffer nil - "Keeps track of folder whose message is being displayed.") +;;; Logo Display (defvar mh-logo-cache nil) +;;;###mh-autoload (defun mh-logo-display () "Modify mode line to display MH-E logo." + (mh-image-load-path) (mh-do-in-gnu-emacs (add-text-properties 0 2 @@ -569,1474 +162,223 @@ Name of the Inbox folder.") (cons modeline-buffer-id-left-extent "XEmacs%N:")) (cons modeline-buffer-id-right-extent " %17b"))))) -(defun mh-showing-mode (&optional arg) - "Change whether messages should be displayed. + -With ARG, display messages iff ARG is positive." - (setq mh-showing-mode - (if (null arg) - (not mh-showing-mode) - (> (prefix-numeric-value arg) 0)))) +;;; Read MH Profile + +(defvar mh-find-path-run nil + "Non-nil if `mh-find-path' has been run already. +Do not access this variable; `mh-find-path' already uses it to +avoid running more than once.") + +;;;###mh-autoload +(defun mh-find-path () + "Set variables from user's MH profile. + +This function sets `mh-user-path' from your \"Path:\" MH profile +component (but defaults to \"Mail\" if one isn't present), +`mh-draft-folder' from \"Draft-Folder:\", `mh-unseen-seq' from +\"Unseen-Sequence:\", `mh-previous-seq' from +\"Previous-Sequence:\", and `mh-inbox' from \"Inbox:\" (defaults +to \"+inbox\"). + +The hook `mh-find-path-hook' is run after these variables have +been set. This hook can be used the change the value of these +variables if you need to run with different values between MH and +MH-E." + (unless mh-find-path-run + ;; Sanity checks. + (if (and (getenv "MH") + (not (file-readable-p (getenv "MH")))) + (error "MH environment variable contains unreadable file %s" + (getenv "MH"))) + (if (null (mh-variants)) + (error "Install MH and run install-mh before running MH-E")) + (let ((profile "~/.mh_profile")) + (if (not (file-readable-p profile)) + (error "Run install-mh before running MH-E"))) + ;; Read MH profile. + (setq mh-user-path (mh-profile-component "Path")) + (if (not mh-user-path) + (setq mh-user-path "Mail")) + (setq mh-user-path + (file-name-as-directory + (expand-file-name mh-user-path (expand-file-name "~")))) + (mh-set-x-image-cache-directory (expand-file-name ".mhe-x-image-cache" + mh-user-path)) + (setq mh-draft-folder (mh-profile-component "Draft-Folder")) + (if mh-draft-folder + (progn + (if (not (mh-folder-name-p mh-draft-folder)) + (setq mh-draft-folder (format "+%s" mh-draft-folder))) + (if (not (file-exists-p (mh-expand-file-name mh-draft-folder))) + (error + "Draft folder \"%s\" not found; create it and try again" + (mh-expand-file-name mh-draft-folder))))) + (setq mh-inbox (mh-profile-component "Inbox")) + (cond ((not mh-inbox) + (setq mh-inbox "+inbox")) + ((not (mh-folder-name-p mh-inbox)) + (setq mh-inbox (format "+%s" mh-inbox)))) + (setq mh-unseen-seq (mh-profile-component "Unseen-Sequence")) + (if mh-unseen-seq + (setq mh-unseen-seq (intern mh-unseen-seq)) + (setq mh-unseen-seq 'unseen)) ;old MH default? + (setq mh-previous-seq (mh-profile-component "Previous-Sequence")) + (if mh-previous-seq + (setq mh-previous-seq (intern mh-previous-seq))) + (run-hooks 'mh-find-path-hook) + (mh-collect-folder-names) + (setq mh-find-path-run t))) -(defvar mh-seq-list nil - "Alist of this folder's sequences. -Elements have the form (SEQUENCE . MESSAGES).") + -(defvar mh-seen-list nil - "List of displayed messages to be removed from the \"Unseen\" sequence.") +;;; Help Functions -(defvar mh-showing-with-headers nil - "If non-nil, MH-Show buffer contains message with all header fields. -If nil, MH-Show buffer contains message processed normally.") +;;;###mh-autoload +(defun mh-ephem-message (string) + "Display STRING in the minibuffer momentarily." + (message "%s" string) + (sit-for 5) + (message "")) - +(defvar mh-help-default nil + "Mode to use if messages are not present for the current mode.") -;;; MH-E macros - -(defmacro with-mh-folder-updating (save-modification-flag &rest body) - "Format is (with-mh-folder-updating (SAVE-MODIFICATION-FLAG) &body BODY). -Execute BODY, which can modify the folder buffer without having to -worry about file locking or the read-only flag, and return its result. -If SAVE-MODIFICATION-FLAG is non-nil, the buffer's modification flag -is unchanged, otherwise it is cleared." - (setq save-modification-flag (car save-modification-flag)) ; CL style - `(prog1 - (let ((mh-folder-updating-mod-flag (buffer-modified-p)) - (buffer-read-only nil) - (buffer-file-name nil)) ;don't let the buffer get locked - (prog1 - (progn - ,@body) - (mh-set-folder-modified-p mh-folder-updating-mod-flag))) - ,@(if (not save-modification-flag) - '((mh-set-folder-modified-p nil))))) - -(put 'with-mh-folder-updating 'lisp-indent-hook 'defun) - -(defmacro mh-in-show-buffer (show-buffer &rest body) - "Format is (mh-in-show-buffer (SHOW-BUFFER) &body BODY). -Display buffer SHOW-BUFFER in other window and execute BODY in it. -Stronger than `save-excursion', weaker than `save-window-excursion'." - (setq show-buffer (car show-buffer)) ; CL style - `(let ((mh-in-show-buffer-saved-window (selected-window))) - (switch-to-buffer-other-window ,show-buffer) - (if mh-bury-show-buffer-flag (bury-buffer (current-buffer))) - (unwind-protect - (progn - ,@body) - (select-window mh-in-show-buffer-saved-window)))) - -(put 'mh-in-show-buffer 'lisp-indent-hook 'defun) - -(defmacro mh-do-at-event-location (event &rest body) - "Switch to the location of EVENT and execute BODY. -After BODY has been executed return to original window. The -modification flag of the buffer in the event window is -preserved." - (let ((event-window (make-symbol "event-window")) - (event-position (make-symbol "event-position")) - (original-window (make-symbol "original-window")) - (original-position (make-symbol "original-position")) - (modified-flag (make-symbol "modified-flag"))) - `(save-excursion - (let* ((,event-window - (or (mh-funcall-if-exists posn-window (event-start ,event)) - (mh-funcall-if-exists event-window ,event))) - (,event-position - (or (mh-funcall-if-exists posn-point (event-start ,event)) - (mh-funcall-if-exists event-closest-point ,event))) - (,original-window (selected-window)) - (,original-position (progn - (set-buffer (window-buffer ,event-window)) - (set-marker (make-marker) (point)))) - (,modified-flag (buffer-modified-p)) - (buffer-read-only nil)) - (unwind-protect (progn - (select-window ,event-window) - (goto-char ,event-position) - ,@body) - (set-buffer-modified-p ,modified-flag) - (goto-char ,original-position) - (set-marker ,original-position nil) - (select-window ,original-window)))))) - -(put 'mh-do-at-event-location 'lisp-indent-hook 'defun) - -(defmacro mh-make-seq (name msgs) - "Create sequence NAME with the given MSGS." - (list 'cons name msgs)) - -(defmacro mh-seq-name (sequence) - "Extract sequence name from the given SEQUENCE." - (list 'car sequence)) - -(defmacro mh-seq-msgs (sequence) - "Extract messages from the given SEQUENCE." - (list 'cdr sequence)) - -(defun mh-recenter (arg) - "Like recenter but with three improvements: - -- At the end of the buffer it tries to show fewer empty lines. - -- operates only if the current buffer is in the selected window. - (Commands like `save-some-buffers' can make this false.) - -- nil ARG means recenter as if prefix argument had been given." - (cond ((not (eq (get-buffer-window (current-buffer)) (selected-window))) - nil) - ((= (point-max) (save-excursion - (forward-line (- (/ (window-height) 2) 2)) - (point))) - (let ((lines-from-end 2)) - (save-excursion - (while (> (point-max) (progn (forward-line) (point))) - (incf lines-from-end))) - (recenter (- lines-from-end)))) - ;; '(4) is the same as C-u prefix argument. - (t (recenter (or arg '(4)))))) - -(defun mh-start-of-uncleaned-message () - "Position uninteresting headers off the top of the window." - (let ((case-fold-search t)) - (re-search-forward - "^To:\\|^Cc:\\|^From:\\|^Subject:\\|^Date:" nil t) - (beginning-of-line) - (mh-recenter 0))) - -(defun mh-invalidate-show-buffer () - "Invalidate the show buffer so we must update it to use it." - (if (get-buffer mh-show-buffer) - (save-excursion - (set-buffer mh-show-buffer) - (mh-unvisit-file)))) - -(defun mh-unvisit-file () - "Separate current buffer from the message file it was visiting." - (or (not (buffer-modified-p)) - (null buffer-file-name) ;we've been here before - (yes-or-no-p (format "Message %s modified; flush changes? " - (file-name-nondirectory buffer-file-name))) - (error "Flushing changes not confirmed")) - (clear-visited-file-modtime) - (unlock-buffer) - (setq buffer-file-name nil)) +(defvar mh-help-messages nil + "Help messages for all modes. +This is an alist of alists. The primary key is a symbol +representing the mode; the value is described in `mh-set-help'.") + +;;;###mh-autoload +(defun mh-set-help (messages &optional default) + "Set help messages. + +The MESSAGES are assumed to be an associative array. It is used +to show help for the most common commands in the current mode. +The key is a prefix char. The value is one or more strings which +are concatenated together and displayed in a help buffer if ? is +pressed after the prefix character. The special key nil is used +to display the non-prefixed commands. + +The substitutions described in `substitute-command-keys' are performed as +well. + +If optional argument DEFAULT is non-nil, then these messages will +be used if help is asked for an unknown mode." + (add-to-list 'mh-help-messages (cons major-mode messages)) + (if default + (setq mh-help-default major-mode))) + +;;;###mh-autoload +(defun mh-help (&optional help-messages) + "Display cheat sheet for the MH-E commands. +See `mh-set-help' for setting the help messages. +HELP-MESSAGES are used instead if given. +This is a list of one or more strings which are concatenated together +and displayed in a help buffer." + (interactive) + (let* ((help (or help-messages + (cdr (assoc nil (assoc major-mode mh-help-messages))))) + (text (substitute-command-keys (mapconcat 'identity help "")))) + (with-electric-help + (function + (lambda () + (insert text))) + mh-help-buffer))) + +;;;###mh-autoload +(defun mh-prefix-help () + "Display cheat sheet for the commands of the current prefix in minibuffer." + (interactive) + ;; We got here because the user pressed a "?", but he pressed a prefix key + ;; before that. Since the the key vector starts at index 0, the index of the + ;; last keystroke is length-1 and thus the second to last keystroke is at + ;; length-2. We use that information to obtain a suitable prefix character + ;; from the recent keys. + (let* ((keys (recent-keys)) + (prefix-char (elt keys (- (length keys) 2))) + (help (cdr (assoc prefix-char (assoc major-mode mh-help-messages))))) + (mh-help help))) + + +;;; Message Number Utilities + +;;;###mh-autoload +(defun mh-coalesce-msg-list (messages) + "Given a list of MESSAGES, return a list of message number ranges. +This is the inverse of `mh-read-msg-list', which expands ranges. +Message lists passed to MH programs should be processed by this +function to avoid exceeding system command line argument limits." + (let ((msgs (sort (copy-sequence messages) 'mh-greaterp)) + (range-high nil) + (prev -1) + (ranges nil)) + (while prev + (if range-high + (if (or (not (numberp prev)) + (not (equal (car msgs) (1- prev)))) + (progn ;non-sequential, flush old range + (if (eq prev range-high) + (setq ranges (cons range-high ranges)) + (setq ranges (cons (format "%s-%s" prev range-high) ranges))) + (setq range-high nil)))) + (or range-high + (setq range-high (car msgs))) ;start new or first range + (setq prev (car msgs)) + (setq msgs (cdr msgs))) + ranges)) + +(defun mh-greaterp (msg1 msg2) + "Return the greater of two message indicators MSG1 and MSG2. +Strings are \"smaller\" than numbers. +Valid values are things like \"cur\", \"last\", 1, and 1820." + (if (numberp msg1) + (if (numberp msg2) + (> msg1 msg2) + t) + (if (numberp msg2) + nil + (string-lessp msg2 msg1)))) + +;;;###mh-autoload +(defun mh-lessp (msg1 msg2) + "Return the lesser of two message indicators MSG1 and MSG2. +Strings are \"smaller\" than numbers. +Valid values are things like \"cur\", \"last\", 1, and 1820." + (not (mh-greaterp msg1 msg2))) + +;;;###mh-autoload (defun mh-get-msg-num (error-if-no-message) "Return the message number of the displayed message. If the argument ERROR-IF-NO-MESSAGE is non-nil, then complain if the cursor is not pointing to a message." (save-excursion (beginning-of-line) - (cond ((looking-at mh-scan-msg-number-regexp) + (cond ((looking-at (mh-scan-msg-number-regexp)) (string-to-number (buffer-substring (match-beginning 1) (match-end 1)))) (error-if-no-message (error "Cursor not pointing to message")) (t nil)))) -(defun mh-folder-name-p (name) - "Return non-nil if NAME is the name of a folder. -A name (a string or symbol) can be a folder name if it begins -with \"+\"." - (if (symbolp name) - (eq (aref (symbol-name name) 0) ?+) - (and (> (length name) 0) - (eq (aref name 0) ?+)))) - -(defun mh-expand-file-name (filename &optional default) - "Expand FILENAME like `expand-file-name', but also handle MH folder names. -Any filename that starts with '+' is treated as a folder name. -See `expand-file-name' for description of DEFAULT." - (if (mh-folder-name-p filename) - (expand-file-name (substring filename 1) mh-user-path) - (expand-file-name filename default))) - -(defun mh-msg-filename (msg &optional folder) - "Return the file name of MSG in FOLDER (default current folder)." - (expand-file-name (int-to-string msg) - (if folder - (mh-expand-file-name folder) - mh-folder-filename))) - -;; Infrastructure to generate show-buffer functions from folder functions -;; XEmacs does not have deactivate-mark? What is the equivalent of -;; transient-mark-mode for XEmacs? Should we be restoring the mark in the -;; folder buffer after the operation has been carried out. -(defmacro mh-defun-show-buffer (function original-function - &optional dont-return) - "Define FUNCTION to run ORIGINAL-FUNCTION in folder buffer. -If the buffer we start in is still visible and DONT-RETURN is nil -then switch to it after that." - `(defun ,function () - ,(format "Calls %s from the message's folder.\n%s\nSee \"%s\" for more info.\n" - original-function - (if dont-return "" - "When function completes, returns to the show buffer if it is -still visible.\n") - original-function) - (interactive) - (when (buffer-live-p (get-buffer mh-show-folder-buffer)) - (let ((config (current-window-configuration)) - (folder-buffer mh-show-folder-buffer) - (normal-exit nil) - ,@(if dont-return () '((cur-buffer-name (buffer-name))))) - (pop-to-buffer mh-show-folder-buffer nil) - (unless (equal (buffer-name - (window-buffer (frame-first-window (selected-frame)))) - folder-buffer) - (delete-other-windows)) - (mh-goto-cur-msg t) - (mh-funcall-if-exists deactivate-mark) - (unwind-protect - (prog1 (call-interactively (function ,original-function)) - (setq normal-exit t)) - (mh-funcall-if-exists deactivate-mark) - (when (eq major-mode 'mh-folder-mode) - (mh-funcall-if-exists hl-line-highlight)) - (cond ((not normal-exit) - (set-window-configuration config)) - ,(if dont-return - `(t (setq mh-previous-window-config config)) - `((and (get-buffer cur-buffer-name) - (window-live-p (get-buffer-window - (get-buffer cur-buffer-name)))) - (pop-to-buffer (get-buffer cur-buffer-name) nil))))))))) - -;; Generate interactive functions for the show buffer from the corresponding -;; folder functions. -(mh-defun-show-buffer mh-show-previous-undeleted-msg - mh-previous-undeleted-msg) -(mh-defun-show-buffer mh-show-next-undeleted-msg - mh-next-undeleted-msg) -(mh-defun-show-buffer mh-show-quit mh-quit) -(mh-defun-show-buffer mh-show-delete-msg mh-delete-msg) -(mh-defun-show-buffer mh-show-refile-msg mh-refile-msg) -(mh-defun-show-buffer mh-show-undo mh-undo) -(mh-defun-show-buffer mh-show-execute-commands mh-execute-commands) -(mh-defun-show-buffer mh-show-reply mh-reply t) -(mh-defun-show-buffer mh-show-redistribute mh-redistribute) -(mh-defun-show-buffer mh-show-forward mh-forward t) -(mh-defun-show-buffer mh-show-header-display mh-header-display) -(mh-defun-show-buffer mh-show-refile-or-write-again - mh-refile-or-write-again) -(mh-defun-show-buffer mh-show-show mh-show) -(mh-defun-show-buffer mh-show-write-message-to-file - mh-write-msg-to-file) -(mh-defun-show-buffer mh-show-extract-rejected-mail - mh-extract-rejected-mail t) -(mh-defun-show-buffer mh-show-delete-msg-no-motion - mh-delete-msg-no-motion) -(mh-defun-show-buffer mh-show-first-msg mh-first-msg) -(mh-defun-show-buffer mh-show-last-msg mh-last-msg) -(mh-defun-show-buffer mh-show-copy-msg mh-copy-msg) -(mh-defun-show-buffer mh-show-edit-again mh-edit-again t) -(mh-defun-show-buffer mh-show-goto-msg mh-goto-msg) -(mh-defun-show-buffer mh-show-inc-folder mh-inc-folder) -(mh-defun-show-buffer mh-show-delete-subject-or-thread - mh-delete-subject-or-thread) -(mh-defun-show-buffer mh-show-delete-subject mh-delete-subject) -(mh-defun-show-buffer mh-show-print-msg mh-print-msg) -(mh-defun-show-buffer mh-show-send mh-send t) -(mh-defun-show-buffer mh-show-toggle-showing mh-toggle-showing t) -(mh-defun-show-buffer mh-show-pipe-msg mh-pipe-msg t) -(mh-defun-show-buffer mh-show-sort-folder mh-sort-folder) -(mh-defun-show-buffer mh-show-visit-folder mh-visit-folder t) -(mh-defun-show-buffer mh-show-rescan-folder mh-rescan-folder) -(mh-defun-show-buffer mh-show-pack-folder mh-pack-folder) -(mh-defun-show-buffer mh-show-kill-folder mh-kill-folder t) -(mh-defun-show-buffer mh-show-list-folders mh-list-folders t) -(mh-defun-show-buffer mh-show-undo-folder mh-undo-folder) -(mh-defun-show-buffer mh-show-delete-msg-from-seq - mh-delete-msg-from-seq) -(mh-defun-show-buffer mh-show-delete-seq mh-delete-seq) -(mh-defun-show-buffer mh-show-list-sequences mh-list-sequences) -(mh-defun-show-buffer mh-show-narrow-to-seq mh-narrow-to-seq) -(mh-defun-show-buffer mh-show-put-msg-in-seq mh-put-msg-in-seq) -(mh-defun-show-buffer mh-show-msg-is-in-seq mh-msg-is-in-seq) -(mh-defun-show-buffer mh-show-widen mh-widen) -(mh-defun-show-buffer mh-show-narrow-to-subject mh-narrow-to-subject) -(mh-defun-show-buffer mh-show-narrow-to-from mh-narrow-to-from) -(mh-defun-show-buffer mh-show-narrow-to-cc mh-narrow-to-cc) -(mh-defun-show-buffer mh-show-narrow-to-range mh-narrow-to-range) -(mh-defun-show-buffer mh-show-narrow-to-to mh-narrow-to-to) -(mh-defun-show-buffer mh-show-store-msg mh-store-msg) -(mh-defun-show-buffer mh-show-page-digest mh-page-digest) -(mh-defun-show-buffer mh-show-page-digest-backwards - mh-page-digest-backwards) -(mh-defun-show-buffer mh-show-burst-digest mh-burst-digest) -(mh-defun-show-buffer mh-show-page-msg mh-page-msg) -(mh-defun-show-buffer mh-show-previous-page mh-previous-page) -(mh-defun-show-buffer mh-show-modify mh-modify t) -(mh-defun-show-buffer mh-show-next-button mh-next-button) -(mh-defun-show-buffer mh-show-prev-button mh-prev-button) -(mh-defun-show-buffer mh-show-toggle-mime-part mh-folder-toggle-mime-part) -(mh-defun-show-buffer mh-show-save-mime-part mh-folder-save-mime-part) -(mh-defun-show-buffer mh-show-inline-mime-part mh-folder-inline-mime-part) -(mh-defun-show-buffer mh-show-toggle-threads mh-toggle-threads) -(mh-defun-show-buffer mh-show-thread-delete mh-thread-delete) -(mh-defun-show-buffer mh-show-thread-refile mh-thread-refile) -(mh-defun-show-buffer mh-show-update-sequences mh-update-sequences) -(mh-defun-show-buffer mh-show-next-unread-msg mh-next-unread-msg) -(mh-defun-show-buffer mh-show-previous-unread-msg mh-previous-unread-msg) -(mh-defun-show-buffer mh-show-thread-ancestor mh-thread-ancestor) -(mh-defun-show-buffer mh-show-thread-next-sibling mh-thread-next-sibling) -(mh-defun-show-buffer mh-show-thread-previous-sibling - mh-thread-previous-sibling) -(mh-defun-show-buffer mh-show-index-visit-folder mh-index-visit-folder t) -(mh-defun-show-buffer mh-show-toggle-tick mh-toggle-tick) -(mh-defun-show-buffer mh-show-narrow-to-tick mh-narrow-to-tick) -(mh-defun-show-buffer mh-show-junk-blacklist mh-junk-blacklist) -(mh-defun-show-buffer mh-show-junk-whitelist mh-junk-whitelist) -(mh-defun-show-buffer mh-show-index-new-messages mh-index-new-messages) -(mh-defun-show-buffer mh-show-index-ticked-messages mh-index-ticked-messages) -(mh-defun-show-buffer mh-show-index-sequenced-messages - mh-index-sequenced-messages) -(mh-defun-show-buffer mh-show-catchup mh-catchup) -(mh-defun-show-buffer mh-show-ps-print-toggle-color mh-ps-print-toggle-color) -(mh-defun-show-buffer mh-show-ps-print-toggle-faces mh-ps-print-toggle-faces) -(mh-defun-show-buffer mh-show-ps-print-msg-file mh-ps-print-msg-file) -(mh-defun-show-buffer mh-show-ps-print-msg mh-ps-print-msg) -(mh-defun-show-buffer mh-show-toggle-mime-buttons mh-toggle-mime-buttons) -(mh-defun-show-buffer mh-show-display-with-external-viewer - mh-display-with-external-viewer) - - - -;;; Build mh-show-mode keymaps - -(gnus-define-keys mh-show-mode-map - " " mh-show-page-msg - "!" mh-show-refile-or-write-again - "'" mh-show-toggle-tick - "," mh-show-header-display - "." mh-show-show - ">" mh-show-write-message-to-file - "?" mh-help - "E" mh-show-extract-rejected-mail - "M" mh-show-modify - "\177" mh-show-previous-page - "\C-d" mh-show-delete-msg-no-motion - "\t" mh-show-next-button - [backtab] mh-show-prev-button - "\M-\t" mh-show-prev-button - "\ed" mh-show-redistribute - "^" mh-show-refile-msg - "c" mh-show-copy-msg - "d" mh-show-delete-msg - "e" mh-show-edit-again - "f" mh-show-forward - "g" mh-show-goto-msg - "i" mh-show-inc-folder - "k" mh-show-delete-subject-or-thread - "m" mh-show-send - "n" mh-show-next-undeleted-msg - "\M-n" mh-show-next-unread-msg - "o" mh-show-refile-msg - "p" mh-show-previous-undeleted-msg - "\M-p" mh-show-previous-unread-msg - "q" mh-show-quit - "r" mh-show-reply - "s" mh-show-send - "t" mh-show-toggle-showing - "u" mh-show-undo - "x" mh-show-execute-commands - "v" mh-show-index-visit-folder - "|" mh-show-pipe-msg) - -(gnus-define-keys (mh-show-folder-map "F" mh-show-mode-map) - "?" mh-prefix-help - "'" mh-index-ticked-messages - "S" mh-show-sort-folder - "c" mh-show-catchup - "f" mh-show-visit-folder - "k" mh-show-kill-folder - "l" mh-show-list-folders - "n" mh-index-new-messages - "o" mh-show-visit-folder - "q" mh-show-index-sequenced-messages - "r" mh-show-rescan-folder - "s" mh-search - "t" mh-show-toggle-threads - "u" mh-show-undo-folder - "v" mh-show-visit-folder) - -(gnus-define-keys (mh-show-sequence-map "S" mh-show-mode-map) - "'" mh-show-narrow-to-tick - "?" mh-prefix-help - "d" mh-show-delete-msg-from-seq - "k" mh-show-delete-seq - "l" mh-show-list-sequences - "n" mh-show-narrow-to-seq - "p" mh-show-put-msg-in-seq - "s" mh-show-msg-is-in-seq - "w" mh-show-widen) - -(define-key mh-show-mode-map "I" mh-inc-spool-map) - -(gnus-define-keys (mh-show-junk-map "J" mh-show-mode-map) - "?" mh-prefix-help - "b" mh-show-junk-blacklist - "w" mh-show-junk-whitelist) - -(gnus-define-keys (mh-show-ps-print-map "P" mh-show-mode-map) - "?" mh-prefix-help - "C" mh-show-ps-print-toggle-color - "F" mh-show-ps-print-toggle-faces - "f" mh-show-ps-print-msg-file - "l" mh-show-print-msg - "p" mh-show-ps-print-msg) - -(gnus-define-keys (mh-show-thread-map "T" mh-show-mode-map) - "?" mh-prefix-help - "u" mh-show-thread-ancestor - "p" mh-show-thread-previous-sibling - "n" mh-show-thread-next-sibling - "t" mh-show-toggle-threads - "d" mh-show-thread-delete - "o" mh-show-thread-refile) - -(gnus-define-keys (mh-show-limit-map "/" mh-show-mode-map) - "'" mh-show-narrow-to-tick - "?" mh-prefix-help - "c" mh-show-narrow-to-cc - "g" mh-show-narrow-to-range - "m" mh-show-narrow-to-from - "s" mh-show-narrow-to-subject - "t" mh-show-narrow-to-to - "w" mh-show-widen) - -(gnus-define-keys (mh-show-extract-map "X" mh-show-mode-map) - "?" mh-prefix-help - "s" mh-show-store-msg - "u" mh-show-store-msg) - -;; Untested... -(gnus-define-keys (mh-show-digest-map "D" mh-show-mode-map) - "?" mh-prefix-help - " " mh-show-page-digest - "\177" mh-show-page-digest-backwards - "b" mh-show-burst-digest) - -(gnus-define-keys (mh-show-mime-map "K" mh-show-mode-map) - "?" mh-prefix-help - "a" mh-mime-save-parts - "e" mh-show-display-with-external-viewer - "v" mh-show-toggle-mime-part - "o" mh-show-save-mime-part - "i" mh-show-inline-mime-part - "t" mh-show-toggle-mime-buttons - "\t" mh-show-next-button - [backtab] mh-show-prev-button - "\M-\t" mh-show-prev-button) - -(easy-menu-define - mh-show-sequence-menu mh-show-mode-map "Menu for MH-E folder-sequence." - '("Sequence" - ["Add Message to Sequence..." mh-show-put-msg-in-seq t] - ["List Sequences for Message" mh-show-msg-is-in-seq t] - ["Delete Message from Sequence..." mh-show-delete-msg-from-seq t] - ["List Sequences in Folder..." mh-show-list-sequences t] - ["Delete Sequence..." mh-show-delete-seq t] - ["Narrow to Sequence..." mh-show-narrow-to-seq t] - ["Widen from Sequence" mh-show-widen t] - "--" - ["Narrow to Subject Sequence" mh-show-narrow-to-subject t] - ["Narrow to Tick Sequence" mh-show-narrow-to-tick - (save-excursion - (set-buffer mh-show-folder-buffer) - (and mh-tick-seq (mh-seq-msgs (mh-find-seq mh-tick-seq))))] - ["Delete Rest of Same Subject" mh-show-delete-subject t] - ["Toggle Tick Mark" mh-show-toggle-tick t] - "--" - ["Push State Out to MH" mh-show-update-sequences t])) - -(easy-menu-define - mh-show-message-menu mh-show-mode-map "Menu for MH-E folder-message." - '("Message" - ["Show Message" mh-show-show t] - ["Show Message with Header" mh-show-header-display t] - ["Next Message" mh-show-next-undeleted-msg t] - ["Previous Message" mh-show-previous-undeleted-msg t] - ["Go to First Message" mh-show-first-msg t] - ["Go to Last Message" mh-show-last-msg t] - ["Go to Message by Number..." mh-show-goto-msg t] - ["Modify Message" mh-show-modify t] - ["Delete Message" mh-show-delete-msg t] - ["Refile Message" mh-show-refile-msg t] - ["Undo Delete/Refile" mh-show-undo t] - ["Process Delete/Refile" mh-show-execute-commands t] - "--" - ["Compose a New Message" mh-send t] - ["Reply to Message..." mh-show-reply t] - ["Forward Message..." mh-show-forward t] - ["Redistribute Message..." mh-show-redistribute t] - ["Edit Message Again" mh-show-edit-again t] - ["Re-edit a Bounced Message" mh-show-extract-rejected-mail t] - "--" - ["Copy Message to Folder..." mh-show-copy-msg t] - ["Print Message" mh-show-print-msg t] - ["Write Message to File..." mh-show-write-msg-to-file t] - ["Pipe Message to Command..." mh-show-pipe-msg t] - ["Unpack Uuencoded Message..." mh-show-store-msg t] - ["Burst Digest Message" mh-show-burst-digest t])) - -(easy-menu-define - mh-show-folder-menu mh-show-mode-map "Menu for MH-E folder." - '("Folder" - ["Incorporate New Mail" mh-show-inc-folder t] - ["Toggle Show/Folder" mh-show-toggle-showing t] - ["Execute Delete/Refile" mh-show-execute-commands t] - ["Rescan Folder" mh-show-rescan-folder t] - ["Thread Folder" mh-show-toggle-threads t] - ["Pack Folder" mh-show-pack-folder t] - ["Sort Folder" mh-show-sort-folder t] - "--" - ["List Folders" mh-show-list-folders t] - ["Visit a Folder..." mh-show-visit-folder t] - ["View New Messages" mh-show-index-new-messages t] - ["Search..." mh-search t] - "--" - ["Quit MH-E" mh-quit t])) - -;; Ensure new buffers won't get this mode if default-major-mode is nil. -(put 'mh-show-mode 'mode-class 'special) - -;; Shush compiler. -(eval-when-compile (defvar font-lock-auto-fontify)) - -(define-derived-mode mh-show-mode text-mode "MH-Show" - "Major mode for showing messages in MH-E.\\<mh-show-mode-map> - -The hook `mh-show-mode-hook' is called upon entry to this mode. - -See also `mh-folder-mode'. - -\\{mh-show-mode-map}" - (set (make-local-variable 'mail-header-separator) mh-mail-header-separator) - (setq paragraph-start (default-value 'paragraph-start)) - (mh-show-unquote-From) - (mh-show-xface) - (mh-show-addr) - (setq buffer-invisibility-spec '((vanish . t) t)) - (set (make-local-variable 'line-move-ignore-invisible) t) - (make-local-variable 'font-lock-defaults) - ;;(set (make-local-variable 'font-lock-support-mode) nil) - (cond - ((equal mh-highlight-citation-style 'font-lock) - (setq font-lock-defaults '(mh-show-font-lock-keywords-with-cite t))) - ((equal mh-highlight-citation-style 'gnus) - (setq font-lock-defaults '((mh-show-font-lock-keywords) - t nil nil nil - (font-lock-fontify-region-function - . mh-show-font-lock-fontify-region))) - (mh-gnus-article-highlight-citation)) - (t - (setq font-lock-defaults '(mh-show-font-lock-keywords t)))) - (if (and mh-xemacs-flag - font-lock-auto-fontify) - (turn-on-font-lock)) - (set (make-local-variable 'tool-bar-map) mh-show-tool-bar-map) - (mh-funcall-if-exists mh-tool-bar-init :show) - (when mh-decode-mime-flag - (mh-make-local-hook 'kill-buffer-hook) - (add-hook 'kill-buffer-hook 'mh-mime-cleanup nil t)) - (easy-menu-add mh-show-sequence-menu) - (easy-menu-add mh-show-message-menu) - (easy-menu-add mh-show-folder-menu) - (make-local-variable 'mh-show-folder-buffer) - (buffer-disable-undo) - (setq buffer-read-only t) - (use-local-map mh-show-mode-map)) - -(defun mh-show-addr () - "Use `goto-address'." - (when mh-show-use-goto-addr-flag - (if (not (featurep 'goto-addr)) - (load "goto-addr" t t)) - (if (fboundp 'goto-address) - (goto-address)))) - - - -;; X-Face and Face display -(defvar mh-show-xface-function - (cond ((and mh-xemacs-flag (locate-library "x-face") (not (featurep 'xface))) - (load "x-face" t t) - #'mh-face-display-function) - ((>= emacs-major-version 21) - #'mh-face-display-function) - (t #'ignore)) - "Determine at run time what function should be called to display X-Face.") - -(defvar mh-uncompface-executable - (and (fboundp 'executable-find) (executable-find "uncompface"))) - -(defun mh-face-to-png (data) - "Convert base64 encoded DATA to png image." - (with-temp-buffer - (insert data) - (ignore-errors (base64-decode-region (point-min) (point-max))) - (buffer-string))) - -(defun mh-uncompface (data) - "Run DATA through `uncompface' to generate bitmap." - (with-temp-buffer - (insert data) - (when (and mh-uncompface-executable - (equal (call-process-region (point-min) (point-max) - mh-uncompface-executable t '(t nil)) - 0)) - (mh-icontopbm) - (buffer-string)))) - -(defun mh-icontopbm () - "Elisp substitute for `icontopbm'." - (goto-char (point-min)) - (let ((end (point-max))) - (while (re-search-forward "0x\\(..\\)\\(..\\)," nil t) - (save-excursion - (goto-char (point-max)) - (insert (string-to-number (match-string 1) 16)) - (insert (string-to-number (match-string 2) 16)))) - (delete-region (point-min) end) - (goto-char (point-min)) - (insert "P4\n48 48\n"))) - -(mh-do-in-xemacs (defvar default-enable-multibyte-characters)) - -(defmacro mh-face-foreground-compat (face &optional frame inherit) - "Return the foreground color name of FACE, or nil if unspecified. -See documentation for `face-foreground' for a description of the -arguments FACE, FRAME, and INHERIT. - -Calls `face-foreground' correctly in older environments. Versions -of Emacs prior to version 22 lacked an INHERIT argument which -when t tells `face-foreground' to consider an inherited value for -the foreground if the face does not define one itself." - (if (>= emacs-major-version 22) - `(face-foreground ,face ,frame ,inherit) - `(face-foreground ,face ,frame))) - -(defmacro mh-face-background-compat (face &optional frame inherit) - "Return the background color name of face, or nil if unspecified. -See documentation for `back-foreground' for a description of the -arguments FACE, FRAME, and INHERIT. - -Calls `face-background' correctly in older environments. Versions -of Emacs prior to version 22 lacked an INHERIT argument which -when t tells `face-background' to consider an inherited value for -the background if the face does not define one itself." - (if (>= emacs-major-version 22) - `(face-background ,face ,frame ,inherit) - `(face-background ,face ,frame))) - -(defun mh-face-display-function () - "Display a Face, X-Face, or X-Image-URL header field. -If more than one of these are present, then the first one found -in this order is used." - (save-restriction - (goto-char (point-min)) - (re-search-forward "\n\n" (point-max) t) - (narrow-to-region (point-min) (point)) - (let* ((case-fold-search t) - (default-enable-multibyte-characters nil) - (face (message-fetch-field "face" t)) - (x-face (message-fetch-field "x-face" t)) - (url (message-fetch-field "x-image-url" t)) - raw type) - (cond (face (setq raw (mh-face-to-png face) - type 'png)) - (x-face (setq raw (mh-uncompface x-face) - type 'pbm)) - (url (setq type 'url)) - (t (multiple-value-setq (type raw) (mh-picon-get-image)))) - (when type - (goto-char (point-min)) - (when (re-search-forward "^from:" (point-max) t) - ;; GNU Emacs - (mh-do-in-gnu-emacs - (if (eq type 'url) - (mh-x-image-url-display url) - (mh-funcall-if-exists - insert-image (create-image - raw type t - :foreground - (mh-face-foreground-compat 'mh-show-xface nil t) - :background - (mh-face-background-compat 'mh-show-xface nil t)) - " "))) - ;; XEmacs - (mh-do-in-xemacs - (cond - ((eq type 'url) - (mh-x-image-url-display url)) - ((eq type 'png) - (when (featurep 'png) - (set-extent-begin-glyph - (make-extent (point) (point)) - (make-glyph (vector 'png ':data (mh-face-to-png face)))))) - ;; Try internal xface support if available... - ((and (eq type 'pbm) (featurep 'xface)) - (set-glyph-face - (set-extent-begin-glyph - (make-extent (point) (point)) - (make-glyph (vector 'xface ':data (concat "X-Face: " x-face)))) - 'mh-show-xface)) - ;; Otherwise try external support with x-face... - ((and (eq type 'pbm) - (fboundp 'x-face-xmas-wl-display-x-face) - (fboundp 'executable-find) (executable-find "uncompface")) - (mh-funcall-if-exists x-face-xmas-wl-display-x-face)) - ;; Picon display - ((and raw (member type '(xpm xbm gif))) - (when (featurep type) - (set-extent-begin-glyph - (make-extent (point) (point)) - (make-glyph (vector type ':data raw)))))) - (when raw (insert " ")))))))) - -(defun mh-show-xface () - "Display X-Face." - (when (and window-system mh-show-use-xface-flag - (or mh-decode-mime-flag mh-mhl-format-file - mh-clean-message-header-flag)) - (funcall mh-show-xface-function))) - - - -;;; Picon display - -;; XXX: This should be customizable. As a side-effect of setting this -;; variable, arrange to reset mh-picon-existing-directory-list to 'unset. -(defvar mh-picon-directory-list - '("~/.picons" "~/.picons/users" "~/.picons/usenix" "~/.picons/news" - "~/.picons/domains" "~/.picons/misc" - "/usr/share/picons/" "/usr/share/picons/users" "/usr/share/picons/usenix" - "/usr/share/picons/news" "/usr/share/picons/domains" - "/usr/share/picons/misc") - "List of directories where picons reside. -The directories are searched for in the order they appear in the list.") - -(defvar mh-picon-existing-directory-list 'unset - "List of directories to search in.") - -(defvar mh-picon-cache (make-hash-table :test #'equal)) - -(defvar mh-picon-image-types - (loop for type in '(xpm xbm gif) - when (or (mh-do-in-gnu-emacs - (ignore-errors - (mh-funcall-if-exists image-type-available-p type))) - (mh-do-in-xemacs (featurep type))) - collect type)) - -(defun mh-picon-set-directory-list () - "Update `mh-picon-existing-directory-list' if needed." - (when (eq mh-picon-existing-directory-list 'unset) - (setq mh-picon-existing-directory-list - (loop for x in mh-picon-directory-list - when (file-directory-p x) collect x)))) - -(defun* mh-picon-get-image () - "Find the best possible match and return contents." - (mh-picon-set-directory-list) - (save-restriction - (let* ((from-field (ignore-errors (car (message-tokenize-header - (mh-get-header-field "from:"))))) - (from (car (ignore-errors - (mh-funcall-if-exists ietf-drums-parse-address - from-field)))) - (host (and from - (string-match "\\([^+]*\\)\\(+.*\\)?@\\(.*\\)" from) - (downcase (match-string 3 from)))) - (user (and host (downcase (match-string 1 from)))) - (canonical-address (format "%s@%s" user host)) - (cached-value (gethash canonical-address mh-picon-cache)) - (host-list (and host (delete "" (split-string host "\\.")))) - (match nil)) - (cond (cached-value (return-from mh-picon-get-image cached-value)) - ((not host-list) (return-from mh-picon-get-image nil))) - (setq match - (block 'loop - ;; u@h search - (loop for dir in mh-picon-existing-directory-list - do (loop for type in mh-picon-image-types - ;; [path]user@host - for file1 = (format "%s/%s.%s" - dir canonical-address type) - when (file-exists-p file1) - do (return-from 'loop file1) - ;; [path]user - for file2 = (format "%s/%s.%s" dir user type) - when (file-exists-p file2) - do (return-from 'loop file2) - ;; [path]host - for file3 = (format "%s/%s.%s" dir host type) - when (file-exists-p file3) - do (return-from 'loop file3))) - ;; facedb search - ;; Search order for user@foo.net: - ;; [path]net/foo/user - ;; [path]net/foo/user/face - ;; [path]net/user - ;; [path]net/user/face - ;; [path]net/foo/unknown - ;; [path]net/foo/unknown/face - ;; [path]net/unknown - ;; [path]net/unknown/face - (loop for u in (list user "unknown") - do (loop for dir in mh-picon-existing-directory-list - do (loop for x on host-list by #'cdr - for y = (mh-picon-generate-path x u dir) - do (loop for type in mh-picon-image-types - for z1 = (format "%s.%s" y type) - when (file-exists-p z1) - do (return-from 'loop z1) - for z2 = (format "%s/face.%s" - y type) - when (file-exists-p z2) - do (return-from 'loop z2))))))) - (setf (gethash canonical-address mh-picon-cache) - (mh-picon-file-contents match))))) - -(defun mh-picon-file-contents (file) - "Return details about FILE. -A list of consisting of a symbol for the type of the file and the -file contents as a string is returned. If FILE is nil, then both -elements of the list are nil." - (if (stringp file) - (with-temp-buffer - (let ((type (and (string-match ".*\\.\\(...\\)$" file) - (intern (match-string 1 file))))) - (insert-file-contents-literally file) - (values type (buffer-string)))) - (values nil nil))) - -(defun mh-picon-generate-path (host-list user directory) - "Generate the image file path. -HOST-LIST is the parsed host address of the email address, USER -the username and DIRECTORY is the directory relative to which the -path is generated." - (loop with acc = "" - for elem in host-list - do (setq acc (format "%s/%s" elem acc)) - finally return (format "%s/%s%s" directory acc user))) - - - -;; X-Image-URL display - -(defvar mh-x-image-cache-directory nil - "Directory where X-Image-URL images are cached.") -(defvar mh-x-image-scaling-function - (cond ((executable-find "convert") - 'mh-x-image-scale-with-convert) - ((and (executable-find "anytopnm") (executable-find "pnmscale") - (executable-find "pnmtopng")) - 'mh-x-image-scale-with-pnm) - (t 'ignore)) - "Function to use to scale image to proper size.") -(defvar mh-wget-executable nil) -(defvar mh-wget-choice - (or (and (setq mh-wget-executable (executable-find "wget")) 'wget) - (and (setq mh-wget-executable (executable-find "fetch")) 'fetch) - (and (setq mh-wget-executable (executable-find "curl")) 'curl))) -(defvar mh-wget-option - (cdr (assoc mh-wget-choice '((curl . "-o") (fetch . "-o") (wget . "-O"))))) -(defvar mh-x-image-temp-file nil) -(defvar mh-x-image-url nil) -(defvar mh-x-image-marker nil) -(defvar mh-x-image-url-cache-file nil) - -;; Functions to scale image to proper size -(defun mh-x-image-scale-with-pnm (input output) - "Scale image in INPUT file and write to OUTPUT file using pnm tools." - (let ((res (shell-command-to-string - (format "anytopnm < %s | pnmscale -xysize 96 48 | pnmtopng > %s" - input output)))) - (unless (equal res "") - (delete-file output)))) - -(defun mh-x-image-scale-with-convert (input output) - "Scale image in INPUT file and write to OUTPUT file using ImageMagick." - (call-process "convert" nil nil nil "-geometry" "96x48" input output)) - -;; Copy of constant from url-util.el in Emacs 22; needed by Emacs 21. -(if (not (boundp 'url-unreserved-chars)) - (defconst url-unreserved-chars - '( - ?a ?b ?c ?d ?e ?f ?g ?h ?i ?j ?k ?l ?m ?n ?o ?p ?q ?r ?s ?t ?u ?v ?w ?x ?y ?z - ?A ?B ?C ?D ?E ?F ?G ?H ?I ?J ?K ?L ?M ?N ?O ?P ?Q ?R ?S ?T ?U ?V ?W ?X ?Y ?Z - ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9 - ?- ?_ ?. ?! ?~ ?* ?' ?\( ?\)) - "A list of characters that are _NOT_ reserved in the URL spec. -This is taken from RFC 2396.")) - -;; Copy of function from url-util.el in Emacs 22; needed by Emacs 21. -(mh-defun-compat url-hexify-string (str) - "Escape characters in a string." - (mapconcat - (lambda (char) - ;; Fixme: use a char table instead. - (if (not (memq char url-unreserved-chars)) - (if (> char 255) - (error "Hexifying multibyte character %s" str) - (format "%%%02X" char)) - (char-to-string char))) - str "")) - -(defun mh-x-image-url-cache-canonicalize (url) - "Canonicalize URL. -Replace the ?/ character with a ?! character and append .png. -Also replaces special characters with `url-hexify-string' since -not all characters, such as :, are legal within Windows -filenames. See URL `http://msdn.microsoft.com/library/default.asp?url=/library/en-us/fileio/fs/naming_a_file.asp'." - (format "%s/%s.png" mh-x-image-cache-directory - (url-hexify-string - (with-temp-buffer - (insert url) - (mh-replace-string "/" "!") - (buffer-string))))) - -(defun mh-x-image-set-download-state (file data) - "Setup a symbolic link from FILE to DATA." - (if data - (make-symbolic-link (symbol-name data) file t) - (delete-file file))) - -(defun mh-x-image-get-download-state (file) - "Check the state of FILE by following any symbolic links." - (unless (file-exists-p mh-x-image-cache-directory) - (call-process "mkdir" nil nil nil mh-x-image-cache-directory)) - (cond ((file-symlink-p file) - (intern (file-name-nondirectory (file-chase-links file)))) - ((not (file-exists-p file)) nil) - (t 'ok))) - -(defun mh-x-image-url-fetch-image (url cache-file marker sentinel) - "Fetch and display the image specified by URL. -After the image is fetched, it is stored in CACHE-FILE. It will -be displayed in a buffer and position specified by MARKER. The -actual display is carried out by the SENTINEL function." - (if mh-wget-executable - (let ((buffer (get-buffer-create (generate-new-buffer-name - mh-temp-fetch-buffer))) - (filename (or (mh-funcall-if-exists make-temp-file "mhe-fetch") - (expand-file-name (make-temp-name "~/mhe-fetch"))))) - (save-excursion - (set-buffer buffer) - (set (make-local-variable 'mh-x-image-url-cache-file) cache-file) - (set (make-local-variable 'mh-x-image-marker) marker) - (set (make-local-variable 'mh-x-image-temp-file) filename)) - (set-process-sentinel - (start-process "*mh-x-image-url-fetch*" buffer - mh-wget-executable mh-wget-option filename url) - sentinel)) - ;; Temporary failure - (mh-x-image-set-download-state cache-file 'try-again))) - -(defun mh-x-image-display (image marker) - "Display IMAGE at MARKER." - (save-excursion - (set-buffer (marker-buffer marker)) - (let ((buffer-read-only nil) - (default-enable-multibyte-characters nil) - (buffer-modified-flag (buffer-modified-p))) - (unwind-protect - (when (and (file-readable-p image) (not (file-symlink-p image)) - (eq marker mh-x-image-marker)) - (goto-char marker) - (mh-do-in-gnu-emacs - (mh-funcall-if-exists insert-image (create-image image 'png))) - (mh-do-in-xemacs - (when (featurep 'png) - (set-extent-begin-glyph - (make-extent (point) (point)) - (make-glyph - (vector 'png ':data (with-temp-buffer - (insert-file-contents-literally image) - (buffer-string)))))))) - (set-buffer-modified-p buffer-modified-flag))))) - -(defun mh-x-image-scale-and-display (process change) - "When the wget PROCESS terminates scale and display image. -The argument CHANGE is ignored." - (when (eq (process-status process) 'exit) - (let (marker temp-file cache-filename wget-buffer) - (save-excursion - (set-buffer (setq wget-buffer (process-buffer process))) - (setq marker mh-x-image-marker - cache-filename mh-x-image-url-cache-file - temp-file mh-x-image-temp-file)) - (cond - ;; Check if we have `convert' - ((eq mh-x-image-scaling-function 'ignore) - (message "The \"convert\" program is needed to display X-Image-URL") - (mh-x-image-set-download-state cache-filename 'try-again)) - ;; Scale fetched image - ((and (funcall mh-x-image-scaling-function temp-file cache-filename) - nil)) - ;; Attempt to display image if we have it - ((file-exists-p cache-filename) - (mh-x-image-display cache-filename marker)) - ;; We didn't find the image. Should we try to display it the next time? - (t (mh-x-image-set-download-state cache-filename 'try-again))) - (ignore-errors - (set-marker marker nil) - (delete-process process) - (kill-buffer wget-buffer) - (delete-file temp-file))))) - -(defun mh-x-image-url-sane-p (url) - "Check if URL is something sensible." - (let ((len (length url))) - (cond ((< len 5) nil) - ((not (equal (substring url 0 5) "http:")) nil) - ((> len 100) nil) - (t t)))) - -(defun mh-x-image-url-display (url) - "Display image from location URL. -If the URL isn't present in the cache then it is fetched with wget." - (let* ((cache-filename (mh-x-image-url-cache-canonicalize url)) - (state (mh-x-image-get-download-state cache-filename)) - (marker (set-marker (make-marker) (point)))) - (set (make-local-variable 'mh-x-image-marker) marker) - (cond ((not (mh-x-image-url-sane-p url))) - ((eq state 'ok) - (mh-x-image-display cache-filename marker)) - ((or (not mh-wget-executable) - (eq mh-x-image-scaling-function 'ignore))) - ((eq state 'never)) - ((not mh-fetch-x-image-url) - (set-marker marker nil)) - ((eq state 'try-again) - (mh-x-image-set-download-state cache-filename nil) - (mh-x-image-url-fetch-image url cache-filename marker - 'mh-x-image-scale-and-display)) - ((and (eq mh-fetch-x-image-url 'ask) - (not (y-or-n-p (format "Fetch %s? " url)))) - (mh-x-image-set-download-state cache-filename 'never)) - ((eq state nil) - (mh-x-image-url-fetch-image url cache-filename marker - 'mh-x-image-scale-and-display))))) +(add-to-list 'debug-ignored-errors "^Cursor not pointing to message$") -(defun mh-maybe-show (&optional msg) - "Display message at cursor, but only if in show mode. -If optional arg MSG is non-nil, display that message instead." - (if mh-showing-mode (mh-show msg))) - -(defun mh-show (&optional message redisplay-flag) - "Display message\\<mh-folder-mode-map>. - -If the message under the cursor is already displayed, this command -scrolls to the beginning of the message. MH-E normally hides a lot of -the superfluous header fields that mailers add to a message, but if -you wish to see all of them, use the command \\[mh-header-display]. - -Two hooks can be used to control how messages are displayed. The -first hook, `mh-show-mode-hook', is called early on in the -process of the message display. It is usually used to perform -some action on the message's content. The second hook, -`mh-show-hook', is the last thing called after messages are -displayed. It's used to affect the behavior of MH-E in general or -when `mh-show-mode-hook' is too early. - -From a program, optional argument MESSAGE can be used to display an -alternative message. The optional argument REDISPLAY-FLAG forces the -redisplay of the message even if the show buffer was already -displaying the correct message. - -See the \"mh-show\" customization group for a litany of options that -control what displayed messages look like." - (interactive (list nil t)) - (when (or redisplay-flag - (and mh-showing-with-headers - (or mh-mhl-format-file mh-clean-message-header-flag))) - (mh-invalidate-show-buffer)) - (mh-show-msg message)) - -(defun mh-show-mouse (event) - "Move point to mouse EVENT and show message." - (interactive "e") - (mouse-set-point event) - (mh-show)) - -(defun mh-summary-height () - "Return ideal value for the variable `mh-summary-height'. -The current frame height is taken into consideration." - (or (and (fboundp 'frame-height) - (> (frame-height) 24) - (min 10 (/ (frame-height) 6))) - 4)) - -(defun mh-show-msg (msg) - "Show MSG. - -The hook `mh-show-hook' is called after the message has been -displayed." - (if (not msg) - (setq msg (mh-get-msg-num t))) - (mh-showing-mode t) - (setq mh-page-to-next-msg-flag nil) - (let ((folder mh-current-folder) - (folders (list mh-current-folder)) - (clean-message-header mh-clean-message-header-flag) - (show-window (get-buffer-window mh-show-buffer)) - (display-mime-buttons-flag mh-display-buttons-for-inline-parts-flag)) - (if (not (eq (next-window (minibuffer-window)) (selected-window))) - (delete-other-windows)) ; force ourself to the top window - (mh-in-show-buffer (mh-show-buffer) - (setq mh-display-buttons-for-inline-parts-flag display-mime-buttons-flag) - (if (and show-window - (equal (mh-msg-filename msg folder) buffer-file-name)) - (progn ;just back up to start - (goto-char (point-min)) - (if (not clean-message-header) - (mh-start-of-uncleaned-message))) - (mh-display-msg msg folder))) - (if (not (= (1+ (window-height)) (frame-height))) ;not horizontally split - (shrink-window (- (window-height) (or mh-summary-height - (mh-summary-height))))) - (mh-recenter nil) - ;; The following line is a nop which forces update of the scan line so - ;; that font-lock will update it (if needed)... - (mh-notate nil nil mh-cmd-note) - (if (not (memq msg mh-seen-list)) - (setq mh-seen-list (cons msg mh-seen-list))) - (when mh-update-sequences-after-mh-show-flag - (mh-update-sequences) - (when mh-index-data - (setq folders - (append (mh-index-delete-from-sequence mh-unseen-seq (list msg)) - folders))) - (when (mh-speed-flists-active-p) - (apply #'mh-speed-flists t folders))) - (run-hooks 'mh-show-hook))) - -(defun mh-modify (&optional message) - "Edit message. - -There are times when you need to edit a message. For example, you -may need to fix a broken Content-Type header field. You can do -this with this command. It displays the raw message in an -editable buffer. When you are done editing, save and kill the -buffer as you would any other. - -From a program, edit MESSAGE; nil means edit current message." - (interactive) - (let* ((message (or message (mh-get-msg-num t))) - (msg-filename (mh-msg-filename message)) - edit-buffer) - (when (not (file-exists-p msg-filename)) - (error "Message %d does not exist" message)) - - ;; Invalidate the show buffer if it is showing the same message that is - ;; to be edited. - (when (and (buffer-live-p (get-buffer mh-show-buffer)) - (equal (save-excursion (set-buffer mh-show-buffer) - buffer-file-name) - msg-filename)) - (mh-invalidate-show-buffer)) - - ;; Edit message - (find-file msg-filename) - (setq edit-buffer (current-buffer)) - - ;; Set buffer properties - (mh-letter-mode) - (use-local-map text-mode-map) - - ;; Just show the edit buffer... - (delete-other-windows) - (switch-to-buffer edit-buffer))) - -(defun mh-show-unquote-From () - "Decode >From at beginning of lines for `mh-show-mode'." - (save-excursion - (let ((modified (buffer-modified-p)) - (case-fold-search nil) - (buffer-read-only nil)) - (goto-char (mh-mail-header-end)) - (while (re-search-forward "^>From" nil t) - (replace-match "From")) - (set-buffer-modified-p modified)))) - -(defun mh-msg-folder (folder-name) - "Return the name of the buffer for FOLDER-NAME." - folder-name) - -(defun mh-display-msg (msg-num folder-name) - "Display MSG-NUM of FOLDER-NAME. -Sets the current buffer to the show buffer." - (let ((folder (mh-msg-folder folder-name))) - (set-buffer folder) - ;; When Gnus uses external displayers it has to keep handles longer. So - ;; we will delete these handles when mh-quit is called on the folder. It - ;; would be nicer if there are weak pointers in emacs lisp, then we could - ;; get the garbage collector to do this for us. - (unless (mh-buffer-data) - (setf (mh-buffer-data) (mh-make-buffer-data))) - ;; Bind variables in folder buffer in case they are local - (let ((formfile mh-mhl-format-file) - (clean-message-header mh-clean-message-header-flag) - (invisible-headers mh-invisible-header-fields-compiled) - (visible-headers nil) - (msg-filename (mh-msg-filename msg-num folder-name)) - (show-buffer mh-show-buffer) - (mm-inline-media-tests mh-mm-inline-media-tests)) - (if (not (file-exists-p msg-filename)) - (error "Message %d does not exist" msg-num)) - (if (and (> mh-show-maximum-size 0) - (> (elt (file-attributes msg-filename) 7) - mh-show-maximum-size) - (not (y-or-n-p - (format - "Message %d (%d bytes) exceeds %d bytes. Display it? " - msg-num (elt (file-attributes msg-filename) 7) - mh-show-maximum-size)))) - (error "Message %d not displayed" msg-num)) - (set-buffer show-buffer) - (cond ((not (equal msg-filename buffer-file-name)) - (mh-unvisit-file) - (setq buffer-read-only nil) - ;; Cleanup old mime handles - (mh-mime-cleanup) - (erase-buffer) - ;; Changing contents, so this hook needs to be reinitialized. - ;; pgp.el uses this. - (if (boundp 'write-contents-hooks) ;Emacs 19 - (kill-local-variable 'write-contents-hooks)) - (if formfile - (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear" - (if (stringp formfile) - (list "-form" formfile)) - msg-filename) - (insert-file-contents-literally msg-filename)) - ;; Use mm to display buffer - (when (and mh-decode-mime-flag (not formfile)) - (mh-add-missing-mime-version-header) - (setf (mh-buffer-data) (mh-make-buffer-data)) - (mh-mime-display)) - (mh-show-mode) - ;; Header cleanup - (goto-char (point-min)) - (cond (clean-message-header - (mh-clean-msg-header (point-min) - invisible-headers - visible-headers) - (goto-char (point-min))) - (t - (mh-start-of-uncleaned-message))) - (mh-decode-message-header) - ;; the parts of visiting we want to do (no locking) - (or (eq buffer-undo-list t) ;don't save undo info for prev msgs - (setq buffer-undo-list nil)) - (set-buffer-auto-saved) - ;; the parts of set-visited-file-name we want to do (no locking) - (setq buffer-file-name msg-filename) - (setq buffer-backed-up nil) - (auto-save-mode 1) - (set-mark nil) - (unwind-protect - (when (and mh-decode-mime-flag (not formfile)) - (setq buffer-read-only nil) - (mh-display-smileys) - (mh-display-emphasis)) - (setq buffer-read-only t)) - (set-buffer-modified-p nil) - (setq mh-show-folder-buffer folder) - (setq mode-line-buffer-identification - (list (format mh-show-buffer-mode-line-buffer-id - folder-name msg-num))) - (mh-logo-display) - (set-buffer folder) - (setq mh-showing-with-headers nil)))))) - -(defun mh-clean-msg-header (start invisible-headers visible-headers) - "Flush extraneous lines in message header. - -Header is cleaned from START to the end of the message header. -INVISIBLE-HEADERS contains a regular expression specifying lines -to delete from the header. VISIBLE-HEADERS contains a regular -expression specifying the lines to display. INVISIBLE-HEADERS is -ignored if VISIBLE-HEADERS is non-nil." - ;; XXX Note that MH-E no longer supports the `mh-visible-headers' - ;; variable, so this function could be trimmed of this feature too." - (let ((case-fold-search t) - (buffer-read-only nil)) - (save-restriction - (goto-char start) - (if (search-forward "\n\n" nil 'move) - (backward-char 1)) - (narrow-to-region start (point)) - (goto-char (point-min)) - (if visible-headers - (while (< (point) (point-max)) - (cond ((looking-at visible-headers) - (forward-line 1) - (while (looking-at "[ \t]") (forward-line 1))) - (t - (mh-delete-line 1) - (while (looking-at "[ \t]") - (mh-delete-line 1))))) - (while (re-search-forward invisible-headers nil t) - (beginning-of-line) - (mh-delete-line 1) - (while (looking-at "[ \t]") - (mh-delete-line 1))))) - (let ((mh-compose-skipped-header-fields ())) - (mh-letter-hide-all-skipped-fields)) - (unlock-buffer))) - -(defun mh-delete-line (lines) - "Delete the next LINES lines." - (delete-region (point) (progn (forward-line lines) (point)))) - -(defun mh-notate (msg notation offset) - "Mark MSG with the character NOTATION at position OFFSET. -Null MSG means the message at cursor. -If NOTATION is nil then no change in the buffer occurs." - (save-excursion - (if (or (null msg) - (mh-goto-msg msg t t)) - (with-mh-folder-updating (t) - (beginning-of-line) - (forward-char offset) - (let* ((change-stack-flag - (and (equal offset - (+ mh-cmd-note mh-scan-field-destination-offset)) - (not (eq notation mh-note-seq)))) - (msg (and change-stack-flag (or msg (mh-get-msg-num nil)))) - (stack (and msg (gethash msg mh-sequence-notation-history))) - (notation (or notation (char-after)))) - (if stack - ;; The presence of the stack tells us that we don't need to - ;; notate the message, since the notation would be replaced - ;; by a sequence notation. So we will just put the notation - ;; at the bottom of the stack. If the sequence is deleted, - ;; the correct notation will be shown. - (setf (gethash msg mh-sequence-notation-history) - (reverse (cons notation (cdr (reverse stack))))) - ;; Since we don't have any sequence notations in the way, just - ;; notate the scan line. - (delete-char 1) - (insert notation)) - (when change-stack-flag - (mh-thread-update-scan-line-map msg notation offset))))))) - -(defun mh-goto-msg (number &optional no-error-if-no-message dont-show) - "Go to a message\\<mh-folder-mode-map>. - -You can enter the message NUMBER either before or after typing -\\[mh-goto-msg]. In the latter case, Emacs prompts you. - -In a program, optional non-nil second argument NO-ERROR-IF-NO-MESSAGE -means return nil instead of signaling an error if message does not -exist\; in this case, the cursor is positioned near where the message -would have been. Non-nil third argument DONT-SHOW means not to show -the message." - (interactive "NGo to message: ") - (setq number (prefix-numeric-value number)) - (let ((point (point)) - (return-value t)) - (goto-char (point-min)) - (unless (re-search-forward (format mh-scan-msg-search-regexp number) nil t) - (goto-char point) - (unless no-error-if-no-message - (error "No message %d" number)) - (setq return-value nil)) - (beginning-of-line) - (or dont-show (not return-value) (mh-maybe-show number)) - return-value)) - -(defun mh-set-folder-modified-p (flag) - "Mark current folder as modified or unmodified according to FLAG." - (set-buffer-modified-p flag)) - -(defun mh-find-seq (name) - "Return sequence NAME." - (assoc name mh-seq-list)) - -(defun mh-seq-to-msgs (seq) - "Return a list of the messages in SEQ." - (mh-seq-msgs (mh-find-seq seq))) - -(defun mh-update-scan-format (fmt width) - "Return a scan format with the (msg) width in the FMT replaced with WIDTH. - -The message number width portion of the format is discovered -using `mh-scan-msg-format-regexp'. Its replacement is controlled -with `mh-scan-msg-format-string'." - (or (and - (string-match mh-scan-msg-format-regexp fmt) - (let ((begin (match-beginning 1)) - (end (match-end 1))) - (concat (substring fmt 0 begin) - (format mh-scan-msg-format-string width) - (substring fmt end)))) - fmt)) - -(defun mh-msg-num-width (folder) - "Return the width of the largest message number in this FOLDER." - (or mh-progs (mh-find-path)) - (let ((tmp-buffer (get-buffer-create mh-temp-buffer)) - (width 0)) - (save-excursion - (set-buffer tmp-buffer) - (erase-buffer) - (apply 'call-process - (expand-file-name mh-scan-prog mh-progs) nil '(t nil) nil - (list folder "last" "-format" "%(msg)")) - (goto-char (point-min)) - (if (re-search-forward mh-scan-msg-number-regexp nil 0 1) - (setq width (length (buffer-substring - (match-beginning 1) (match-end 1)))))) - width)) - -(defun mh-add-msgs-to-seq (msgs seq &optional internal-flag dont-annotate-flag) - "Add MSGS to SEQ. - -Remove duplicates and keep sequence sorted. If optional -INTERNAL-FLAG is non-nil, do not mark the message in the scan -listing or inform MH of the addition. - -If DONT-ANNOTATE-FLAG is non-nil then the annotations in the -folder buffer are not updated." - (let ((entry (mh-find-seq seq)) - (internal-seq-flag (mh-internal-seq seq))) - (if (and msgs (atom msgs)) (setq msgs (list msgs))) - (if (null entry) - (setq mh-seq-list - (cons (mh-make-seq seq (mh-canonicalize-sequence msgs)) - mh-seq-list)) - (if msgs (setcdr entry (mh-canonicalize-sequence - (append msgs (mh-seq-msgs entry)))))) - (unless internal-flag - (mh-add-to-sequence seq msgs) - (when (not dont-annotate-flag) - (mh-iterate-on-range msg msgs - (unless (memq msg (cdr entry)) - (mh-add-sequence-notation msg internal-seq-flag))))))) - -(defun mh-canonicalize-sequence (msgs) - "Sort MSGS in decreasing order and remove duplicates." - (let* ((sorted-msgs (sort (copy-sequence msgs) '>)) - (head sorted-msgs)) - (while (cdr head) - (if (= (car head) (cadr head)) - (setcdr head (cddr head)) - (setq head (cdr head)))) - sorted-msgs)) +;;; Folder Cache and Access (defvar mh-sub-folders-cache (make-hash-table :test #'equal)) (defvar mh-current-folder-name nil) (defvar mh-flists-partial-line "") (defvar mh-flists-process nil) +;;;###mh-autoload +(defun mh-clear-sub-folders-cache () + "Clear `mh-sub-folders-cache'." + (clrhash mh-sub-folders-cache)) + ;; Initialize mh-sub-folders-cache... (defun mh-collect-folder-names () "Collect folder names by running \"folders\"." @@ -2050,17 +392,17 @@ folder buffer are not updated." PROCESS is the flists process that was run to collect folder names and the function is called when OUTPUT is available." (let ((position 0) - (prevailing-match-data (match-data)) - line-end folder) + (prevailing-match-data (match-data)) + line-end folder) (unwind-protect - (while (setq line-end (string-match "\n" output position)) - (setq folder (format "+%s%s" + (while (setq line-end (string-match "\n" output position)) + (setq folder (format "+%s%s" mh-flists-partial-line (substring output position line-end))) - (setq mh-flists-partial-line "") + (setq mh-flists-partial-line "") (unless (equal (aref folder 1) ?.) (mh-populate-sub-folders-cache folder)) - (setq position (1+ line-end))) + (setq position (1+ line-end))) (set-match-data prevailing-match-data)) (setq mh-flists-partial-line (substring output position)))) @@ -2148,6 +490,7 @@ number of sub-folders. XXX" t nil)) +;;;###mh-autoload (defun mh-folder-list (folder) "Return FOLDER and its descendents. Returns a list of strings. For example, @@ -2176,6 +519,7 @@ not be returned." (mh-folder-list (concat folder (car f))))))) folder-list)) +;;;###mh-autoload (defun mh-sub-folders (folder &optional add-trailing-slash-flag) "Find the subfolders of FOLDER. The function avoids running folders unnecessarily by caching the @@ -2244,6 +588,7 @@ directories that aren't usually mail folders are hidden." results)))) results)) +;;;###mh-autoload (defun mh-remove-from-sub-folders-cache (folder) "Remove FOLDER and its parent from `mh-sub-folders-cache'. FOLDER should be unconditionally removed from the cache. Also the @@ -2269,12 +614,33 @@ otherwise completion on +foo won't tell us about the option (setq one-ancestor-found t)))) (remhash nil mh-sub-folders-cache)))) + + +;;; Folder Utilities + +;;;###mh-autoload +(defun mh-folder-name-p (name) + "Return non-nil if NAME is the name of a folder. +A name (a string or symbol) can be a folder name if it begins +with \"+\"." + (if (symbolp name) + (eq (aref (symbol-name name) 0) ?+) + (and (> (length name) 0) + (eq (aref name 0) ?+)))) + +;;;###mh-autoload +(defun mh-expand-file-name (filename &optional default) + "Expand FILENAME like `expand-file-name', but also handle MH folder names. +Any filename that starts with '+' is treated as a folder name. +See `expand-file-name' for description of DEFAULT." + (if (mh-folder-name-p filename) + (expand-file-name (substring filename 1) mh-user-path) + (expand-file-name filename default))) + (defvar mh-folder-hist nil) ;; Shush compiler. -(eval-when-compile - (defvar mh-speed-folder-map) - (defvar mh-speed-flists-cache)) +(eval-when-compile (defvar mh-speed-flists-cache)) (defvar mh-allow-root-folder-flag nil "Non-nil means \"+\" is an acceptable folder name. @@ -2289,12 +655,14 @@ This variable should never be set.") (defvar mh-speed-flists-inhibit-flag nil) +;;;###mh-autoload (defun mh-speed-flists-active-p () "Check if speedbar is running with message counts enabled." (and (featurep 'mh-speed) (not mh-speed-flists-inhibit-flag) (> (hash-table-count mh-speed-flists-cache) 0))) +;;;###mh-autoload (defun mh-folder-completion-function (name predicate flag) "Programmable completion for folder names. NAME is the partial folder name that has been input. PREDICATE if @@ -2332,6 +700,12 @@ and FLAG determines whether the completion is over." ((equal path mh-user-path) nil) (t (file-exists-p path)))))))) +;; Shush compiler. +(eval-when-compile + (mh-do-in-xemacs + (defvar completion-root-regexp) + (defvar minibuffer-completing-file-name))) + (defun mh-folder-completing-read (prompt default allow-root-folder-flag) "Read folder name with PROMPT and default result DEFAULT. If ALLOW-ROOT-FOLDER-FLAG is non-nil then \"+\" is allowed to be @@ -2345,6 +719,7 @@ a folder name corresponding to `mh-user-path'." 'mh-folder-hist default)) t)) +;;;###mh-autoload (defun mh-prompt-for-folder (prompt default can-create &optional default-string allow-root-folder-flag) "Prompt for a folder name with PROMPT. @@ -2408,37 +783,90 @@ used in searching." -;;; List and string manipulation - -(defun mh-list-to-string (l) - "Flatten the list L and make every element of the new list into a string." - (nreverse (mh-list-to-string-1 l))) - -(defun mh-list-to-string-1 (l) - "Flatten the list L and make every element of the new list into a string." - (let ((new-list nil)) - (while l - (cond ((null (car l))) - ((symbolp (car l)) - (setq new-list (cons (symbol-name (car l)) new-list))) - ((numberp (car l)) - (setq new-list (cons (int-to-string (car l)) new-list))) - ((equal (car l) "")) - ((stringp (car l)) (setq new-list (cons (car l) new-list))) - ((listp (car l)) - (setq new-list (nconc (mh-list-to-string-1 (car l)) - new-list))) - (t (error "Bad element in `mh-list-to-string': %s" (car l)))) - (setq l (cdr l))) - new-list)) +;;; Message Utilities -(defun mh-replace-string (old new) - "Replace all occurrences of OLD with NEW in the current buffer. -Ignores case when searching for OLD." +;; Functions that would ordinarily be in mh-letter.el that are needed +;; by mh-show.el are found here in order to prevent the loading of +;; mh-letter.el until a message is actually composed. + +;;;###mh-autoload +(defun mh-in-header-p () + "Return non-nil if the point is in the header of a draft message." + (< (point) (mh-mail-header-end))) + +;;;###mh-autoload +(defun mh-extract-from-header-value () + "Extract From: string from header." + (save-excursion + (if (not (mh-goto-header-field "From:")) + nil + (skip-chars-forward " \t") + (buffer-substring-no-properties + (point) (progn (mh-header-field-end)(point)))))) + +;;;###mh-autoload +(defun mh-goto-header-field (field) + "Move to FIELD in the message header. +Move to the end of the FIELD name, which should end in a colon. +Returns t if found, nil if not." (goto-char (point-min)) - (let ((case-fold-search t)) - (while (search-forward old nil t) - (replace-match new t t)))) + (let ((case-fold-search t) + (headers-end (save-excursion + (mh-goto-header-end 0) + (point)))) + (re-search-forward (format "^%s" field) headers-end t))) + +;;;###mh-autoload +(defun mh-goto-header-end (arg) + "Move the cursor ARG lines after the header." + (if (re-search-forward "^-*$" nil nil) + (forward-line arg))) + +;;;###mh-autoload +(defun mh-mail-header-end () + "Substitute for `mail-header-end' that doesn't widen the buffer. + +In MH-E we frequently need to find the end of headers in nested +messages, where the buffer has been narrowed. This function works +in this situation." + (save-excursion + ;; XXX: The following replaces a call to rfc822-goto-eoh. Occasionally, + ;; mail headers that MH-E has to read contains lines of the form: + ;; From xxx@yyy Mon May 10 11:48:07 2004 + ;; In this situation, rfc822-goto-eoh doesn't go to the end of the + ;; header. The replacement allows From_ lines in the mail header. + (goto-char (point-min)) + (loop for p = (re-search-forward + "^\\([:\n]\\|[^: \t\n]+[ \t\n]\\)" nil 'move) + do (cond ((null p) (return)) + (t (goto-char (match-beginning 0)) + (unless (looking-at "From ") (return)) + (goto-char p)))) + (point))) + +;;;###mh-autoload +(defun mh-header-field-beginning () + "Move to the beginning of the current header field. +Handles RFC 822 continuation lines." + (beginning-of-line) + (while (looking-at "^[ \t]") + (forward-line -1))) + +;;;###mh-autoload +(defun mh-header-field-end () + "Move to the end of the current header field. +Handles RFC 822 continuation lines." + (forward-line 1) + (while (looking-at "^[ \t]") + (forward-line 1)) + (backward-char 1)) ;to end of previous line + +;;;###mh-autoload +(defun mh-signature-separator-p () + "Return non-nil if buffer includes \"^-- $\"." + (save-excursion + (goto-char (point-min)) + (re-search-forward mh-signature-separator-regexp nil t))) (provide 'mh-utils) |