Mercurial > emacs
diff lisp/mh-e/mh-utils.el @ 88155:d7ddb3e565de
sync with trunk
| author | Henrik Enberg <henrik.enberg@telia.com> |
|---|---|
| date | Mon, 16 Jan 2006 00:03:54 +0000 |
| parents | 0d8b17d428b5 |
| children |
line wrap: on
line diff
--- a/lisp/mh-e/mh-utils.el Sun Jan 15 23:02:10 2006 +0000 +++ b/lisp/mh-e/mh-utils.el Mon Jan 16 00:03:54 2006 +0000 @@ -1,6 +1,7 @@ ;;; mh-utils.el --- MH-E code needed for both sending and reading -;; Copyright (C) 1993, 1995, 1997, 2000, 2001, 2002 Free Software Foundation, Inc. +;; Copyright (C) 1993, 1995, 1997, +;; 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. ;; Author: Bill Wohler <wohler@newt.com> ;; Maintainer: Bill Wohler <wohler@newt.com> @@ -21,8 +22,8 @@ ;; 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., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: @@ -30,156 +31,158 @@ ;;; Change Log: -;; $Id: mh-utils.el,v 1.2 2003/02/03 20:55:30 wohler Exp $ - ;;; Code: -;; Is this XEmacs-land? Located here since needed by mh-customize.el. -(defvar mh-xemacs-flag (featurep 'xemacs) - "Non-nil means the current Emacs is XEmacs.") +;;(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))) -(require 'cl) -(require 'gnus-util) -(require 'font-lock) -(require 'mh-loaddefs) -(require 'mh-customize) +(eval-when-compile (require 'mh-acros)) +(mh-require-cl) -(load "mm-decode" t t) ; Non-fatal dependency -(load "mm-view" t t) ; Non-fatal dependency -(load "executable" t t) ; Non-fatal dependency on - ; executable-find +(require 'font-lock) +(require 'gnus-util) +(require 'mh-buffers) +(require 'mh-customize) +(require 'mh-inc) +(require 'mouse) +(require 'sendmail) +;;(message "< mh-utils") -;; Shush the byte-compiler -(defvar font-lock-auto-fontify) -(defvar font-lock-defaults) -(defvar mark-active) -(defvar tool-bar-mode) +;; 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 'mail-header-end "sendmail") -(autoload 'Info-goto-node "info") +(autoload 'message-fetch-field "message") +(autoload 'message-tokenize-header "message") (unless (fboundp 'make-hash-table) (autoload 'make-hash-table "cl")) -;;; Set for local environment: -;;; mh-progs and mh-lib used to be set in paths.el, which tried to -;;; figure out at build time which of several possible directories MH -;;; was installed into. But if you installed MH after building Emacs, -;;; this would almost certainly be wrong, so now we do it at run time. - -(defvar mh-progs nil - "Directory containing MH commands, such as inc, repl, and rmm.") - -(defvar mh-lib nil - "Directory containing the MH library. -This directory contains, among other things, the components file.") - -(defvar mh-lib-progs nil - "Directory containing MH helper programs. -This directory contains, among other things, the mhl program.") - -(defvar mh-nmh-flag nil - "Non-nil means nmh is installed on this system instead of MH.") - -;;;###autoload -(put 'mh-progs 'risky-local-variable t) -;;;###autoload -(put 'mh-lib 'risky-local-variable t) -;;;###autoload -(put 'mh-lib-progs 'risky-local-variable t) -;;;###autoload -(put 'mh-nmh-flag 'risky-local-variable t) + ;;; CL Replacements + (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 used in lieu -of `search' in the CL package." +If CHAR is not present in STRING then return nil. The function is +used in lieu of `search' in the CL package." (loop for index from (1- (length string)) downto 0 when (equal (aref string index) char) return index finally return nil)) -;;; Macro to generate correct code for different emacs variants +;; Additional header fields that might someday be added: +;; "Sender: " "Reply-to: " -(defmacro mh-mark-active-p (check-transient-mark-mode-flag) - "A macro that expands into appropriate code in XEmacs and nil in GNU Emacs. -In GNU Emacs if CHECK-TRANSIENT-MARK-MODE-FLAG is non-nil then check if -variable `transient-mark-mode' is active." - (cond (mh-xemacs-flag ;XEmacs - `(and (boundp 'zmacs-regions) zmacs-regions (region-active-p))) - ((not check-transient-mark-mode-flag) ;GNU Emacs - `(and (boundp 'mark-active) mark-active)) - (t ;GNU Emacs - `(and (boundp 'transient-mark-mode) transient-mark-mode - (boundp 'mark-active) mark-active)))) + -;;; Additional header fields that might someday be added: -;;; "Sender: " "Reply-to: " +;;; Scan Line Formats (defvar mh-scan-msg-number-regexp "^ *\\([0-9]+\\)" - "Regexp to find the number of a message in a scan line. -The message's number must be surrounded with \\( \\)") + "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]" - "Regexp to find a scan line in which the message number overflowed. -The message's number is left truncated in this case.") + "This regular expression matches overflowed message numbers.") (defvar mh-scan-msg-format-regexp "%\\([0-9]*\\)(msg)" - "Regexp to find message number width in an scan format. -The message number width must be surrounded with \\( \\).") + "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" - "Format string for width of the message number in a scan format. -Use `0%d' for zero-filled message numbers.") + "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]" - "Format string containing a regexp matching the scan listing for a message. -The desired message's number will be an argument to format.") + "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. -(defvar mh-default-folder-for-message-function nil - "Function to select a default folder for refiling or Fcc. -If set to a function, that function is called with no arguments by -`\\[mh-refile-msg]' and `\\[mh-to-fcc]' to get a default when -prompting the user for a folder. The function is called from within a -`save-excursion', with point at the start of the message. It should -return the folder to offer as the refile or Fcc folder, as a string -with a leading `+' sign. It can also return an empty string to use no -default, or nil to calculate the default the usual way. -NOTE: This variable is not an ordinary hook; -It may not be a list of functions.") +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-cmd-note 4 - "Column to insert notation. -Use `mh-set-cmd-note' to modify it. -This value may be dynamically updated if `mh-adaptive-cmd-note-flag' is -non-nil and `mh-scan-format-file' is t. -Note that the first column is column number 0.") -(make-variable-buffer-local 'mh-cmd-note) +First argument is folder name. Second is message number.") -(defvar mh-note-seq "%" - "String whose first character is used to notate messages in a sequence.") + (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. + +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'.") -Do not make this a regexp 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 "-- \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. -(defstruct (mh-buffer-data (:conc-name mh-mime-) - (:constructor mh-make-buffer-data)) +(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 @@ -187,7 +190,8 @@ ; 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) ...) + +;; 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)) @@ -195,9 +199,6 @@ (defvar mh-globals-hash (make-hash-table) "Keeps track of MIME data on a per buffer basis.") -(defvar mh-gnus-pgp-support-flag (not (not (locate-library "mml2015"))) - "Non-nil means installed Gnus has PGP support.") - (defvar mh-mm-inline-media-tests `(("image/jpeg" mm-inline-image @@ -287,30 +288,18 @@ (".*" mm-inline-text mm-readable-p)) "Alist of media types/tests saying whether types can be displayed inline.") -;; Needed by mh-comp.el and mh-mime.el -(defvar mh-mhn-compose-insert-flag nil - "Non-nil means MIME insertion was done. -Triggers an automatic call to `mh-edit-mhn' in `mh-send-letter'. -This variable is buffer-local.") -(make-variable-buffer-local 'mh-mhn-compose-insert-flag) - -(defvar mh-mml-compose-insert-flag nil - "Non-nil means that a MIME insertion was done. -This buffer-local variable is used to remember if a MIME insertion was done. -Triggers an automatic call to `mh-mml-to-mime' in `mh-send-letter'.") -(make-variable-buffer-local 'mh-mml-compose-insert-flag) - ;; Copy of `goto-address-mail-regexp' (defvar mh-address-mail-regexp - "[-a-zA-Z0-9._]+@[-a-zA-z0-9_]+\\.+[a-zA-Z0-9]+" + "[-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. -;;;###mh-autoload + (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." + +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 @@ -318,9 +307,30 @@ (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) (mail-header-end))) + (< (point) (mh-mail-header-end))) (defun mh-header-field-beginning () "Move to the beginning of the current header field. @@ -342,7 +352,7 @@ Argument LIMIT limits search." (if (= (point) limit) nil - (let* ((mail-header-end (save-match-data (mail-header-end))) + (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)) @@ -354,7 +364,7 @@ Argument LIMIT limits search." (if (= (point) limit) nil - (let* ((mail-header-end (mail-header-end)) + (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 @@ -386,18 +396,30 @@ (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-face)) - (mh-header-to-font-lock (0 'default) (1 mh-show-to-face)) - (mh-header-cc-font-lock (0 'default) (1 mh-show-cc-face)) + '(("^\\(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-face)) - (mh-header-subject-font-lock (0 'default) (1 mh-show-subject-face)) + (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-face)) + (1 'default) + (2 'mh-show-cc)) ("^\\(In-reply-to\\|Date\\):\\(.*\\)$" - (1 'default) (2 mh-show-date-face)) - (mh-letter-header-font-lock (0 mh-show-header-face append t))) - "Additional expressions to highlight in MH-show mode.")) + (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 @@ -416,15 +438,23 @@ (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 mode.") + "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 `mh-highlight-citation-p' 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 (mail-header-end))) + +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)) @@ -433,16 +463,15 @@ (t nil)))) -;; Needed to help shush the byte-compiler. +;; Shush compiler. (if mh-xemacs-flag - (progn - (eval-and-compile - (require 'gnus) - (require 'gnus-art) - (require 'gnus-cite)))) + (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." + "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 @@ -462,68 +491,56 @@ (gnus-article-highlight-citation t) (set-buffer-modified-p modified)))) + + ;;; Internal bookkeeping variables: -;; Cached value of the `Path:' component in the user's MH profile. -;; User's mail folder directory. -(defvar mh-user-path nil) - -;; An mh-draft-folder of nil means do not use a draft folder. -;; Cached value of the `Draft-Folder:' component in the user's MH profile. -;; Name of folder containing draft messages. -(defvar mh-draft-folder nil) +(defvar mh-user-path nil + "Cached value of the \"Path:\" MH profile component. +User's mail folder directory.") -;; Cached value of the `Unseen-Sequence:' component in the user's MH profile. -;; Name of the Unseen sequence. -(defvar mh-unseen-seq nil) +(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.") -;; Cached value of the `Previous-Sequence:' component in the user's MH -;; profile. -;; Name of the Previous sequence. -(defvar mh-previous-seq nil) +(defvar mh-unseen-seq nil + "Cached value of the \"Unseen-Sequence:\" MH profile component. +Name of the Unseen sequence.") -;; Cached value of the `Inbox:' component in the user's MH profile, -;; or "+inbox" if no such component. -;; Name of the Inbox folder. -(defvar mh-inbox nil) - -;; The names of ephemeral buffers have a " *mh-" prefix (so that they are -;; hidden and can be programmatically removed in mh-quit), and the variable -;; names have the form mh-temp-.*-buffer. -(defconst mh-temp-buffer " *mh-temp*") ;scratch +(defvar mh-previous-seq nil + "Cached value of the \"Previous-Sequence:\" MH profile component. +Name of the Previous sequence.") -;; The names of MH-E buffers that are not ephemeral and can be used by the -;; user (and deleted by the user when no longer needed) have a "*MH-E " prefix -;; (so they can be programmatically removed in mh-quit), and the variable -;; names have the form mh-.*-buffer. -(defconst mh-folders-buffer "*MH-E Folders*") ;folder list -(defconst mh-info-buffer "*MH-E Info*") ;version information buffer -(defconst mh-log-buffer "*MH-E Log*") ;output of MH commands and so on -(defconst mh-recipients-buffer "*MH-E Recipients*") ;killed when draft sent -(defconst mh-sequences-buffer "*MH-E Sequences*") ;sequences list +(defvar mh-inbox nil + "Cached value of the \"Inbox:\" MH profile component. +Set to \"+inbox\" if no such component. +Name of the Inbox folder.") -;; Window configuration before MH-E command. -(defvar mh-previous-window-config nil) +(defvar mh-previous-window-config nil + "Window configuration before MH-E command.") -;;Non-nil means next SPC or whatever goes to next undeleted message. -(defvar mh-page-to-next-msg-flag nil) +(defvar mh-page-to-next-msg-flag nil + "Non-nil means next SPC or whatever goes to next undeleted message.") + + ;;; Internal variables local to a folder. -;; Name of current folder, a string. -(defvar mh-current-folder nil) +(defvar mh-current-folder nil + "Name of current folder, a string.") -;; Buffer that displays message for this folder. -(defvar mh-show-buffer nil) +(defvar mh-show-buffer nil + "Buffer that displays message for this folder.") -;; Full path of directory for this folder. -(defvar mh-folder-filename nil) +(defvar mh-folder-filename nil + "Full path of directory for this folder.") -;;Number of msgs in buffer. -(defvar mh-msg-count nil) +(defvar mh-msg-count nil + "Number of msgs in buffer.") -;; If non-nil, show the message in a separate window. -(defvar mh-showing-mode nil) +(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.") @@ -535,35 +552,44 @@ (defun mh-logo-display () "Modify mode line to display MH-E logo." - (when (fboundp 'find-image) - (add-text-properties - 0 2 - `(display ,(or mh-logo-cache - (setq mh-logo-cache - (find-image '((:type xpm :ascent center - :file "mh-logo.xpm")))))) - (car mode-line-buffer-identification)))) + (mh-do-in-gnu-emacs + (add-text-properties + 0 2 + `(display ,(or mh-logo-cache + (setq mh-logo-cache + (mh-funcall-if-exists + find-image '((:type xpm :ascent center + :file "mh-logo.xpm")))))) + (car mode-line-buffer-identification))) + (mh-do-in-xemacs + (setq modeline-buffer-identification + (list + (if mh-modeline-glyph + (cons modeline-buffer-id-left-extent mh-modeline-glyph) + (cons modeline-buffer-id-left-extent "XEmacs%N:")) + (cons modeline-buffer-id-right-extent " %17b"))))) -;;; This holds a documentation string used by describe-mode. (defun mh-showing-mode (&optional arg) "Change whether messages should be displayed. -With arg, display messages iff ARG is positive." + +With ARG, display messages iff ARG is positive." (setq mh-showing-mode (if (null arg) (not mh-showing-mode) (> (prefix-numeric-value arg) 0)))) -;; The sequences of this folder. An alist of (seq . msgs). -(defvar mh-seq-list nil) - -;; List of displayed messages to be removed from the Unseen sequence. -(defvar mh-seen-list nil) +(defvar mh-seq-list nil + "Alist of this folder's sequences. +Elements have the form (SEQUENCE . MESSAGES).") -;; If non-nil, show buffer contains message with all headers. -;; If nil, show buffer contains message processed normally. -;; Showing message with headers or normally. -(defvar mh-showing-with-headers nil) +(defvar mh-seen-list nil + "List of displayed messages to be removed from the \"Unseen\" sequence.") +(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-E macros @@ -571,8 +597,8 @@ "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." +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)) @@ -585,7 +611,7 @@ ,@(if (not save-modification-flag) '((mh-set-folder-modified-p nil))))) -(put 'with-mh-folder-updating 'lisp-indent-hook 1) +(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). @@ -600,7 +626,41 @@ ,@body) (select-window mh-in-show-buffer-saved-window)))) -(put 'mh-in-show-buffer 'lisp-indent-hook 1) +(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." @@ -616,9 +676,12 @@ (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) @@ -659,29 +722,28 @@ (unlock-buffer) (setq buffer-file-name nil)) -;;;###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." +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) - (string-to-int (buffer-substring (match-beginning 1) - (match-end 1)))) + (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 \"+\"." +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. @@ -690,7 +752,6 @@ (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) @@ -698,17 +759,17 @@ (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. +;; 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." +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" + ,(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 @@ -726,11 +787,13 @@ folder-buffer) (delete-other-windows)) (mh-goto-cur-msg t) - (and (fboundp 'deactivate-mark) (deactivate-mark)) + (mh-funcall-if-exists deactivate-mark) (unwind-protect (prog1 (call-interactively (function ,original-function)) (setq normal-exit t)) - (and (fboundp 'deactivate-mark) (deactivate-mark)) + (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 @@ -740,8 +803,8 @@ (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. +;; 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 @@ -783,7 +846,6 @@ (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-search-folder mh-search-folder 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) @@ -793,8 +855,11 @@ (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-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 @@ -819,11 +884,31 @@ (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) -;;; Populate mh-show-mode-map + + +;;; 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 @@ -844,7 +929,6 @@ "g" mh-show-goto-msg "i" mh-show-inc-folder "k" mh-show-delete-subject-or-thread - "l" mh-show-print-msg "m" mh-show-send "n" mh-show-next-undeleted-msg "\M-n" mh-show-next-unread-msg @@ -862,19 +946,23 @@ (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 - "i" mh-index-search "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-show-search-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 @@ -884,6 +972,21 @@ "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 @@ -894,8 +997,13 @@ "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 + "f" mh-show-narrow-to-from + "r" mh-show-narrow-to-range "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) @@ -913,9 +1021,11 @@ (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) @@ -932,7 +1042,12 @@ ["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])) @@ -979,30 +1094,38 @@ "--" ["List Folders" mh-show-list-folders t] ["Visit a Folder..." mh-show-visit-folder t] - ["Search a Folder..." mh-show-search-folder t] - ["Indexed Search..." mh-index-search 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) -;;; 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 value of `mh-show-mode-hook' is a list of functions to -be called, with no arguments, upon entry to this mode." + +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-p 'font-lock) + ((equal mh-highlight-citation-style 'font-lock) (setq font-lock-defaults '(mh-show-font-lock-keywords-with-cite t))) - ((equal mh-highlight-citation-p 'gnus) + ((equal mh-highlight-citation-style 'gnus) (setq font-lock-defaults '((mh-show-font-lock-keywords) t nil nil nil (font-lock-fontify-region-function @@ -1013,9 +1136,10 @@ (if (and mh-xemacs-flag font-lock-auto-fontify) (turn-on-font-lock)) - (if (and (boundp 'tool-bar-mode) tool-bar-mode) - (set (make-local-variable 'tool-bar-map) mh-show-tool-bar-map)) + (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) @@ -1023,8 +1147,7 @@ (make-local-variable 'mh-show-folder-buffer) (buffer-disable-undo) (setq buffer-read-only t) - (use-local-map mh-show-mode-map) - (run-hooks 'mh-show-mode-hook)) + (use-local-map mh-show-mode-map)) (defun mh-show-addr () "Use `goto-address'." @@ -1034,92 +1157,576 @@ (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")) + (cond ((and mh-xemacs-flag (locate-library "x-face") (not (featurep 'xface))) (load "x-face" t t) - (if (fboundp 'x-face-xmas-wl-display-x-face) - #'x-face-xmas-wl-display-x-face - #'ignore)) - ((and (not mh-xemacs-flag) (>= emacs-major-version 21)) - (load "x-face-e21" t t) - (if (fboundp 'x-face-decode-message-header) - #'x-face-decode-message-header - #'ignore)) + #'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 mh-show-use-xface-flag - (or mh-decode-mime-flag mhl-formfile + (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))))) + + + (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) - "Show message at cursor. -If optional argument MESSAGE is non-nil, display that message instead. -Force a two-window display with the folder window on top (size -`mh-summary-height') and the show buffer below it. -If the message is already visible, display the start of the message. +(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]. -Display of the message is controlled by setting the variables -`mh-clean-message-header-flag' and `mhl-formfile'. The default behavior is -to scroll uninteresting headers off the top of the window. -Type \"\\[mh-header-display]\" to see the message with all its headers." - (interactive) - (and mh-showing-with-headers - (or mhl-formfile mh-clean-message-header-flag) - (mh-invalidate-show-buffer)) +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) +(defun mh-show-mouse (event) "Move point to mouse EVENT and show message." (interactive "e") - (mouse-set-point EVENT) + (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 value of `mh-show-hook' is a list of functions to be called, with no -arguments, after the message has been displayed." + +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))) + (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) mh-summary-height))) - (mh-recenter nil) - (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)) - (run-hooks 'mh-show-hook)) + (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 at cursor. -If optional argument MESSAGE is non-nil, edit that message instead. -Force a two-window display with the folder window on top (size -`mh-summary-height') and the message editing buffer below it. + "Edit message. -The message is displayed in raw form." +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)) @@ -1147,32 +1754,13 @@ (delete-other-windows) (switch-to-buffer edit-buffer))) -(defun mh-decode-content-transfer-encoded-message () - "Run mimencode on message body, if needed." - (let ((case-fold-search t) - (header-end (mail-header-end))) - (goto-char (point-min)) - (when (re-search-forward "^content-transfer-encoding: " header-end t) - (let ((enc (buffer-substring-no-properties (point) (line-end-position))) - cmdline) - (setq cmdline - (cond ((string-match "base64" enc) (list "-u" "-b" "-p")) - ((string-match "quoted-printable" enc) (list "-u" "-q")) - (t nil))) - (when cmdline - (beginning-of-line) - (insert "Removed-") - (setq header-end (mail-header-end)) - (goto-char (1+ header-end)) - (apply #'call-process-region (1+ header-end) (point-max) "mimencode" - t t nil cmdline)))))) - (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)) - (goto-char (mail-header-end)) + (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)))) @@ -1193,10 +1781,10 @@ (unless (mh-buffer-data) (setf (mh-buffer-data) (mh-make-buffer-data))) ;; Bind variables in folder buffer in case they are local - (let ((formfile mhl-formfile) + (let ((formfile mh-mhl-format-file) (clean-message-header mh-clean-message-header-flag) - (invisible-headers mh-invisible-headers) - (visible-headers mh-visible-headers) + (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)) @@ -1215,6 +1803,8 @@ (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. @@ -1226,15 +1816,12 @@ (list "-form" formfile)) msg-filename) (insert-file-contents-literally msg-filename)) - (if mh-decode-content-transfer-encoded-message-flag - (mh-decode-content-transfer-encoded-message)) - ;; Cleanup old mime handles - (mh-mime-cleanup) ;; 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 @@ -1244,6 +1831,7 @@ (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)) @@ -1253,7 +1841,6 @@ (setq buffer-backed-up nil) (auto-save-mode 1) (set-mark nil) - (mh-show-mode) (unwind-protect (when (and mh-decode-mime-flag (not formfile)) (setq buffer-read-only nil) @@ -1271,13 +1858,16 @@ (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." +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) - (after-change-functions nil)) ;Work around emacs-20 font-lock bug - ;causing an endless loop. + (buffer-read-only nil)) (save-restriction (goto-char start) (if (search-forward "\n\n" nil 'move) @@ -1297,8 +1887,10 @@ (beginning-of-line) (mh-delete-line 1) (while (looking-at "[ \t]") - (mh-delete-line 1)))) - (unlock-buffer)))) + (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." @@ -1306,47 +1898,53 @@ (defun mh-notate (msg notation offset) "Mark MSG with the character NOTATION at position OFFSET. -Null MSG means the message at cursor." +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) - (delete-char 1) - (insert notation))))) - -(defun mh-find-msg-get-num (step) - "Return the message number of the message nearest the cursor. -Jumps over non-message lines, such as inc errors. -If we have to search, STEP tells whether to search forward or backward." - (or (mh-get-msg-num nil) - (let ((msg-num nil) - (nreverses 0)) - (while (and (not msg-num) - (< nreverses 2)) - (cond ((eobp) - (setq step -1) - (setq nreverses (1+ nreverses))) - ((bobp) - (setq step 1) - (setq nreverses (1+ nreverses)))) - (forward-line step) - (setq msg-num (mh-get-msg-num nil))) - msg-num))) + (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) - "Position the cursor at message NUMBER. -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." + "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 "^[ ]*%s[^0-9]+" number) nil t) + (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)) @@ -1355,157 +1953,6 @@ (or dont-show (not return-value) (mh-maybe-show number)) return-value)) -(defun mh-msg-search-pat (n) - "Return a search pattern for message N in the scan listing." - (format mh-scan-msg-search-regexp n)) - -(defun mh-get-profile-field (field) - "Find and return the value of FIELD in the current buffer. -Returns nil if the field is not in the buffer." - (let ((case-fold-search t)) - (goto-char (point-min)) - (cond ((not (re-search-forward (format "^%s" field) nil t)) nil) - ((looking-at "[\t ]*$") nil) - (t - (re-search-forward "[\t ]*\\([^\t \n].*\\)$" nil t) - (let ((start (match-beginning 1))) - (end-of-line) - (buffer-substring start (point))))))) - -(defvar mail-user-agent) -(defvar read-mail-command) - -(defvar mh-find-path-run nil - "Non-nil if `mh-find-path' has been run already.") - -(defun mh-find-path () - "Set `mh-progs', `mh-lib', and `mh-lib-progs' variables. -Set `mh-user-path', `mh-draft-folder', `mh-unseen-seq', `mh-previous-seq', -`mh-inbox' from user's MH profile. -The value of `mh-find-path-hook' is a list of functions to be called, with no -arguments, after these variable have been set." - (mh-find-progs) - (unless mh-find-path-run - (setq mh-find-path-run t) - (setq read-mail-command 'mh-rmail) - (setq mail-user-agent 'mh-e-user-agent)) - (save-excursion - ;; Be sure profile is fully expanded before switching buffers - (let ((profile (expand-file-name (or (getenv "MH") "~/.mh_profile")))) - (set-buffer (get-buffer-create mh-temp-buffer)) - (setq buffer-offer-save nil) ;for people who set default to t - (erase-buffer) - (condition-case err - (insert-file-contents profile) - (file-error - (mh-install profile err))) - (setq mh-user-path (mh-get-profile-field "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 "~")))) - (setq mh-draft-folder (mh-get-profile-field "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-get-profile-field "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-get-profile-field "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-get-profile-field "Previous-Sequence:")) - (if mh-previous-seq - (setq mh-previous-seq (intern mh-previous-seq))) - (run-hooks 'mh-find-path-hook)))) - -(defun mh-file-command-p (file) - "Return t if file FILE is the name of a executable regular file." - (and (file-regular-p file) (file-executable-p file))) - -(defun mh-find-progs () - "Find the directories for the installed MH/nmh binaries and config files. -Set the `mh-progs' and `mh-lib', and `mh-lib-progs' variables to the -directory names and set `mh-nmh-flag' if we detect nmh instead of MH." - (unless (and mh-progs mh-lib mh-lib-progs) - (let ((path (or (mh-path-search exec-path "mhparam") - (mh-path-search '("/usr/local/nmh/bin" ; nmh default - "/usr/local/bin/mh/" - "/usr/local/mh/" - "/usr/bin/mh/" ;Ultrix 4.2, Linux - "/usr/new/mh/" ;Ultrix <4.2 - "/usr/contrib/mh/bin/" ;BSDI - "/usr/pkg/bin/" ; NetBSD - "/usr/local/bin/" - ) - "mhparam")))) - (if (not path) - (error "Unable to find the `mhparam' command")) - (save-excursion - (let ((tmp-buffer (get-buffer-create mh-temp-buffer))) - (set-buffer tmp-buffer) - (unwind-protect - (progn - (call-process (expand-file-name "mhparam" path) - nil '(t nil) nil "libdir" "etcdir") - (goto-char (point-min)) - (if (search-forward-regexp "^libdir:\\s-\\(\\S-+\\)\\s-*$" - nil t) - (setq mh-lib-progs (match-string 1) - mh-lib mh-lib-progs - mh-progs path)) - (goto-char (point-min)) - (if (search-forward-regexp "^etcdir:\\s-\\(\\S-+\\)\\s-*$" - nil t) - (setq mh-lib (match-string 1) - mh-nmh-flag t))) - (kill-buffer tmp-buffer)))) - (unless (and mh-progs mh-lib mh-lib-progs) - (error "Unable to determine paths from `mhparam' command"))))) - -(defun mh-path-search (path file) - "Search PATH, a list of directory names, for FILE. -Returns the element of PATH that contains FILE, or nil if not found." - (while (and path - (not (funcall 'mh-file-command-p - (expand-file-name file (car path))))) - (setq path (cdr path))) - (car path)) - -(defvar mh-no-install nil) ;do not run install-mh - -(defun mh-install (profile error-val) - "Initialize the MH environment. -This is called if we fail to read the PROFILE file. ERROR-VAL is the error -that made this call necessary." - (if (or (getenv "MH") - (file-exists-p profile) - mh-no-install) - (signal (car error-val) - (list (format "Cannot read MH profile \"%s\"" profile) - (car (cdr (cdr error-val)))))) - ;; The "install-mh" command will output a short note which - ;; mh-exec-cmd will display to the user. - ;; The MH 5 version of install-mh might try prompt the user - ;; for information, which would fail here. - (mh-exec-cmd (expand-file-name "install-mh" mh-lib-progs) "-auto") - ;; now try again to read the profile file - (erase-buffer) - (condition-case err - (insert-file-contents profile) - (file-error - (signal (car err) ;re-signal with more specific msg - (list (format "Cannot read MH profile \"%s\"" profile) - (car (cdr (cdr err)))))))) - (defun mh-set-folder-modified-p (flag) "Mark current folder as modified or unmodified according to FLAG." (set-buffer-modified-p flag)) @@ -1521,9 +1968,9 @@ (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'." +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)) @@ -1533,8 +1980,8 @@ (substring fmt end)))) fmt)) -(defun mh-message-number-width (folder) - "Return the widest message number in this FOLDER." +(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)) @@ -1542,7 +1989,7 @@ (set-buffer tmp-buffer) (erase-buffer) (apply 'call-process - (expand-file-name "scan" mh-progs) nil '(t nil) nil + (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) @@ -1552,13 +1999,15 @@ (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. + +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))) +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 @@ -1566,10 +2015,12 @@ mh-seq-list)) (if msgs (setcdr entry (mh-canonicalize-sequence (append msgs (mh-seq-msgs entry)))))) - (cond ((not internal-flag) - (mh-add-to-sequence seq msgs) - (unless dont-annotate-flag - (mh-notate-seq seq mh-note-seq (1+ mh-cmd-note))))))) + (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." @@ -1582,28 +2033,89 @@ sorted-msgs)) (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) + +;; Initialize mh-sub-folders-cache... +(defun mh-collect-folder-names () + "Collect folder names by running \"folders\"." + (unless mh-flists-process + (setq mh-flists-process + (mh-exec-cmd-daemon "folders" 'mh-collect-folder-names-filter + "-recurse" "-fast")))) + +(defun mh-collect-folder-names-filter (process output) + "Read folder names. +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) + (unwind-protect + (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 "") + (unless (equal (aref folder 1) ?.) + (mh-populate-sub-folders-cache folder)) + (setq position (1+ line-end))) + (set-match-data prevailing-match-data)) + (setq mh-flists-partial-line (substring output position)))) + +(defun mh-populate-sub-folders-cache (folder) + "Tell `mh-sub-folders-cache' about FOLDER." + (let* ((last-slash (mh-search-from-end ?/ folder)) + (child1 (substring folder (1+ (or last-slash 0)))) + (parent (and last-slash (substring folder 0 last-slash))) + (parent-slash (and parent (mh-search-from-end ?/ parent))) + (child2 (and parent (substring parent (1+ (or parent-slash 0))))) + (grand-parent (and parent-slash (substring parent 0 parent-slash))) + (cache-entry (gethash parent mh-sub-folders-cache))) + (unless (loop for x in cache-entry when (equal (car x) child1) return t + finally return nil) + (push (list child1) cache-entry) + (setf (gethash parent mh-sub-folders-cache) + (sort cache-entry (lambda (x y) (string< (car x) (car y))))) + (when parent + (loop for x in (gethash grand-parent mh-sub-folders-cache) + when (equal (car x) child2) + do (progn (setf (cdr x) t) (return))))))) (defun mh-normalize-folder-name (folder &optional empty-string-okay dont-remove-trailing-slash) "Normalizes FOLDER name. -Makes sure that two '/' characters never occur next to each other. Also all -occurrences of \"..\" and \".\" are suitably processed. So \"+inbox/../news\" -will be normalized to \"+news\". + +Makes sure that two '/' characters never occur next to each +other. Also all occurrences of \"..\" and \".\" are suitably +processed. So \"+inbox/../news\" will be normalized to \"+news\". -If optional argument EMPTY-STRING-OKAY is nil then a '+' is added at the -front if FOLDER lacks one. If non-nil and FOLDER is the empty string then -nothing is added. +If optional argument EMPTY-STRING-OKAY is nil then a '+' is added +at the front if FOLDER lacks one. If non-nil and FOLDER is the +empty string then nothing is added. -If optional argument DONT-REMOVE-TRAILING-SLASH is non-nil then a trailing '/' -if present is retained (if present), otherwise it is removed." +If optional argument DONT-REMOVE-TRAILING-SLASH is non-nil then a +trailing '/' if present is retained (if present), otherwise it is +removed." (when (stringp folder) ;; Replace two or more consecutive '/' characters with a single '/' (while (string-match "//" folder) (setq folder (replace-match "/" nil t folder))) (let* ((length (length folder)) (trailing-slash-present (and (> length 0) - (equal (aref folder (1- length)) ?/)))) - (let ((components (split-string folder "/")) + (equal (aref folder (1- length)) ?/))) + (leading-slash-present (and (> length 0) + (equal (aref folder 0) ?/)))) + (when (and (> length 0) (equal (aref folder 0) ?@) + (stringp mh-current-folder-name)) + (setq folder (format "%s/%s/" mh-current-folder-name + (substring folder 1)))) + ;; XXX: Purge empty strings from the list that split-string returns. In + ;; XEmacs, (split-string "+foo/" "/") returns ("+foo" "") while in GNU + ;; Emacs it returns ("+foo"). In the code it is assumed that the + ;; components list has no empty strings. + (let ((components (delete "" (split-string folder "/"))) (result ())) ;; Remove .. and . from the pathname. (dolist (component components) @@ -1618,19 +2130,60 @@ ;; Remove trailing '/' if needed. (unless (and trailing-slash-present dont-remove-trailing-slash) (when (not (equal folder "")) - (setq folder (substring folder 0 (1- (length folder)))))))) + (setq folder (substring folder 0 (1- (length folder)))))) + (when leading-slash-present + (setq folder (concat "/" folder))))) (cond ((and empty-string-okay (equal folder ""))) ((equal folder "") (setq folder "+")) ((not (equal (aref folder 0) ?+)) (setq folder (concat "+" folder))))) folder) +(defmacro mh-children-p (folder) + "Return t if FOLDER from sub-folders cache has children. +The car of folder is the name, and the cdr is either t or some +sort of count that I do not understand. It's too small to be the +number of messages in the sub-folders and too large to be the +number of sub-folders. XXX" + `(if (cdr ,folder) + t + nil)) + +(defun mh-folder-list (folder) + "Return FOLDER and its descendents. +Returns a list of strings. For example, + + '(\"inbox\" \"lists\" \"lists/mh-e\"). + +If folder is nil, then all folders are considered. Respects the +value of `mh-recursive-folders-flag'. If this flag is nil, and +the sub-folders have not been explicitly viewed, then they will +not be returned." + (let ((folder-list)) + ;; Normalize folder. Strip leading +. Add trailing slash. If no + ;; folder is specified, ensure it is nil to ensure we get the + ;; top-level folders; otherwise mh-sub-folders returns all the + ;; files in / if given an empty string or +. + (when folder + (setq folder (replace-regexp-in-string "^\+" "" folder)) + (setq folder (replace-regexp-in-string "/*$" "/" folder)) + (if (equal folder "") + (setq folder nil))) + (loop for f in (mh-sub-folders folder) do + (setq folder-list (append folder-list (list (concat folder (car f))))) + (if (mh-children-p f) + (setq folder-list + (append folder-list + (mh-folder-list (concat folder (car f))))))) + folder-list)) + (defun mh-sub-folders (folder &optional add-trailing-slash-flag) "Find the subfolders of FOLDER. -The function avoids running folders unnecessarily by caching the results of -the actual folders call. +The function avoids running folders unnecessarily by caching the +results of the actual folders call. -If optional argument ADD-TRAILING-SLASH-FLAG is non-nil then a slash is added -to each of the sub-folder names that may have nested folders within them." +If optional argument ADD-TRAILING-SLASH-FLAG is non-nil then a +slash is added to each of the sub-folder names that may have +nested folders within them." (let* ((folder (mh-normalize-folder-name folder)) (match (gethash folder mh-sub-folders-cache 'no-result)) (sub-folders (cond ((eq match 'no-result) @@ -1645,8 +2198,8 @@ (defun mh-sub-folders-actual (folder) "Execute the command folders to return the sub-folders of FOLDER. -Filters out the folder names that start with \".\" so that directories that -aren't usually mail folders are hidden." +Filters out the folder names that start with \".\" so that +directories that aren't usually mail folders are hidden." (let ((arg-list `(,(expand-file-name "folders" mh-progs) nil (t nil) nil "-noheader" "-norecurse" "-nototal" ,@(if (stringp folder) (list folder) ()))) @@ -1662,12 +2215,15 @@ (goto-char (point-min)) (while (not (and (eolp) (bolp))) (goto-char (line-end-position)) - (let ((has-pos (search-backward " has " (line-beginning-position) t))) + (let ((start-pos (line-beginning-position)) + (has-pos (search-backward " has " (line-beginning-position) t))) (when (integerp has-pos) (while (equal (char-after has-pos) ? ) (decf has-pos)) (incf has-pos) - (let* ((name (buffer-substring (line-beginning-position) has-pos)) + (while (equal (char-after start-pos) ? ) + (incf start-pos)) + (let* ((name (buffer-substring start-pos has-pos)) (first-char (aref name 0)) (last-char (aref name (1- (length name))))) (unless (member first-char '(?. ?# ?,)) @@ -1690,13 +2246,15 @@ (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 last ancestor -of FOLDER present in the cache must be removed as well. +FOLDER should be unconditionally removed from the cache. Also the +last ancestor of FOLDER present in the cache must be removed as +well. -To see why this is needed assume we have a folder +foo which has a single -sub-folder qux. Now we create the folder +foo/bar/baz. Here we will need to -invalidate the cached sub-folders of +foo, otherwise completion on +foo won't -tell us about the option +foo/bar!" +To see why this is needed assume we have a folder +foo which has +a single sub-folder qux. Now we create the folder +foo/bar/baz. +Here we will need to invalidate the cached sub-folders of +foo, +otherwise completion on +foo won't tell us about the option ++foo/bar!" (remhash folder mh-sub-folders-cache) (block ancestor-found (let ((parent folder) @@ -1712,15 +2270,36 @@ (remhash nil mh-sub-folders-cache)))) (defvar mh-folder-hist nil) -(defvar mh-speed-folder-map) + +;; Shush compiler. +(eval-when-compile + (defvar mh-speed-folder-map) + (defvar mh-speed-flists-cache)) + +(defvar mh-allow-root-folder-flag nil + "Non-nil means \"+\" is an acceptable folder name. +This variable is used to communicate with +`mh-folder-completion-function'. That function can have exactly +three arguments so we bind this variable to t or nil. + +This variable should never be set.") + (defvar mh-folder-completion-map (copy-keymap minibuffer-local-completion-map)) -(define-key mh-folder-completion-map " " 'minibuffer-complete) +(define-key mh-folder-completion-map " " 'minibuffer-complete) ;Why??? + +(defvar mh-speed-flists-inhibit-flag nil) + +(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))) (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 non-nil is a -function that is used to filter the possible choices and FLAG determines -whether the completion is over." +NAME is the partial folder name that has been input. PREDICATE if +non-nil is a function that is used to filter the possible choices +and FLAG determines whether the completion is over." (let* ((orig-name name) (name (mh-normalize-folder-name name nil t)) (last-slash (mh-search-from-end ?/ name)) @@ -1747,14 +2326,21 @@ (all-completions remainder (mh-sub-folders last-complete t) predicate)) ((eq flag 'lambda) - (file-exists-p - (concat mh-user-path - (substring (mh-normalize-folder-name name) 1))))))) + (let ((path (concat mh-user-path + (substring (mh-normalize-folder-name name) 1)))) + (cond (mh-allow-root-folder-flag (file-exists-p path)) + ((equal path mh-user-path) nil) + (t (file-exists-p path)))))))) -(defun mh-folder-completing-read (prompt default) - "Read folder name with PROMPT and default result DEFAULT." +(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 +a folder name corresponding to `mh-user-path'." (mh-normalize-folder-name - (let ((minibuffer-local-completion-map mh-folder-completion-map)) + (let ((minibuffer-completing-file-name t) + (completion-root-regexp "^[+/]") + (minibuffer-local-completion-map mh-folder-completion-map) + (mh-allow-root-folder-flag allow-root-folder-flag)) (completing-read prompt 'mh-folder-completion-function nil nil nil 'mh-folder-hist default)) t)) @@ -1762,21 +2348,23 @@ (defun mh-prompt-for-folder (prompt default can-create &optional default-string allow-root-folder-flag) "Prompt for a folder name with PROMPT. -Returns the folder's name as a string. DEFAULT is used if the folder exists -and the user types return. If the CAN-CREATE flag is t, then a folder is -created if it doesn't already exist. If optional argument DEFAULT-STRING is -non-nil, use it in the prompt instead of DEFAULT. If ALLOW-ROOT-FOLDER-FLAG is -non-nil then the function will accept the folder +, which means all folders -when used in searching." +Returns the folder's name as a string. DEFAULT is used if the +folder exists and the user types return. If the CAN-CREATE flag +is t, then a folder is created if it doesn't already exist. If +optional argument DEFAULT-STRING is non-nil, use it in the prompt +instead of DEFAULT. If ALLOW-ROOT-FOLDER-FLAG is non-nil then the +function will accept the folder +, which means all folders when +used in searching." (if (null default) (setq default "")) - (let* ((default-string (cond (default-string (format " [%s]? " - default-string)) - ((equal "" default) "? ") - (t (format " [%s]? " default)))) - (prompt (format "%s folder%s" prompt default-string)) + (let* ((default-string (cond (default-string (format " (default %s)" default-string)) + ((equal "" default) "") + (t (format " (default %s)" default)))) + (prompt (format "%s folder%s: " prompt default-string)) + (mh-current-folder-name mh-current-folder) read-name folder-name) - (while (and (setq read-name (mh-folder-completing-read prompt default)) + (while (and (setq read-name (mh-folder-completing-read + prompt default allow-root-folder-flag)) (equal read-name "") (equal default ""))) (cond ((or (equal read-name "") @@ -1790,9 +2378,18 @@ (cond ((and (> (length folder-name) 0) (eq (aref folder-name (1- (length folder-name))) ?/)) (setq folder-name (substring folder-name 0 -1)))) + (let* ((last-slash (mh-search-from-end ?/ folder-name)) + (parent (and last-slash (substring folder-name 0 last-slash))) + (child (if last-slash + (substring folder-name (1+ last-slash)) + (substring folder-name 1)))) + (unless (member child + (mapcar #'car (gethash parent mh-sub-folders-cache))) + (mh-remove-from-sub-folders-cache folder-name))) (let ((new-file-flag (not (file-exists-p (mh-expand-file-name folder-name))))) (cond ((and new-file-flag + can-create (y-or-n-p (format "Folder %s does not exist. Create it? " folder-name))) @@ -1803,160 +2400,15 @@ (mh-speed-add-folder folder-name)) (message "Creating %s...done" folder-name)) (new-file-flag - (error "Folder %s is not created" folder-name)) + (error "Folder %s does not exist" folder-name)) ((not (file-directory-p (mh-expand-file-name folder-name))) - (error "\"%s\" is not a directory" + (error "%s is not a directory" (mh-expand-file-name folder-name))))) folder-name)) -;;; Issue commands to MH. - -(defun mh-exec-cmd (command &rest args) - "Execute mh-command COMMAND with ARGS. -The side effects are what is desired. -Any output is assumed to be an error and is shown to the user. -The output is not read or parsed by MH-E." - (save-excursion - (set-buffer (get-buffer-create mh-log-buffer)) - (erase-buffer) - (apply 'call-process - (expand-file-name command mh-progs) nil t nil - (mh-list-to-string args)) - (if (> (buffer-size) 0) - (save-window-excursion - (switch-to-buffer-other-window mh-log-buffer) - (sit-for 5))))) - -(defun mh-exec-cmd-error (env command &rest args) - "In environment ENV, execute mh-command COMMAND with ARGS. -ENV is nil or a string of space-separated \"var=value\" elements. -Signals an error if process does not complete successfully." - (save-excursion - (set-buffer (get-buffer-create mh-temp-buffer)) - (erase-buffer) - (let ((status - (if env - ;; the shell hacks necessary here shows just how broken Unix is - (apply 'call-process "/bin/sh" nil t nil "-c" - (format "%s %s ${1+\"$@\"}" - env - (expand-file-name command mh-progs)) - command - (mh-list-to-string args)) - (apply 'call-process - (expand-file-name command mh-progs) nil t nil - (mh-list-to-string args))))) - (mh-handle-process-error command status)))) - -(defun mh-exec-cmd-daemon (command filter &rest args) - "Execute MH command COMMAND in the background. - -If FILTER is non-nil then it is used to process the output otherwise the -default filter `mh-process-daemon' is used. See `set-process-filter' for more -details of FILTER. - -ARGS are passed to COMMAND as command line arguments." - (save-excursion - (set-buffer (get-buffer-create mh-log-buffer)) - (erase-buffer)) - (let* ((process-connection-type nil) - (process (apply 'start-process - command nil - (expand-file-name command mh-progs) - (mh-list-to-string args)))) - (set-process-filter process (or filter 'mh-process-daemon)))) - -(defun mh-process-daemon (process output) - "PROCESS daemon that puts OUTPUT into a temporary buffer. -Any output from the process is displayed in an asynchronous pop-up window." - (set-buffer (get-buffer-create mh-log-buffer)) - (insert-before-markers output) - (display-buffer mh-log-buffer)) + -(defun mh-exec-cmd-quiet (raise-error command &rest args) - "Signal RAISE-ERROR if COMMAND with ARGS fails. -Execute MH command COMMAND with ARGS. ARGS is a list of strings. -Return at start of mh-temp buffer, where output can be parsed and used. -Returns value of `call-process', which is 0 for success, unless RAISE-ERROR is -non-nil, in which case an error is signaled if `call-process' returns non-0." - (set-buffer (get-buffer-create mh-temp-buffer)) - (erase-buffer) - (let ((value - (apply 'call-process - (expand-file-name command mh-progs) nil t nil - args))) - (goto-char (point-min)) - (if raise-error - (mh-handle-process-error command value) - value))) - -(defun mh-profile-component (component) - "Return COMPONENT value from mhparam, or nil if unset." - (save-excursion - (mh-exec-cmd-quiet nil "mhparam" "-components" component) - (mh-get-profile-field (concat component ":")))) - -(defun mh-exchange-point-and-mark-preserving-active-mark () - "Put the mark where point is now, and point where the mark is now. -This command works even when the mark is not active, and preserves whether the -mark is active or not." - (interactive nil) - (let ((is-active (and (boundp 'mark-active) mark-active))) - (let ((omark (mark t))) - (if (null omark) - (error "No mark set in this buffer")) - (set-mark (point)) - (goto-char omark) - (if (boundp 'mark-active) - (setq mark-active is-active)) - nil))) - -(defun mh-exec-cmd-output (command display &rest args) - "Execute MH command COMMAND with DISPLAY flag and ARGS. -Put the output into buffer after point. Set mark after inserted text. -Output is expected to be shown to user, not parsed by MH-E." - (push-mark (point) t) - (apply 'call-process - (expand-file-name command mh-progs) nil t display - (mh-list-to-string args)) - - ;; The following is used instead of 'exchange-point-and-mark because the - ;; latter activates the current region (between point and mark), which - ;; turns on highlighting. So prior to this bug fix, doing "inc" would - ;; highlight a region containing the new messages, which is undesirable. - ;; The bug wasn't seen in emacs21 but still occurred in XEmacs21.4. - (mh-exchange-point-and-mark-preserving-active-mark)) - -(defun mh-exec-lib-cmd-output (command &rest args) - "Execute MH library command COMMAND with ARGS. -Put the output into buffer after point. Set mark after inserted text." - (apply 'mh-exec-cmd-output (expand-file-name command mh-lib-progs) nil args)) - -(defun mh-handle-process-error (command status) - "Raise error if COMMAND returned non-zero STATUS, otherwise return STATUS. -STATUS is return value from `call-process'. -Program output is in current buffer. -If output is too long to include in error message, display the buffer." - (cond ((eq status 0) ;success - status) - ((stringp status) ;kill string - (error "%s: %s" command status)) - (t ;exit code - (cond - ((= (buffer-size) 0) ;program produced no error message - (error "%s: exit code %d" command status)) - (t - ;; will error message fit on one line? - (goto-line 2) - (if (and (< (buffer-size) (frame-width)) - (eobp)) - (error "%s" - (buffer-substring 1 (progn (goto-char 1) - (end-of-line) - (point)))) - (display-buffer (current-buffer)) - (error "%s failed with status %d. See error message in other window" - command status))))))) +;;; 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." @@ -1976,15 +2428,24 @@ ((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)))) + (t (error "Bad element in `mh-list-to-string': %s" (car l)))) (setq l (cdr l))) new-list)) +(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)))) + (provide 'mh-utils) -;;; Local Variables: -;;; indent-tabs-mode: nil -;;; sentence-end-double-space: nil -;;; End: +;; Local Variables: +;; indent-tabs-mode: nil +;; sentence-end-double-space: nil +;; End: +;; arch-tag: 1af39fdf-f66f-4b06-9b48-18a7656c8e36 ;;; mh-utils.el ends here