Mercurial > emacs
changeset 49459:06b77df47802
* mh-e: Created directory. ChangeLog will appear in a week when we
release version 7.2.
* lisp/mail/mh-alias.el, lisp/mail/mh-comp.el,
lisp/mail/mh-customize.el, lisp/mail/mh-e.el, lisp/mail/mh-funcs.el,
lisp/mail/mh-identity.el, lisp/mail/mh-index.el,
lisp/mail/mh-loaddefs.el, lisp/mail/mh-mime.el, lisp/mail/mh-pick.el,
lisp/mail/mh-seq.el, lisp/mail/mh-speed.el, lisp/mail/mh-utils.el,
lisp/mail/mh-xemacs-compat.el: Moved to mh-e. Note that reply2.pbm and
reply2.xpm, which were created by the MH-E package, were left in mail
since they can probably be used by other mail packages.
* makefile.w32-in (WINS): Added mh-e.
* makefile.nt (WINS): Added mh-e.
| author | Bill Wohler <wohler@newt.com> |
|---|---|
| date | Sun, 26 Jan 2003 02:38:37 +0000 |
| parents | 5ddabc4c81b0 |
| children | 9f4069f735c6 |
| files | lisp/ChangeLog lisp/mail/mh-alias.el lisp/mail/mh-comp.el lisp/mail/mh-customize.el lisp/mail/mh-e.el lisp/mail/mh-funcs.el lisp/mail/mh-identity.el lisp/mail/mh-index.el lisp/mail/mh-loaddefs.el lisp/mail/mh-mime.el lisp/mail/mh-pick.el lisp/mail/mh-seq.el lisp/mail/mh-speed.el lisp/mail/mh-utils.el lisp/mail/mh-xemacs-compat.el lisp/makefile.nt lisp/makefile.w32-in lisp/mh-e/mh-alias.el lisp/mh-e/mh-comp.el lisp/mh-e/mh-customize.el lisp/mh-e/mh-e.el lisp/mh-e/mh-funcs.el lisp/mh-e/mh-identity.el lisp/mh-e/mh-index.el lisp/mh-e/mh-loaddefs.el lisp/mh-e/mh-mime.el lisp/mh-e/mh-pick.el lisp/mh-e/mh-seq.el lisp/mh-e/mh-speed.el lisp/mh-e/mh-utils.el lisp/mh-e/mh-xemacs-compat.el |
| diffstat | 31 files changed, 13934 insertions(+), 13913 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/ChangeLog Sun Jan 26 01:33:33 2003 +0000 +++ b/lisp/ChangeLog Sun Jan 26 02:38:37 2003 +0000 @@ -1,3 +1,22 @@ +2003-01-25 Bill Wohler <wohler@newt.com> + + * mh-e: Created directory. ChangeLog will appear in a week when we + release version 7.2. + + * lisp/mail/mh-alias.el, lisp/mail/mh-comp.el, + lisp/mail/mh-customize.el, lisp/mail/mh-e.el, + lisp/mail/mh-funcs.el, lisp/mail/mh-identity.el, + lisp/mail/mh-index.el, lisp/mail/mh-loaddefs.el, + lisp/mail/mh-mime.el, lisp/mail/mh-pick.el, lisp/mail/mh-seq.el, + lisp/mail/mh-speed.el, lisp/mail/mh-utils.el, + lisp/mail/mh-xemacs-compat.el: Moved to mh-e. Note that reply2.pbm + and reply2.xpm, which were created by the MH-E package, were left + in mail since they can probably be used by other mail packages. + + * makefile.w32-in (WINS): Added mh-e. + + * makefile.nt (WINS): Added mh-e. + 2003-01-25 Richard M. Stallman <rms@gnu.org> * emacs-lisp/bytecomp.el (byte-compile-file-form-custom-declare-variable):
--- a/lisp/mail/mh-alias.el Sun Jan 26 01:33:33 2003 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,590 +0,0 @@ -;;; mh-alias.el --- MH-E mail alias completion and expansion -;; -;; Copyright (C) 1994, 1995, 1996, 1997, 2001, 2002 Free Software Foundation, Inc. - -;; Author: Peter S. Galbraith <psg@debian.org> -;; Maintainer: Bill Wohler <wohler@newt.com> -;; Keywords: mail -;; See: mh-e.el - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; [To be deleted when documented in MH-E manual.] -;; -;; This module provides mail alias completion when entering addresses. -;; -;; Use the TAB key to complete aliases (and optionally local usernames) when -;; initially composing a message in the To: and Cc: minibuffer prompts. You -;; may enter multiple addressees separated with a comma (but do *not* add any -;; space after the comma). -;; -;; In the header of a message draft, use "M-TAB (mh-letter-complete)" to -;; complete aliases. This is useful when you want to add an addressee as an -;; afterthought when creating a message, or when adding an additional -;; addressee to a reply. -;; -;; By default, completion is case-insensitive. This can be changed by -;; customizing the variable `mh-alias-completion-ignore-case-flag'. This is -;; useful, for example, to differentiate between people aliases in lowercase -;; such as: -;; -;; p.galbraith: Peter Galbraith <GalbraithP@dfo-mpo.gc.ca> -;; -;; and lists in uppercase such as: -;; -;; MH-E: MH-E mailing list <mh-e-devel@lists.sourceforge.net> -;; -;; Note that this variable affects minibuffer completion only. If you have an -;; alias for P.Galbraith and type in p.galbraith at the prompt, it will still -;; be expanded in the letter buffer because MH is case-insensitive. -;; -;; When you press ", (mh-alias-minibuffer-confirm-address)" after an alias in -;; the minibuffer, the expansion for the previous mail alias appears briefly. -;; To inhibit this, customize the variable `mh-alias-flash-on-comma'. -;; -;; The addresses and aliases entered in the minibuffer are added to the -;; message draft. To expand the aliases before they are added to the draft, -;; customize the variable `mh-alias-expand-aliases-flag'. -;; -;; Completion is also performed on usernames extracted from the /etc/passwd -;; file. This can be a handy tool on a machine where you and co-workers -;; exchange messages, but should probably be disabled on a system with -;; thousands of users you don't know. This is done by customizing the -;; variable `mh-alias-local-users'. This variable also takes a string which -;; is executed to generate the password file. For example, you'd use "ypcat -;; passwd" for NIS. -;; -;; Aliases are loaded the first time you send mail and get the "To:" prompt -;; and whenever a source of aliases changes. Sources of system aliases are -;; defined in the customization variable `mh-alias-system-aliases' and -;; include: -;; -;; /etc/nmh/MailAliases -;; /usr/lib/mh/MailAliases -;; /etc/passwd -;; -;; Sources of personal aliases are read from the files listed in your MH -;; profile component Aliasfile. Multiple files are separated by white space -;; and are relative to your mail directory. -;; -;; Alias Insertions -;; ~~~~~~~~~~~~~~~~ -;; There are commands to insert new aliases into your alias file(s) (defined -;; by the `Aliasfile' component in the .mh_profile file or by the variable -;; `mh-alias-insert-file'). In particular, there is a tool-bar icon to grab -;; an alias from the From line of the current message. - -;;; Code: - -(require 'mh-e) -(load "cmr" t t) ; Non-fatal dependency for - ; completing-read-multiple. -(eval-when-compile (defvar mail-abbrev-syntax-table)) - -;;; Autoloads -(autoload 'mail-abbrev-complete-alias "mailabbrev") -(autoload 'multi-prompt "multi-prompt") - -(defvar mh-alias-alist nil - "Alist of MH aliases.") -(defvar mh-alias-blind-alist nil - "Alist of MH aliases that are blind lists.") -(defvar mh-alias-passwd-alist nil - "Alist of aliases extracted from passwd file and their expansions.") -(defvar mh-alias-tstamp nil - "Time aliases were last loaded.") -(defvar mh-alias-read-address-map nil) -(if mh-alias-read-address-map - () - (setq mh-alias-read-address-map - (copy-keymap minibuffer-local-completion-map)) - (if mh-alias-flash-on-comma - (define-key mh-alias-read-address-map - "," 'mh-alias-minibuffer-confirm-address)) - (define-key mh-alias-read-address-map " " 'self-insert-command)) - - -;;; Alias Loading - -(defun mh-alias-tstamp (arg) - "Check whether alias files have been modified. -Return t if any file listed in the MH profile component Aliasfile has been -modified since the timestamp. -If ARG is non-nil, set timestamp with the current time." - (if arg - (let ((time (current-time))) - (setq mh-alias-tstamp (list (nth 0 time) (nth 1 time)))) - (let ((stamp)) - (car (memq t (mapcar - (function - (lambda (file) - (when (and file (file-exists-p file)) - (setq stamp (nth 5 (file-attributes file))) - (or (> (car stamp) (car mh-alias-tstamp)) - (and (= (car stamp) (car mh-alias-tstamp)) - (> (cadr stamp) (cadr mh-alias-tstamp))))))) - (mh-alias-filenames t))))))) - -(defun mh-alias-filenames (arg) - "Return list of filenames that contain aliases. -The filenames come from the MH profile component Aliasfile and are expanded. -If ARG is non-nil, filenames listed in `mh-alias-system-aliases' are appended." - (or mh-progs (mh-find-path)) - (save-excursion - (let* ((filename (mh-profile-component "Aliasfile")) - (filelist (and filename (split-string filename "[ \t]+"))) - (userlist - (mapcar - (function - (lambda (file) - (if (and mh-user-path file - (file-exists-p (expand-file-name file mh-user-path))) - (expand-file-name file mh-user-path)))) - filelist))) - (if arg - (if (stringp mh-alias-system-aliases) - (append userlist (list mh-alias-system-aliases)) - (append userlist mh-alias-system-aliases)) - userlist)))) - -(defun mh-alias-local-users () - "Return an alist of local users from /etc/passwd." - (let (passwd-alist) - (save-excursion - (set-buffer (get-buffer-create mh-temp-buffer)) - (erase-buffer) - (cond - ((eq mh-alias-local-users t) - (if (file-readable-p "/etc/passwd") - (insert-file-contents "/etc/passwd"))) - ((stringp mh-alias-local-users) - (insert mh-alias-local-users "\n") - (shell-command-on-region (point-min)(point-max) mh-alias-local-users t) - (goto-char (point-min)))) - (while (< (point) (point-max)) - (cond - ((looking-at "\\([^:]*\\):[^:]*:\\([^:]*\\):[^:]*:\\([^:,]*\\)[:,]") - (when (> (string-to-int (match-string 2)) 200) - (let* ((username (match-string 1)) - (gecos-name (match-string 3)) - (realname - (if (string-match "&" gecos-name) - (concat - (substring gecos-name 0 (match-beginning 0)) - (capitalize username) - (substring gecos-name (match-end 0))) - gecos-name))) - (setq passwd-alist - (cons (list username - (if (string-equal "" realname) - (concat "<" username ">") - (concat realname " <" username ">"))) - passwd-alist)))))) - (forward-line 1))) - passwd-alist)) - -;;;###mh-autoload -(defun mh-alias-reload () - "Load MH aliases into `mh-alias-alist'." - (interactive) - (save-excursion - (message "Loading MH aliases...") - (mh-alias-tstamp t) - (mh-exec-cmd-quiet t "ali" "-nolist" "-nouser") - (setq mh-alias-alist nil) - (setq mh-alias-blind-alist nil) - (while (< (point) (point-max)) - (cond - ((looking-at "^[ \t]")) ;Continuation line - ((looking-at "\\(.+\\): .+: .*$") ; A new -blind- MH alias - (when (not (assoc-ignore-case (match-string 1) mh-alias-blind-alist)) - (setq mh-alias-blind-alist - (cons (list (match-string 1)) mh-alias-blind-alist)) - (setq mh-alias-alist (cons (list (match-string 1)) mh-alias-alist)))) - ((looking-at "\\(.+\\): .*$") ; A new MH alias - (when (not (assoc-ignore-case (match-string 1) mh-alias-alist)) - (setq mh-alias-alist - (cons (list (match-string 1)) mh-alias-alist))))) - (forward-line 1))) - (when mh-alias-local-users - (setq mh-alias-passwd-alist (mh-alias-local-users)) - ;; Update aliases with local users, but leave existing aliases alone. - (let ((local-users mh-alias-passwd-alist) - user) - (while local-users - (setq user (car local-users)) - (if (not (assoc-ignore-case (car user) mh-alias-alist)) - (setq mh-alias-alist (append mh-alias-alist (list user)))) - (setq local-users (cdr local-users))))) - (message "Loading MH aliases...done")) - -(defun mh-alias-reload-maybe () - "Load new MH aliases." - (if (or (not mh-alias-alist) ; Doesn't exist, so create it. - (mh-alias-tstamp nil)) ; Out of date, so recreate it. - (mh-alias-reload))) - - -;;; Alias Expansion - -(defun mh-alias-ali (alias &optional user) - "Return ali expansion for ALIAS. -ALIAS must be a string for a single alias. -If USER is t, then assume ALIAS is an address and call ali -user. -ali returns the string unchanged if not defined. The same is done here." - (save-excursion - (let ((user-arg (if user "-user" "-nouser"))) - (mh-exec-cmd-quiet t "ali" user-arg "-nolist" alias)) - (goto-char (point-max)) - (if (looking-at "^$") (delete-backward-char 1)) - (buffer-substring (point-min)(point-max)))) - -(defun mh-alias-expand (alias) - "Return expansion for ALIAS. -Blind aliases or users from /etc/passwd are not expanded." - (cond - ((assoc-ignore-case alias mh-alias-blind-alist) - alias) ; Don't expand a blind alias - ((assoc-ignore-case alias mh-alias-passwd-alist) - (cadr (assoc-ignore-case alias mh-alias-passwd-alist))) - (t - (mh-alias-ali alias)))) - -;;;###mh-autoload -(defun mh-read-address (prompt) - "Read an address from the minibuffer with PROMPT." - (mh-alias-reload-maybe) - (if (not mh-alias-alist) ; If still no aliases, just prompt - (read-string prompt) - (let* ((minibuffer-local-completion-map mh-alias-read-address-map) - (completion-ignore-case mh-alias-completion-ignore-case-flag) - (the-answer - (or (cond - ((fboundp 'completing-read-multiple) - (completing-read-multiple prompt mh-alias-alist nil nil)) - ((featurep 'multi-prompt) - (multi-prompt "," nil prompt mh-alias-alist nil nil)) - (t - (split-string - (completing-read "To: " mh-alias-alist nil nil) - ",")))))) - (if (not mh-alias-expand-aliases-flag) - (mapconcat 'identity the-answer ", ") - ;; Loop over all elements, checking if in passwd aliast or blind first - (mapconcat 'mh-alias-expand the-answer ",\n "))))) - -;;;###mh-autoload -(defun mh-alias-minibuffer-confirm-address () - "Display the alias expansion if `mh-alias-flash-on-comma' is non-nil." - (interactive) - (if (not mh-alias-flash-on-comma) - () - (save-excursion - (let* ((case-fold-search t) - (the-name (buffer-substring - (progn (skip-chars-backward " \t")(point)) - ;; This moves over to previous comma, if any - (progn (or (and (not (= 0 (skip-chars-backward "^,"))) - ;; the skips over leading whitespace - (skip-chars-forward " ")) - ;; no comma, then to beginning of word - (skip-chars-backward "^ \t")) - ;; In Emacs21, the beginning of the prompt - ;; line is accessible, which wasn't the case - ;; in emacs20. Skip over it. - (if (looking-at "^[^ \t]+:") - (skip-chars-forward "^ \t")) - (skip-chars-forward " ") - (point))))) - (if (assoc-ignore-case the-name mh-alias-alist) - (message "%s -> %s" the-name (mh-alias-expand the-name)) - ;; Check if if was a single word likely to be an alias - (if (and (equal mh-alias-flash-on-comma 1) - (not (string-match " " the-name))) - (message "No alias for %s" the-name)))))) - (self-insert-command 1)) - -;;;###mh-autoload -(defun mh-alias-letter-expand-alias () - "Expand mail alias before point." - (mh-alias-reload-maybe) - (let ((mail-abbrevs mh-alias-alist)) - (mail-abbrev-complete-alias)) - (when mh-alias-expand-aliases-flag - (let* ((end (point)) - (syntax-table (syntax-table)) - (beg (unwind-protect - (save-excursion - (set-syntax-table mail-abbrev-syntax-table) - (backward-word 1) - (point)) - (set-syntax-table syntax-table))) - (alias (buffer-substring beg end)) - (expansion (mh-alias-expand alias))) - (delete-region beg end) - (insert expansion)))) - -;;; Adding addresses to alias file. - -(defun mh-alias-suggest-alias (string) - "Suggest an alias for STRING." - (cond - ((string-match "^\\sw+$" string) - ;; One word -> downcase it. - (downcase string)) - ((string-match "^\\(\\sw+\\)\\s-+\\(\\sw+\\)$" string) - ;; Two words -> first.last - (downcase - (format "%s.%s" (match-string 1 string) (match-string 2 string)))) - ((string-match "^\\([-a-zA-Z0-9._]+\\)@[-a-zA-z0-9_]+\\.+[a-zA-Z0-9]+$" - string) - ;; email only -> downcase username - (downcase (match-string 1 string))) - ((string-match "^\"\\(.*\\)\".*" string) - ;; "Some name" <somename@foo.bar> -> recurse -> "Some name" - (mh-alias-suggest-alias (match-string 1 string))) - ((string-match "^\\(.*\\) +<.*>$" string) - ;; Some name <somename@foo.bar> -> recurse -> Some name - (mh-alias-suggest-alias (match-string 1 string))) - ((string-match (concat mh-address-mail-regexp " +(\\(.*\\))$") string) - ;; somename@foo.bar (Some name) -> recurse -> Some name - (mh-alias-suggest-alias (match-string 1 string))) - ((string-match "^\\(Dr\\|Prof\\)\\.? +\\(.*\\)" string) - ;; Strip out title - (mh-alias-suggest-alias (match-string 2 string))) - ((string-match "^\\(.*\\), +\\(Jr\\.?\\|II+\\)$" string) - ;; Strip out tails with comma - (mh-alias-suggest-alias (match-string 1 string))) - ((string-match "^\\(.*\\) +\\(Jr\\.?\\|II+\\)$" string) - ;; Strip out tails - (mh-alias-suggest-alias (match-string 1 string))) - ((string-match "^\\(\\sw+\\) +[A-Z]\\.? +\\(.*\\)$" string) - ;; Strip out initials - (mh-alias-suggest-alias - (format "%s %s" (match-string 1 string) (match-string 2 string)))) - ((string-match "^\\([^,]+\\), +\\(.*\\)$" string) - ;; Reverse order of comma-separated fields - (mh-alias-suggest-alias - (format "%s %s" (match-string 2 string) (match-string 1 string)))) - (t - ;; Output string, with spaces replaced by dots. - (downcase (replace-regexp-in-string - "\\.\\.+" "." - (replace-regexp-in-string " +" "." string)))))) - -(defun mh-alias-which-file-has-alias (alias file-list) - "Return the name of writable file which defines ALIAS from list FILE-LIST." - (save-excursion - (set-buffer (get-buffer-create mh-temp-buffer)) - (let ((the-list file-list) - (found)) - (while the-list - (erase-buffer) - (when (file-writable-p (car file-list)) - (insert-file-contents (car file-list)) - (if (re-search-forward (concat "^" (regexp-quote alias) ":")) - (setq found (car file-list) - the-list nil) - (setq the-list (cdr the-list))))) - found))) - -(defun mh-alias-insert-file (&optional alias) - "Return the alias file to write a new entry for ALIAS in. -Use variable `mh-alias-insert-file' if non-nil, else use AliasFile component -value. -If ALIAS is specified and it already exists, try to return the file that -contains it." - (cond - ((and mh-alias-insert-file (listp mh-alias-insert-file)) - (if (not (elt mh-alias-insert-file 1)) ; Only one entry, use it - (car mh-alias-insert-file) - (if (or (not alias) - (string-equal alias (mh-alias-ali alias))) ;alias doesn't exist - (completing-read "Alias file [press Tab]: " - (mapcar 'list mh-alias-insert-file) nil t) - (or (mh-alias-which-file-has-alias alias mh-alias-insert-file) - (completing-read "Alias file [press Tab]: " - (mapcar 'list mh-alias-insert-file) nil t))))) - ((and mh-alias-insert-file (stringp mh-alias-insert-file)) - mh-alias-insert-file) - (t - ;; writable ones returned from (mh-alias-filenames): - (let ((autolist (delq nil (mapcar (lambda (file) - (if (and (file-writable-p file) - (not (string-equal - file "/etc/passwd"))) - file)) - (mh-alias-filenames t))))) - (cond - ((not autolist) - (error "No writable alias file. -Set `mh-alias-insert-file' or set AliasFile in your .mh_profile file")) - ((not (elt autolist 1)) ; Only one entry, use it - (car autolist)) - ((or (not alias) - (string-equal alias (mh-alias-ali alias))) ;alias doesn't exist - (completing-read "Alias file [press Tab]: " - (mapcar 'list autolist) nil t)) - (t - (or (mh-alias-which-file-has-alias alias autolist) - (completing-read "Alias file [press Tab]: " - (mapcar 'list autolist) nil t)))))))) - -(defun mh-alias-address-to-alias (address) - "Return the ADDRESS alias if defined, or nil." - (let* ((aliases (mh-alias-ali address t))) - (if (string-equal aliases address) - nil ; ali returned same string -> no. - ;; For the comma-separated aliases reyurned by ali, check that one of - ;; them doesn't expand into a list. e.g. we do have an individual - ;; alias for that adress. - (car (delq nil (mapcar - (function - (lambda (alias) - (let ((recurse (mh-alias-ali alias nil))) - (if (string-match ".*,.*" recurse) - nil - alias)))) - (split-string aliases ", +"))))))) - -;;;###mh-autoload -(defun mh-alias-from-has-no-alias-p () - "Return t is From has no current alias set." - (mh-alias-reload-maybe) - (save-excursion - (if (not (mh-folder-line-matches-show-buffer-p)) - nil ;No corresponding show buffer - (if (eq major-mode 'mh-folder-mode) - (set-buffer mh-show-buffer)) - (not (mh-alias-address-to-alias (mh-extract-from-header-value)))))) - -(defun mh-alias-add-alias-to-file (alias address &optional file) - "Add ALIAS for ADDRESS in alias FILE without alias check or prompts. -Prompt for alias file if not provided and there is more than one candidate. -If ALIAS matches exactly, prompt to [i]nsert before old value or [a]ppend -after it." - (if (not file) - (setq file (mh-alias-insert-file alias))) - (save-excursion - (set-buffer (find-file-noselect file)) - (goto-char (point-min)) - (let ((alias-search (concat alias ":")) - (letter) - (here (point)) - (case-fold-search t)) - (cond - ;; Search for exact match (if we had the same alias before) - ((re-search-forward - (concat "^" (regexp-quote alias-search) " *\\(.*\\)") nil t) - (let ((answer (read-string - (format "Exists for %s; [i]nsert, [a]ppend: " - (match-string 1)))) - (case-fold-search t)) - (cond ((string-match "^i" answer)) - ((string-match "^a" answer) - (forward-line 1)) - (t - error "Quitting.")))) - ;; No, so sort-in at the right place - ;; search for "^alias", then "^alia", etc. - ((eq mh-alias-insertion-location 'sorted) - (setq letter (substring alias-search -1) - alias-search (substring alias-search 0 -1)) - (while (and (not (equal alias-search "")) - (not (re-search-forward - (concat "^" (regexp-quote alias-search)) nil t))) - (setq letter (substring alias-search -1) - alias-search (substring alias-search 0 -1))) - ;; Next, move forward to sort alphabetically for following letters - (beginning-of-line) - (while (re-search-forward - (concat "^" (regexp-quote alias-search) "[a-" letter "]") - nil t) - (forward-line 1))) - ((eq mh-alias-insertion-location 'bottom) - (goto-char (point-max))) - ((eq mh-alias-insertion-location 'top) - (goto-char (point-min))))) - (beginning-of-line) - (insert (format "%s: %s\n" alias address)) - (save-buffer))) - -;;;###mh-autoload -(defun mh-alias-add-alias (alias address) - "*Add ALIAS for ADDRESS in personal alias file. -Prompts for confirmation if the address already has an alias. -If the alias is already is use, `mh-alias-add-alias-to-file' will prompt." - (interactive "P\nP") - (mh-alias-reload-maybe) - (setq alias (completing-read "Alias: " mh-alias-alist nil nil alias)) - (setq address (read-string "Address: " address)) - (let ((address-alias (mh-alias-address-to-alias address)) - (alias-address (mh-alias-expand alias))) - (if (string-equal alias-address alias) - (setq alias-address nil)) - (cond - ((and (equal alias address-alias) - (equal address alias-address)) - (message "Already defined as: %s" alias-address)) - (address-alias - (if (y-or-n-p (format "Address has alias %s; set new one? " - address-alias)) - (mh-alias-add-alias-to-file alias address))) - (t - (mh-alias-add-alias-to-file alias address))))) - -;;;###mh-autoload -(defun mh-alias-grab-from-field () - "*Add ALIAS for ADDRESS in personal alias file. -Prompts for confirmation if the alias is already in use or if the address -already has an alias." - (interactive) - (mh-alias-reload-maybe) - (save-excursion - (cond - ((mh-folder-line-matches-show-buffer-p) - (set-buffer mh-show-buffer)) - ((and (eq major-mode 'mh-folder-mode) - (mh-get-msg-num nil)) - (set-buffer (get-buffer-create mh-temp-buffer)) - (insert-file-contents (mh-msg-filename (mh-get-msg-num t)))) - ((eq major-mode 'mh-folder-mode) - (error "Cursor not pointing to a message"))) - (let* ((address (mh-extract-from-header-value)) - (alias (mh-alias-suggest-alias address))) - (mh-alias-add-alias alias address)))) - -;;;###mh-autoload -(defun mh-alias-add-address-under-point () - "Insert an alias for email address under point." - (interactive) - (let ((address (mh-goto-address-find-address-at-point))) - (if address - (mh-alias-add-alias nil address) - (message "No email address found under point.")))) - -(provide 'mh-alias) - -;;; Local Variables: -;;; indent-tabs-mode: nil -;;; sentence-end-double-space: nil -;;; End: - -;;; mh-alias.el ends here
--- a/lisp/mail/mh-comp.el Sun Jan 26 01:33:33 2003 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1525 +0,0 @@ -;;; mh-comp.el --- MH-E functions for composing messages - -;; Copyright (C) 1993,1995,1997,2000,2001,2002 Free Software Foundation, Inc. - -;; Author: Bill Wohler <wohler@newt.com> -;; Maintainer: Bill Wohler <wohler@newt.com> -;; Keywords: mail -;; See: mh-e.el - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Internal support for MH-E package. - -;;; Change Log: - -;; $Id: mh-comp.el,v 1.164 2003/01/07 21:16:25 satyaki Exp $ - -;;; Code: - -(require 'mh-e) -(require 'gnus-util) -(require 'easymenu) -(require 'cl) - -;; Shush the byte-compiler -(defvar adaptive-fill-first-line-regexp) -(defvar font-lock-defaults) -(defvar mark-active) -(defvar sendmail-coding-system) -(defvar mh-identity-list) -(defvar mh-identity-default) -(defvar mh-identity-menu) - -;;; Autoloads -(autoload 'Info-goto-node "info") -(autoload 'mail-mode-fill-paragraph "sendmail") -(autoload 'mm-handle-displayed-p "mm-decode") - -(autoload 'sc-cite-original "sc" - "Workhorse citing function which performs the initial citation. -This is callable from the various mail and news readers' reply -function according to the agreed upon standard. See `\\[sc-describe]' -for more details. `sc-cite-original' does not do any yanking of the -original message but it does require a few things: - - 1) The reply buffer is the current buffer. - - 2) The original message has been yanked and inserted into the - reply buffer. - - 3) Verbose mail headers from the original message have been - inserted into the reply buffer directly before the text of the - original message. - - 4) Point is at the beginning of the verbose headers. - - 5) Mark is at the end of the body of text to be cited. - -For Emacs 19's, the region need not be active (and typically isn't -when this function is called. Also, the hook `sc-pre-hook' is run -before, and `sc-post-hook' is run after the guts of this function.") - -;;; Site customization (see also mh-utils.el): - -(defvar mh-send-prog "send" - "Name of the MH send program. -Some sites need to change this because of a name conflict.") - -(defvar mh-redist-full-contents nil - "Non-nil if the `dist' command needs whole letter for redistribution. -This is the case only when `send' is compiled with the BERK option. -If MH will not allow you to redist a previously redist'd msg, set to nil.") - -(defvar mh-redist-background nil - "If non-nil redist will be done in background like send. -This allows transaction log to be visible if -watch, -verbose or -snoop are -used.") - -(defvar mh-note-repl "-" - "String whose first character is used to notate replied to messages.") - -(defvar mh-note-forw "F" - "String whose first character is used to notate forwarded messages.") - -(defvar mh-note-dist "R" - "String whose first character is used to notate redistributed messages.") - -(defvar mh-yank-hooks nil - "Obsolete hook for modifying a citation just inserted in the mail buffer. -Each hook function can find the citation between point and mark. -And each hook function should leave point and mark around the citation -text as modified. - -This is a normal hook, misnamed for historical reasons. -It is semi-obsolete and is only used if `mail-citation-hook' is nil.") - -(defvar mail-citation-hook nil - "*Hook for modifying a citation just inserted in the mail buffer. -Each hook function can find the citation between point and mark. -And each hook function should leave point and mark around the citation -text as modified. - -If this hook is entirely empty (nil), the text of the message is inserted -with `mh-ins-buf-prefix' prefixed to each line. - -See also the variable `mh-yank-from-start-of-msg', which controls how -much of the message passed to the hook. - -This hook was historically provided to set up supercite. You may now leave -this nil and set up supercite by setting the variable -`mh-yank-from-start-of-msg' to 'supercite or, for more automatic insertion, -to 'autosupercite.") - -(defvar mh-comp-formfile "components" - "Name of file to be used as a skeleton for composing messages. -Default is \"components\". If not an absolute file name, the file -is searched for first in the user's MH directory, then in the -system MH lib directory.") - -(defvar mh-repl-formfile "replcomps" - "Name of file to be used as a skeleton for replying to messages. -Default is \"replcomps\". If not an absolute file name, the file -is searched for first in the user's MH directory, then in the -system MH lib directory.") - -(defvar mh-repl-group-formfile "replgroupcomps" - "Name of file to be used as a skeleton for replying to messages. -This file is used to form replies to the sender and all recipients of a -message. Only used if `mh-nmh-flag' is non-nil. Default is \"replgroupcomps\". -If not an absolute file name, the file is searched for first in the user's MH -directory, then in the system MH lib directory.") - -(defvar mh-rejected-letter-start - (format "^%s$" - (regexp-opt - '("Content-Type: message/rfc822" ;MIME MDN - " ----- Unsent message follows -----" ;from sendmail V5 - " --------Unsent Message below:" ; from sendmail at BU - " ----- Original message follows -----" ;from sendmail V8 - "------- Unsent Draft" ;from MH itself - "---------- Original Message ----------" ;from zmailer - " --- The unsent message follows ---" ;from AIX mail system - " Your message follows:" ;from MMDF-II - "Content-Description: Returned Content" ;1993 KJ sendmail - )))) - -(defvar mh-new-draft-cleaned-headers - "^Date:\\|^Received:\\|^Message-Id:\\|^From:\\|^Sender:\\|^Errors-To:\\|^Delivery-Date:\\|^Return-Path:" - "Regexp of header lines to remove before offering a message as a new draft. -Used by the \\<mh-folder-mode-map>`\\[mh-edit-again]' and `\\[mh-extract-rejected-mail]' commands.") - -(defvar mh-to-field-choices '(("t" . "To:") ("s" . "Subject:") ("c" . "Cc:") - ("b" . "Bcc:") ("f" . "Fcc:") ("r" . "From:") - ("d" . "Dcc:")) - "Alist of (final-character . field-name) choices for `mh-to-field'.") - -(defvar mh-letter-mode-map (copy-keymap text-mode-map) - "Keymap for composing mail.") - -(defvar mh-letter-mode-syntax-table nil - "Syntax table used by MH-E while in MH-Letter mode.") - -(if mh-letter-mode-syntax-table - () - (setq mh-letter-mode-syntax-table - (make-syntax-table text-mode-syntax-table)) - (modify-syntax-entry ?% "." mh-letter-mode-syntax-table)) - -(defvar mh-sent-from-folder nil - "Folder of msg assoc with this letter.") - -(defvar mh-sent-from-msg nil - "Number of msg assoc with this letter.") - -(defvar mh-send-args nil - "Extra args to pass to \"send\" command.") - -(defvar mh-annotate-char nil - "Character to use to annotate `mh-sent-from-msg'.") - -(defvar mh-annotate-field nil - "Field name for message annotation.") - -;;;###autoload -(defun mh-smail () - "Compose and send mail with the MH mail system. -This function is an entry point to MH-E, the Emacs front end -to the MH mail system. - -See documentation of `\\[mh-send]' for more details on composing mail." - (interactive) - (mh-find-path) - (call-interactively 'mh-send)) - -(defvar mh-error-if-no-draft nil) ;raise error over using old draft - -;;;###autoload -(defun mh-smail-batch (&optional to subject other-headers &rest ignored) - "Set up a mail composition draft with the MH mail system. -This function is an entry point to MH-E, the Emacs front end -to the MH mail system. This function does not prompt the user -for any header fields, and thus is suitable for use by programs -that want to create a mail buffer. -Users should use `\\[mh-smail]' to compose mail. -Optional arguments for setting certain fields include TO, SUBJECT, and -OTHER-HEADERS. Additional arguments are IGNORED." - (mh-find-path) - (let ((mh-error-if-no-draft t)) - (mh-send (or to "") "" (or subject "")))) - -;; XEmacs needs this: -;;;###autoload -(defun mh-user-agent-compose (&optional to subject other-headers continue - switch-function yank-action - send-actions) - "Set up mail composition draft with the MH mail system. -This is `mail-user-agent' entry point to MH-E. - -The optional arguments TO and SUBJECT specify recipients and the -initial Subject field, respectively. - -OTHER-HEADERS is an alist specifying additional -header fields. Elements look like (HEADER . VALUE) where both -HEADER and VALUE are strings. - -CONTINUE, SWITCH-FUNCTION, YANK-ACTION and SEND-ACTIONS are ignored." - (mh-find-path) - (let ((mh-error-if-no-draft t)) - (mh-send to "" subject) - (while other-headers - (mh-insert-fields (concat (car (car other-headers)) ":") - (cdr (car other-headers))) - (setq other-headers (cdr other-headers))))) - -;;;###mh-autoload -(defun mh-edit-again (msg) - "Clean up a draft or a message MSG previously sent and make it resendable. -Default is the current message. -The variable `mh-new-draft-cleaned-headers' specifies the headers to remove. -See also documentation for `\\[mh-send]' function." - (interactive (list (mh-get-msg-num t))) - (let* ((from-folder mh-current-folder) - (config (current-window-configuration)) - (draft - (cond ((and mh-draft-folder (equal from-folder mh-draft-folder)) - (pop-to-buffer (find-file-noselect (mh-msg-filename msg)) t) - (rename-buffer (format "draft-%d" msg)) - ;; Make buffer writable... - (setq buffer-read-only nil) - ;; If buffer was being used to display the message reinsert - ;; from file... - (when (eq major-mode 'mh-show-mode) - (erase-buffer) - (insert-file-contents buffer-file-name)) - (buffer-name)) - (t - (mh-read-draft "clean-up" (mh-msg-filename msg) nil))))) - (mh-clean-msg-header (point-min) mh-new-draft-cleaned-headers nil) - (mh-insert-header-separator) - (goto-char (point-min)) - (save-buffer) - (mh-compose-and-send-mail draft "" from-folder nil nil nil nil nil nil - config) - (mh-letter-mode-message))) - -;;;###mh-autoload -(defun mh-extract-rejected-mail (msg) - "Extract message MSG returned by the mail system and make it resendable. -Default is the current message. The variable `mh-new-draft-cleaned-headers' -gives the headers to clean out of the original message. -See also documentation for `\\[mh-send]' function." - (interactive (list (mh-get-msg-num t))) - (let ((from-folder mh-current-folder) - (config (current-window-configuration)) - (draft (mh-read-draft "extraction" (mh-msg-filename msg) nil))) - (goto-char (point-min)) - (cond ((re-search-forward mh-rejected-letter-start nil t) - (skip-chars-forward " \t\n") - (delete-region (point-min) (point)) - (mh-clean-msg-header (point-min) mh-new-draft-cleaned-headers nil)) - (t - (message "Does not appear to be a rejected letter."))) - (mh-insert-header-separator) - (goto-char (point-min)) - (save-buffer) - (mh-compose-and-send-mail draft "" from-folder msg - (mh-get-header-field "To:") - (mh-get-header-field "From:") - (mh-get-header-field "Cc:") - nil nil config) - (mh-letter-mode-message))) - -;;;###mh-autoload -(defun mh-forward (to cc &optional msg-or-seq) - "Forward one or more messages to the recipients TO and CC. - -Use the optional MSG-OR-SEQ to specify a message or sequence to forward. - -Default is the displayed message. If optional prefix argument is given then -prompt for the message sequence. If variable `transient-mark-mode' is non-nil -and the mark is active, then the selected region is forwarded. -See also documentation for `\\[mh-send]' function." - (interactive (list (mh-read-address "To: ") - (mh-read-address "Cc: ") - (cond - ((mh-mark-active-p t) - (mh-region-to-msg-list (region-beginning) (region-end))) - (current-prefix-arg - (mh-read-seq-default "Forward" t)) - (t - (mh-get-msg-num t))))) - (let* ((folder mh-current-folder) - (msgs (cond ((numberp msg-or-seq) (list msg-or-seq)) - ((listp msg-or-seq) msg-or-seq) - (t (mh-seq-to-msgs msg-or-seq)))) - (config (current-window-configuration)) - (fwd-msg-file (mh-msg-filename (car msgs) folder)) - ;; forw always leaves file in "draft" since it doesn't have -draft - (draft-name (expand-file-name "draft" mh-user-path)) - (draft (cond ((or (not (file-exists-p draft-name)) - (y-or-n-p "The file 'draft' exists. Discard it? ")) - (mh-exec-cmd "forw" "-build" (if mh-nmh-flag "-mime") - mh-current-folder msgs) - (prog1 - (mh-read-draft "" draft-name t) - (mh-insert-fields "To:" to "Cc:" cc) - (save-buffer))) - (t - (mh-read-draft "" draft-name nil))))) - (let (orig-from - orig-subject) - (save-excursion - (set-buffer (get-buffer-create mh-temp-buffer)) - (erase-buffer) - (insert-file-contents fwd-msg-file) - (setq orig-from (mh-get-header-field "From:")) - (setq orig-subject (mh-get-header-field "Subject:"))) - (let ((forw-subject - (mh-forwarded-letter-subject orig-from orig-subject)) - (compose)) - (mh-insert-fields "Subject:" forw-subject) - (goto-char (point-min)) - ;; If using MML, translate mhn - (if (equal mh-compose-insertion 'gnus) - (save-excursion - (setq compose t) - (re-search-forward (format "^\\(%s\\)?$" - mh-mail-header-separator)) - (while - (re-search-forward - "^#forw \\[\\([^]]+\\)\\] \\(+\\S-+\\) \\(.*\\)$" - (point-max) t) - (let ((description (if (equal (match-string 1) - "forwarded messages") - "forwarded message %d" - (match-string 1))) - (msgs (split-string (match-string 3))) - (i 0)) - (beginning-of-line) - (delete-region (point) (progn (forward-line 1) (point))) - (dolist (msg msgs) - (setq i (1+ i)) - (mh-mml-forward-message (format description i) - folder msg)))))) - ;; Postition just before forwarded message - (if (re-search-forward "^------- Forwarded Message" nil t) - (forward-line -1) - (re-search-forward (format "^\\(%s\\)?$" mh-mail-header-separator)) - (forward-line 1)) - (delete-other-windows) - (mh-add-msgs-to-seq msgs 'forwarded t) - (mh-compose-and-send-mail draft "" folder msg-or-seq - to forw-subject cc - mh-note-forw "Forwarded:" - config) - (if compose - (setq mh-mml-compose-insert-flag t)) - (mh-letter-mode-message))))) - -(defun mh-forwarded-letter-subject (from subject) - "Return a Subject suitable for a forwarded message. -Original message has headers FROM and SUBJECT." - (let ((addr-start (string-match "<" from)) - (comment (string-match "(" from))) - (cond ((and addr-start (> addr-start 0)) - ;; Full Name <luser@host> - (setq from (substring from 0 (1- addr-start)))) - (comment - ;; luser@host (Full Name) - (setq from (substring from (1+ comment) (1- (length from))))))) - (format mh-forward-subject-format from subject)) - -;;;###autoload -(defun mh-smail-other-window () - "Compose and send mail in other window with the MH mail system. -This function is an entry point to MH-E, the Emacs front end -to the MH mail system. - -See documentation of `\\[mh-send]' for more details on composing mail." - (interactive) - (mh-find-path) - (call-interactively 'mh-send-other-window)) - -;;;###mh-autoload -(defun mh-redistribute (to cc &optional msg) - "Redistribute displayed message to recipients TO and CC. -Use optional argument MSG to redistribute another message. -Depending on how your copy of MH was compiled, you may need to change the -setting of the variable `mh-redist-full-contents'. See its documentation." - (interactive (list (mh-read-address "Redist-To: ") - (mh-read-address "Redist-Cc: ") - (mh-get-msg-num t))) - (or msg - (setq msg (mh-get-msg-num t))) - (save-window-excursion - (let ((folder mh-current-folder) - (draft (mh-read-draft "redistribution" - (if mh-redist-full-contents - (mh-msg-filename msg) - nil) - nil))) - (mh-goto-header-end 0) - (insert "Resent-To: " to "\n") - (if (not (equal cc "")) (insert "Resent-cc: " cc "\n")) - (mh-clean-msg-header (point-min) - "^Message-Id:\\|^Received:\\|^Return-Path:\\|^Sender:\\|^Date:\\|^From:" - nil) - (save-buffer) - (message "Redistributing...") - (if (not mh-redist-background) - (if mh-redist-full-contents - (call-process "/bin/sh" nil 0 nil "-c" - (format "mhdist=1 mhaltmsg=%s %s -push %s" - buffer-file-name - (expand-file-name mh-send-prog mh-progs) - buffer-file-name)) - (call-process "/bin/sh" nil 0 nil "-c" - (format - "mhdist=1 mhaltmsg=%s mhannotate=1 %s -push %s" - (mh-msg-filename msg folder) - (expand-file-name mh-send-prog mh-progs) - buffer-file-name)))) - (mh-annotate-msg msg folder mh-note-dist - "-component" "Resent:" - "-text" (format "\"%s %s\"" to cc)) - (if mh-redist-background - (mh-exec-cmd-daemon "/bin/sh" "-c" - (format "mhdist=1 mhaltmsg=%s %s %s %s" - (if mh-redist-full-contents - buffer-file-name - (mh-msg-filename msg folder)) - (if mh-redist-full-contents - "" - "mhannotate=1") - (mh-expand-file-name "send" mh-progs) - buffer-file-name))) - (kill-buffer draft) - (message "Redistributing...done")))) - -(defun mh-show-buffer-message-number (&optional buffer) - "Message number of displayed message in corresponding show buffer. -Return nil if show buffer not displayed. -If in `mh-letter-mode', don't display the message number being replied to, -but rather the message number of the show buffer associated with our -originating folder buffer. -Optional argument BUFFER can be used to specify the buffer." - (save-excursion - (if buffer - (set-buffer buffer)) - (cond ((eq major-mode 'mh-show-mode) - (let ((number-start (mh-search-from-end ?/ buffer-file-name))) - (car (read-from-string (substring buffer-file-name - (1+ number-start)))))) - ((and (eq major-mode 'mh-folder-mode) - mh-show-buffer - (get-buffer mh-show-buffer)) - (mh-show-buffer-message-number mh-show-buffer)) - ((and (eq major-mode 'mh-letter-mode) - mh-sent-from-folder - (get-buffer mh-sent-from-folder)) - (mh-show-buffer-message-number mh-sent-from-folder)) - (t - nil)))) - -;;;###mh-autoload -(defun mh-reply (message &optional reply-to includep) - "Reply to MESSAGE (default: current message). -If the optional argument REPLY-TO is not given, prompts for type of addresses -to reply to: - from sender only, - to sender and primary recipients, - cc/all sender and all recipients. -If optional prefix argument INCLUDEP provided, then include the message -in the reply using filter `mhl.reply' in your MH directory. -If the file named by `mh-repl-formfile' exists, it is used as a skeleton -for the reply. See also documentation for `\\[mh-send]' function." - (interactive (list - (mh-get-msg-num t) - (let ((minibuffer-help-form - "from => Sender only\nto => Sender and primary recipients\ncc or all => Sender and all recipients")) - (or mh-reply-default-reply-to - (completing-read "Reply to whom? (from, to, all) [from]: " - '(("from") ("to") ("cc") ("all")) - nil - t))) - current-prefix-arg)) - (let* ((folder mh-current-folder) - (show-buffer mh-show-buffer) - (config (current-window-configuration)) - (group-reply (or (equal reply-to "cc") (equal reply-to "all"))) - (form-file (cond ((and mh-nmh-flag group-reply - (stringp mh-repl-group-formfile)) - mh-repl-group-formfile) - ((stringp mh-repl-formfile) mh-repl-formfile) - (t nil)))) - (message "Composing a reply...") - (mh-exec-cmd "repl" "-build" "-noquery" "-nodraftfolder" - (if form-file - (list "-form" form-file)) - mh-current-folder message - (cond ((or (equal reply-to "from") (equal reply-to "")) - '("-nocc" "all")) - ((equal reply-to "to") - '("-cc" "to")) - (group-reply (if mh-nmh-flag - '("-group" "-nocc" "me") - '("-cc" "all" "-nocc" "me")))) - (cond ((or (eq mh-yank-from-start-of-msg 'autosupercite) - (eq mh-yank-from-start-of-msg 'autoattrib)) - '("-noformat")) - (includep '("-filter" "mhl.reply")) - (t '()))) - (let ((draft (mh-read-draft "reply" - (expand-file-name "reply" mh-user-path) - t))) - (delete-other-windows) - (save-buffer) - - (let ((to (mh-get-header-field "To:")) - (subject (mh-get-header-field "Subject:")) - (cc (mh-get-header-field "Cc:"))) - (goto-char (point-min)) - (mh-goto-header-end 1) - (or includep - (not mh-reply-show-message-flag) - (mh-in-show-buffer (show-buffer) - (mh-display-msg message folder))) - (mh-add-msgs-to-seq message 'answered t) - (message "Composing a reply...done") - (mh-compose-and-send-mail draft "" folder message to subject cc - mh-note-repl "Replied:" config)) - (when (and (or (eq 'autosupercite mh-yank-from-start-of-msg) - (eq 'autoattrib mh-yank-from-start-of-msg)) - (eq (mh-show-buffer-message-number) mh-sent-from-msg)) - (undo-boundary) - (mh-yank-cur-msg)) - (mh-letter-mode-message)))) - -;;;###mh-autoload -(defun mh-send (to cc subject) - "Compose and send a letter. - -Do not call this function from outside MH-E; use \\[mh-smail] instead. - -The file named by `mh-comp-formfile' will be used as the form. -The letter is composed in `mh-letter-mode'; see its documentation for more -details. -If `mh-compose-letter-function' is defined, it is called on the draft and -passed three arguments: TO, CC, and SUBJECT." - (interactive (list - (mh-read-address "To: ") - (mh-read-address "Cc: ") - (read-string "Subject: "))) - (let ((config (current-window-configuration))) - (delete-other-windows) - (mh-send-sub to cc subject config))) - -;;;###mh-autoload -(defun mh-send-other-window (to cc subject) - "Compose and send a letter in another window. - -Do not call this function from outside MH-E; use \\[mh-smail-other-window] -instead. - -The file named by `mh-comp-formfile' will be used as the form. -The letter is composed in `mh-letter-mode'; see its documentation for more -details. -If `mh-compose-letter-function' is defined, it is called on the draft and -passed three arguments: TO, CC, and SUBJECT." - (interactive (list - (mh-read-address "To: ") - (mh-read-address "Cc: ") - (read-string "Subject: "))) - (let ((pop-up-windows t)) - (mh-send-sub to cc subject (current-window-configuration)))) - -(defun mh-send-sub (to cc subject config) - "Do the real work of composing and sending a letter. -Expects the TO, CC, and SUBJECT fields as arguments. -CONFIG is the window configuration before sending mail." - (let ((folder mh-current-folder) - (msg-num (mh-get-msg-num nil))) - (message "Composing a message...") - (let ((draft (mh-read-draft - "message" - (let (components) - (cond - ((file-exists-p - (setq components - (expand-file-name mh-comp-formfile mh-user-path))) - components) - ((file-exists-p - (setq components - (expand-file-name mh-comp-formfile mh-lib))) - components) - ((file-exists-p - (setq components - (expand-file-name mh-comp-formfile - ;; What is this mh-etc ?? -sm - ;; This is dead code, so - ;; remove it. - ;(and (boundp 'mh-etc) mh-etc) - ))) - components) - (t - (error (format "Can't find components file \"%s\"" - components))))) - nil))) - (mh-insert-fields "To:" to "Subject:" subject "Cc:" cc) - (goto-char (point-max)) - (mh-compose-and-send-mail draft "" folder msg-num - to subject cc - nil nil config) - (mh-letter-mode-message)))) - -(defun mh-read-draft (use initial-contents delete-contents-file) - "Read draft file into a draft buffer and make that buffer the current one. -USE is a message used for prompting about the intended use of the message. -INITIAL-CONTENTS is filename that is read into an empty buffer, or nil -if buffer should not be modified. Delete the initial-contents file if -DELETE-CONTENTS-FILE flag is set. -Returns the draft folder's name. -If the draft folder facility is enabled in ~/.mh_profile, a new buffer is -used each time and saved in the draft folder. The draft file can then be -reused." - (cond (mh-draft-folder - (let ((orig-default-dir default-directory) - (draft-file-name (mh-new-draft-name))) - (pop-to-buffer (generate-new-buffer - (format "draft-%s" - (file-name-nondirectory draft-file-name)))) - (condition-case () - (insert-file-contents draft-file-name t) - (file-error)) - (setq default-directory orig-default-dir))) - (t - (let ((draft-name (expand-file-name "draft" mh-user-path))) - (pop-to-buffer "draft") ; Create if necessary - (if (buffer-modified-p) - (if (y-or-n-p "Draft has been modified; kill anyway? ") - (set-buffer-modified-p nil) - (error "Draft preserved"))) - (setq buffer-file-name draft-name) - (clear-visited-file-modtime) - (unlock-buffer) - (cond ((and (file-exists-p draft-name) - (not (equal draft-name initial-contents))) - (insert-file-contents draft-name) - (delete-file draft-name)))))) - (cond ((and initial-contents - (or (zerop (buffer-size)) - (if (y-or-n-p - (format "A draft exists. Use for %s? " use)) - (if mh-error-if-no-draft - (error "A prior draft exists")) - t))) - (erase-buffer) - (insert-file-contents initial-contents) - (if delete-contents-file (delete-file initial-contents)))) - (auto-save-mode 1) - (if mh-draft-folder - (save-buffer)) ; Do not reuse draft name - (buffer-name)) - -(defun mh-new-draft-name () - "Return the pathname of folder for draft messages." - (save-excursion - (mh-exec-cmd-quiet t "mhpath" mh-draft-folder "new") - (buffer-substring (point-min) (1- (point-max))))) - -(defun mh-annotate-msg (msg buffer note &rest args) - "Mark MSG in BUFFER with character NOTE and annotate message with ARGS." - (apply 'mh-exec-cmd "anno" buffer msg args) - (save-excursion - (cond ((get-buffer buffer) ; Buffer may be deleted - (set-buffer buffer) - (if (numberp msg) - (mh-notate msg note (1+ mh-cmd-note)) - (mh-notate-seq msg note (1+ mh-cmd-note))))))) - -(defun mh-insert-fields (&rest name-values) - "Insert the NAME-VALUES pairs in the current buffer. -If the field exists, append the value to it. -Do not insert any pairs whose value is the empty string." - (let ((case-fold-search t)) - (while name-values - (let ((field-name (car name-values)) - (value (car (cdr name-values)))) - (cond ((equal value "") - nil) - ((mh-position-on-field field-name) - (insert " " (or value ""))) - (t - (insert field-name " " value "\n"))) - (setq name-values (cdr (cdr name-values))))))) - -(defun mh-position-on-field (field &optional ignored) - "Move to the end of the FIELD in the header. -Move to end of entire header if FIELD not found. -Returns non-nil iff FIELD was found. -The optional second arg is for pre-version 4 compatibility and is IGNORED." - (cond ((mh-goto-header-field field) - (mh-header-field-end) - t) - ((mh-goto-header-end 0) - nil))) - -(defun mh-get-header-field (field) - "Find and return the body of FIELD in the mail header. -Returns the empty string if the field is not in the header of the -current buffer." - (if (mh-goto-header-field field) - (progn - (skip-chars-forward " \t") ;strip leading white space in body - (let ((start (point))) - (mh-header-field-end) - (buffer-substring-no-properties start (point)))) - "")) - -(fset 'mh-get-field 'mh-get-header-field) ;MH-E 4 compatibility - -(defun mh-goto-header-field (field) - "Move to FIELD in the message header. -Move to the end of the FIELD name, which should end in a colon. -Returns t if found, nil if not." - (goto-char (point-min)) - (let ((case-fold-search t) - (headers-end (save-excursion - (mh-goto-header-end 0) - (point)))) - (re-search-forward (format "^%s" field) headers-end t))) - -(defun mh-goto-header-end (arg) - "Move the cursor ARG lines after the header." - (if (re-search-forward "^-*$" nil nil) - (forward-line arg))) - -(defun mh-extract-from-header-value () - "Extract From: string from header." - (save-excursion - (if (not (mh-goto-header-field "From:")) - (error "No From header line found") - (skip-chars-forward " \t") - (buffer-substring-no-properties - (point) (progn (mh-header-field-end)(point)))))) - - - -;;; Mode for composing and sending a draft message. - -(put 'mh-letter-mode 'mode-class 'special) - -;;; Menu extracted from mh-menubar.el V1.1 (31 July 2001) -(eval-when-compile (defvar mh-letter-menu nil)) -(cond - ((fboundp 'easy-menu-define) - (easy-menu-define - mh-letter-menu mh-letter-mode-map "Menu for MH-E letter mode." - '("Letter" - ["Send This Draft" mh-send-letter t] - ["Split Current Line" mh-open-line t] - ["Check Recipient" mh-check-whom t] - ["Yank Current Message" mh-yank-cur-msg t] - ["Insert a Message..." mh-insert-letter t] - ["Insert Signature" mh-insert-signature t] - ["GPG Sign message" - mh-mml-secure-message-sign-pgpmime mh-gnus-pgp-support-flag] - ["GPG Encrypt message" - mh-mml-secure-message-encrypt-pgpmime mh-gnus-pgp-support-flag] - ["Compose Insertion (MIME)..." mh-compose-insertion t] - ;; ["Compose Compressed tar (MIME)..." - ;;mh-mhn-compose-external-compressed-tar t] - ;; ["Compose Anon FTP (MIME)..." mh-mhn-compose-anon-ftp t] - ["Compose Forward (MIME)..." mh-compose-forward t] - ;; The next two will have to be merged. But I also need to make sure the - ;; user can't mix directives of both types. - ["Pull in All Compositions (mhn)" - mh-edit-mhn mh-mhn-compose-insert-flag] - ["Pull in All Compositions (gnus)" - mh-mml-to-mime mh-mml-compose-insert-flag] - ["Revert to Non-MIME Edit (mhn)" - mh-revert-mhn-edit (equal mh-compose-insertion 'mhn)] - ["Kill This Draft" mh-fully-kill-draft t])))) - -;;; Help Messages -;;; Group messages logically, more or less. -(defvar mh-letter-mode-help-messages - '((nil - "Send letter: \\[mh-send-letter]" - "\t\tOpen line: \\[mh-open-line]\n" - "Kill letter: \\[mh-fully-kill-draft]" - "\t\tInsert:\n" - "Check recipients: \\[mh-check-whom]" - "\t\t Current message: \\[mh-yank-cur-msg]\n" - "Encrypt message: \\[mh-mml-secure-message-encrypt-pgpmime]" - "\t\t Attachment: \\[mh-compose-insertion]\n" - "Sign message: \\[mh-mml-secure-message-sign-pgpmime]" - "\t\t Message to forward: \\[mh-compose-forward]\n" - " " - "\t\t Signature: \\[mh-insert-signature]")) - "Key binding cheat sheet. - -This is an associative array which is used to show the most common commands. -The key is a prefix char. The value is one or more strings which are -concatenated together and displayed in the minibuffer if ? is pressed after -the prefix character. The special key nil is used to display the -non-prefixed commands. - -The substitutions described in `substitute-command-keys' are performed as -well.") - -;;;###mh-autoload -(defun mh-fill-paragraph-function (arg) - "Fill paragraph at or after point. -Prefix ARG means justify as well. This function enables `fill-paragraph' to -work better in MH-Letter mode." - (interactive "P") - (let ((fill-paragraph-function) (fill-prefix)) - (if (mh-in-header-p) - (mail-mode-fill-paragraph arg) - (fill-paragraph arg)))) - -;;;###autoload -(define-derived-mode mh-letter-mode text-mode "MH-Letter" - "Mode for composing letters in MH-E.\\<mh-letter-mode-map> - -When you have finished composing, type \\[mh-send-letter] to send the message -using the MH mail handling system. - -There are two types of MIME directives used by MH-E: Gnus and MH. The option -`mh-compose-insertion' controls what type of directives are inserted by MH-E -commands. These directives can be converted to MIME body parts by running -\\[mh-edit-mhn] for mhn directives or \\[mh-mml-to-mime] for Gnus directives. -This step is mandatory if these directives are added manually. If the -directives are inserted with MH-E commands such as \\[mh-compose-insertion], -the directives are expanded automatically when the letter is sent. - -Options that control this mode can be changed with -\\[customize-group]; specify the \"mh-compose\" group. - -When a message is composed, the hooks `text-mode-hook' and -`mh-letter-mode-hook' are run. - -\\{mh-letter-mode-map}" - - (or mh-user-path (mh-find-path)) - (make-local-variable 'mh-send-args) - (make-local-variable 'mh-annotate-char) - (make-local-variable 'mh-annotate-field) - (make-local-variable 'mh-previous-window-config) - (make-local-variable 'mh-sent-from-folder) - (make-local-variable 'mh-sent-from-msg) - (make-local-variable 'mail-header-separator) - (setq mail-header-separator mh-mail-header-separator) ;override sendmail.el - (make-local-variable 'mh-help-messages) - (setq mh-help-messages mh-letter-mode-help-messages) - - ;; From sendmail.el for proper paragraph fill - ;; sendmail.el also sets a normal-auto-fill-function (not done here) - (make-local-variable 'paragraph-separate) - (make-local-variable 'paragraph-start) - (make-local-variable 'fill-paragraph-function) - (setq fill-paragraph-function 'mh-fill-paragraph-function) - (make-local-variable 'adaptive-fill-regexp) - (setq adaptive-fill-regexp - (concat adaptive-fill-regexp - "\\|[ \t]*[-[:alnum:]]*>+[ \t]*")) - (make-local-variable 'adaptive-fill-first-line-regexp) - (setq adaptive-fill-first-line-regexp - (concat adaptive-fill-first-line-regexp - "\\|[ \t]*[-[:alnum:]]*>+[ \t]*")) - ;; `-- ' precedes the signature. `-----' appears at the start of the - ;; lines that delimit forwarded messages. - ;; Lines containing just >= 3 dashes, perhaps after whitespace, - ;; are also sometimes used and should be separators. - (setq paragraph-start (concat (regexp-quote mail-header-separator) - "\\|\t*\\([-|#;>* ]\\|(?[0-9]+[.)]\\)+$" - "\\|[ \t]*[[:alnum:]]*>+[ \t]*$\\|[ \t]*$\\|" - "-- $\\|---+$\\|" - page-delimiter)) - (setq paragraph-separate paragraph-start) - ;; --- End of code from sendmail.el --- - - (if (and (boundp 'tool-bar-mode) tool-bar-mode) - (set (make-local-variable 'tool-bar-map) mh-letter-tool-bar-map)) - (make-local-variable 'font-lock-defaults) - (cond - ((or (equal mh-highlight-citation-p 'font-lock) - (equal mh-highlight-citation-p 'gnus)) - ;; Let's use font-lock even if gnus is used in show-mode. The reason - ;; is that gnus uses static text properties which are not appropriate - ;; for a buffer that will be edited. So the choice here is either fontify - ;; the citations and header... - (setq font-lock-defaults '(mh-show-font-lock-keywords-with-cite t))) - (t - ;; ...or the header only - (setq font-lock-defaults '(mh-show-font-lock-keywords t)))) - (easy-menu-add mh-letter-menu) - ;; See if a "forw: -mime" message containing a MIME composition. - ;; Mode clears local vars, so can't do this in mh-forward. - (save-excursion - (goto-char (point-min)) - (when (and (re-search-forward - (format "^\\(%s\\)?$" mail-header-separator) nil t) - (= 0 (forward-line 1)) - (looking-at "^#forw")) - (require 'mh-mime) ;Need mh-mhn-compose-insert-flag local var - (setq mh-mhn-compose-insert-flag t))) - (setq fill-column mh-letter-fill-column) - ;; If text-mode-hook turned on auto-fill, tune it for messages - (when auto-fill-function - (make-local-variable 'auto-fill-function) - (setq auto-fill-function 'mh-auto-fill-for-letter))) - -(defun mh-auto-fill-for-letter () - "Perform auto-fill for message. -Header is treated specially by inserting a tab before continuation lines." - (if (mh-in-header-p) - (let ((fill-prefix "\t")) - (do-auto-fill)) - (do-auto-fill))) - -(defun mh-insert-header-separator () - "Insert `mh-mail-header-separator', if absent." - (save-excursion - (goto-char (point-min)) - (rfc822-goto-eoh) - (if (looking-at "$") - (insert mh-mail-header-separator)))) - -;;;###mh-autoload -(defun mh-to-field () - "Move point to the end of a specified header field. -The field is indicated by the previous keystroke (the last keystroke -of the command) according to the list in the variable `mh-to-field-choices'. -Create the field if it does not exist. Set the mark to point before moving." - (interactive) - (expand-abbrev) - (let ((target (cdr (or (assoc (char-to-string (logior last-input-char ?`)) - mh-to-field-choices) - ;; also look for a char for version 4 compat - (assoc (logior last-input-char ?`) - mh-to-field-choices)))) - (case-fold-search t)) - (push-mark) - (cond ((mh-position-on-field target) - (let ((eol (point))) - (skip-chars-backward " \t") - (delete-region (point) eol)) - (if (and (not (eq (logior last-input-char ?`) ?s)) - (save-excursion - (backward-char 1) - (not (looking-at "[:,]")))) - (insert ", ") - (insert " "))) - (t - (if (mh-position-on-field "To:") - (forward-line 1)) - (insert (format "%s \n" target)) - (backward-char 1))))) - -;;;###mh-autoload -(defun mh-to-fcc (&optional folder) - "Insert an Fcc: FOLDER field in the current message. -Prompt for the field name with a completion list of the current folders." - (interactive) - (or folder - (setq folder (mh-prompt-for-folder - "Fcc" - (or (and mh-default-folder-for-message-function - (save-excursion - (goto-char (point-min)) - (funcall - mh-default-folder-for-message-function))) - "") - t))) - (let ((last-input-char ?\C-f)) - (expand-abbrev) - (save-excursion - (mh-to-field) - (insert (if (mh-folder-name-p folder) - (substring folder 1) - folder))))) - -;;;###mh-autoload -(defun mh-insert-signature () - "Insert the file named by `mh-signature-file-name' at point. -The value of `mh-letter-insert-signature-hook' is a list of functions to be -called, with no arguments, before the signature is actually inserted." - (interactive) - (let ((mh-signature-file-name mh-signature-file-name)) - (run-hooks 'mh-letter-insert-signature-hook) - (if mh-signature-file-name - (insert-file-contents mh-signature-file-name))) - (force-mode-line-update)) - -;;;###mh-autoload -(defun mh-check-whom () - "Verify recipients of the current letter, showing expansion of any aliases." - (interactive) - (let ((file-name buffer-file-name)) - (save-buffer) - (message "Checking recipients...") - (mh-in-show-buffer ("*Recipients*") - (bury-buffer (current-buffer)) - (erase-buffer) - (mh-exec-cmd-output "whom" t file-name)) - (message "Checking recipients...done"))) - - - -;;; Routines to compose and send a letter. - -(defun mh-insert-x-face () - "Append X-Face field to header. -If the field already exists, this function does nothing." - (when (and (file-exists-p mh-x-face-file) - (file-readable-p mh-x-face-file)) - (save-excursion - (when (null (mh-position-on-field "X-Face")) - (insert "X-Face: ") - (goto-char (+ (point) (cadr (insert-file-contents mh-x-face-file)))) - (if (not (looking-at "^")) - (insert "\n")))))) - -(defun mh-insert-x-mailer () - "Append an X-Mailer field to the header. -The versions of MH-E, Emacs, and MH are shown." - - ;; Lazily initialize mh-x-mailer-string. - (when (null mh-x-mailer-string) - (save-window-excursion - (mh-version) - (set-buffer mh-temp-buffer) - (if mh-nmh-flag - (search-forward-regexp "^nmh-\\(\\S +\\)") - (search-forward-regexp "^MH \\(\\S +\\)" nil t)) - (let ((x-mailer-mh (buffer-substring (match-beginning 1) (match-end 1)))) - (setq mh-x-mailer-string - (format "MH-E %s; %s %s; %s %d.%d" - mh-version (if mh-nmh-flag "nmh" "MH") x-mailer-mh - (if mh-xemacs-flag - "XEmacs" - "Emacs") - emacs-major-version emacs-minor-version))) - (kill-buffer mh-temp-buffer))) - ;; Insert X-Mailer, but only if it doesn't already exist. - (save-excursion - (when (null (mh-goto-header-field "X-Mailer")) - (mh-insert-fields "X-Mailer:" mh-x-mailer-string)))) - -(defun mh-regexp-in-field-p (regexp &rest fields) - "Non-nil means REGEXP was found in FIELDS." - (save-excursion - (let ((search-result nil) - (field)) - (while fields - (setq field (car fields)) - (if (and (mh-goto-header-field field) - (re-search-forward - regexp (save-excursion (mh-header-field-end)(point)) t)) - (setq fields nil - search-result t) - (setq fields (cdr fields)))) - search-result))) - -(defun mh-insert-mail-followup-to () - "Insert Mail-Followup-To: if To or Cc match `mh-insert-mail-followup-to-list'." - (save-excursion - (if (and (or (mh-goto-header-field "To:")(mh-goto-header-field "cc:")) - (not (mh-goto-header-field "Mail-Followup-To: "))) - (let ((list mh-insert-mail-followup-to-list)) - (while list - (let ((regexp (nth 0 (car list))) - (entry (nth 1 (car list)))) - (when (mh-regexp-in-field-p regexp "To:" "cc:") - (if (mh-goto-header-field "Mail-Followup-To: ") - (insert entry ", ") - (mh-goto-header-end 0) - (insert "Mail-Followup-To: " entry "\n"))) - (setq list (cdr list)))))))) - -(defun mh-compose-and-send-mail (draft send-args - sent-from-folder sent-from-msg - to subject cc - annotate-char annotate-field - config) - "Edit and compose a draft message in buffer DRAFT and send or save it. -SEND-ARGS is the argument passed to the send command. -SENT-FROM-FOLDER is buffer containing scan listing of current folder, or -nil if none exists. -SENT-FROM-MSG is the message number or sequence name or nil. -The TO, SUBJECT, and CC fields are passed to the -`mh-compose-letter-function'. -If ANNOTATE-CHAR is non-null, it is used to notate the scan listing of the -message. In that case, the ANNOTATE-FIELD is used to build a string -for `mh-annotate-msg'. -CONFIG is the window configuration to restore after sending the letter." - (pop-to-buffer draft) - (if mh-insert-mail-followup-to-flag (mh-insert-mail-followup-to)) - (mh-letter-mode) - - ;; mh-identity support - (if (and (boundp 'mh-identity-default) - mh-identity-default) - (mh-insert-identity mh-identity-default)) - (when (and (boundp 'mh-identity-list) - mh-identity-list) - (mh-identity-make-menu) - (easy-menu-add mh-identity-menu)) - - (setq mh-sent-from-folder sent-from-folder) - (setq mh-sent-from-msg sent-from-msg) - (setq mh-send-args send-args) - (setq mh-annotate-char annotate-char) - (setq mh-annotate-field annotate-field) - (setq mh-previous-window-config config) - (setq mode-line-buffer-identification (list "{%b}")) - (if (and (boundp 'mh-compose-letter-function) - mh-compose-letter-function) - ;; run-hooks will not pass arguments. - (let ((value mh-compose-letter-function)) - (if (and (listp value) (not (eq (car value) 'lambda))) - (while value - (funcall (car value) to subject cc) - (setq value (cdr value))) - (funcall mh-compose-letter-function to subject cc))))) - -(defun mh-letter-mode-message () - "Display a help message for users of `mh-letter-mode'. -This should be the last function called when composing the draft." - (message "%s" (substitute-command-keys - (concat "Type \\[mh-send-letter] to send message, " - "\\[mh-help] for help.")))) - -;;;###mh-autoload -(defun mh-send-letter (&optional arg) - "Send the draft letter in the current buffer. -If optional prefix argument ARG is provided, monitor delivery. -The value of `mh-before-send-letter-hook' is a list of functions to be called, -with no arguments, before doing anything. -Run `\\[mh-edit-mhn]' if variable `mh-mhn-compose-insert-flag' is set. -Run `\\[mh-mml-to-mime]' if variable `mh-mml-compose-insert-flag' is set. -Insert X-Mailer field if variable `mh-insert-x-mailer-flag' is set. -Insert X-Face field if the file specified by `mh-x-face-file' exists." - (interactive "P") - (run-hooks 'mh-before-send-letter-hook) - (cond - ((and (boundp 'mh-mhn-compose-insert-flag) - mh-mhn-compose-insert-flag) - (mh-edit-mhn)) - ((and (boundp 'mh-mml-compose-insert-flag) - mh-mml-compose-insert-flag) - (mh-mml-to-mime))) - (if mh-insert-x-mailer-flag (mh-insert-x-mailer)) - (mh-insert-x-face) - (save-buffer) - (message "Sending...") - (let ((draft-buffer (current-buffer)) - (file-name buffer-file-name) - (config mh-previous-window-config) - (coding-system-for-write - (if (and (local-variable-p 'buffer-file-coding-system - (current-buffer)) ;XEmacs needs two args - ;; We're not sure why, but buffer-file-coding-system - ;; tends to get set to undecided-unix. - (not (memq buffer-file-coding-system - '(undecided undecided-unix undecided-dos)))) - buffer-file-coding-system - (or (and (boundp 'sendmail-coding-system) sendmail-coding-system) - (and (boundp 'default-buffer-file-coding-system ) - default-buffer-file-coding-system) - 'iso-latin-1)))) - ;; The default BCC encapsulation will make a MIME message unreadable. - ;; With nmh use the -mime arg to prevent this. - (if (and mh-nmh-flag - (mh-goto-header-field "Bcc:") - (mh-goto-header-field "Content-Type:")) - (setq mh-send-args (format "-mime %s" mh-send-args))) - (cond (arg - (pop-to-buffer "MH mail delivery") - (erase-buffer) - (mh-exec-cmd-output mh-send-prog t "-watch" "-nopush" - "-nodraftfolder" mh-send-args file-name) - (goto-char (point-max)) ; show the interesting part - (recenter -1) - (set-buffer draft-buffer)) ; for annotation below - (t - (mh-exec-cmd-daemon mh-send-prog "-nodraftfolder" "-noverbose" - mh-send-args file-name))) - (if mh-annotate-char - (mh-annotate-msg mh-sent-from-msg - mh-sent-from-folder - mh-annotate-char - "-component" mh-annotate-field - "-text" (format "\"%s %s\"" - (mh-get-header-field "To:") - (mh-get-header-field "Cc:")))) - - (cond ((or (not arg) - (y-or-n-p "Kill draft buffer? ")) - (kill-buffer draft-buffer) - (if config - (set-window-configuration config)))) - (if arg - (message "Sending...done") - (message "Sending...backgrounded")))) - -;;;###mh-autoload -(defun mh-insert-letter (folder message verbatim) - "Insert a message into the current letter. -Removes the header fields according to the variable `mh-invisible-headers'. -Prefixes each non-blank line with `mh-ins-buf-prefix', unless -`mh-yank-from-start-of-msg' is set for supercite in which case supercite is -used to format the message. -Prompts for FOLDER and MESSAGE. If prefix argument VERBATIM provided, do -not indent and do not delete headers. Leaves the mark before the letter -and point after it." - (interactive - (list (mh-prompt-for-folder "Message from" mh-sent-from-folder nil) - (read-input (format "Message number%s: " - (if (numberp mh-sent-from-msg) - (format " [%d]" mh-sent-from-msg) - ""))) - current-prefix-arg)) - (save-restriction - (narrow-to-region (point) (point)) - (let ((start (point-min))) - (if (equal message "") (setq message (int-to-string mh-sent-from-msg))) - (insert-file-contents - (expand-file-name message (mh-expand-file-name folder))) - (when (not verbatim) - (mh-clean-msg-header start mh-invisible-headers mh-visible-headers) - (goto-char (point-max)) ;Needed for sc-cite-original - (push-mark) ;Needed for sc-cite-original - (goto-char (point-min)) ;Needed for sc-cite-original - (mh-insert-prefix-string mh-ins-buf-prefix))))) - -(defun mh-extract-from-attribution () - "Extract phrase or comment from From header field." - (save-excursion - (if (not (mh-goto-header-field "From: ")) - nil - (skip-chars-forward " ") - (cond - ((looking-at "\"\\([^\"\n]+\\)\" \\(<.+>\\)") - (format "%s %s %s" (match-string 1)(match-string 2) - mh-extract-from-attribution-verb)) - ((looking-at "\\([^<\n]+<.+>\\)$") - (format "%s %s" (match-string 1) mh-extract-from-attribution-verb)) - ((looking-at "\\([^ ]+@[^ ]+\\) +(\\(.+\\))$") - (format "%s <%s> %s" (match-string 2)(match-string 1) - mh-extract-from-attribution-verb)) - ((looking-at " *\\(.+\\)$") - (format "%s %s" (match-string 1) mh-extract-from-attribution-verb)))))) - -;;;###mh-autoload -(defun mh-yank-cur-msg () - "Insert the current message into the draft buffer. -Prefix each non-blank line in the message with the string in -`mh-ins-buf-prefix'. If a region is set in the message's buffer, then -only the region will be inserted. Otherwise, the entire message will -be inserted if `mh-yank-from-start-of-msg' is non-nil. If this variable -is nil, the portion of the message following the point will be yanked. -If `mh-delete-yanked-msg-window-flag' is non-nil, any window displaying the -yanked message will be deleted." - (interactive) - (if (and mh-sent-from-folder - (save-excursion (set-buffer mh-sent-from-folder) mh-show-buffer) - (save-excursion (set-buffer mh-sent-from-folder) - (get-buffer mh-show-buffer)) - mh-sent-from-msg) - (let ((to-point (point)) - (to-buffer (current-buffer))) - (set-buffer mh-sent-from-folder) - (if mh-delete-yanked-msg-window-flag - (delete-windows-on mh-show-buffer)) - (set-buffer mh-show-buffer) ; Find displayed message - (let* ((from-attr (mh-extract-from-attribution)) - (yank-region (mh-mark-active-p nil)) - (mh-ins-str - (cond ((and yank-region - (or (eq 'supercite mh-yank-from-start-of-msg) - (eq 'autosupercite mh-yank-from-start-of-msg) - (eq t mh-yank-from-start-of-msg))) - ;; supercite needs the full header - (concat - (buffer-substring (point-min) (mail-header-end)) - "\n" - (buffer-substring (region-beginning) (region-end)))) - (yank-region - (buffer-substring (region-beginning) (region-end))) - ((or (eq 'body mh-yank-from-start-of-msg) - (eq 'attribution - mh-yank-from-start-of-msg) - (eq 'autoattrib - mh-yank-from-start-of-msg)) - (buffer-substring - (save-excursion - (goto-char (point-min)) - (mh-goto-header-end 1) - (point)) - (point-max))) - ((or (eq 'supercite mh-yank-from-start-of-msg) - (eq 'autosupercite mh-yank-from-start-of-msg) - (eq t mh-yank-from-start-of-msg)) - (buffer-substring (point-min) (point-max))) - (t - (buffer-substring (point) (point-max)))))) - (set-buffer to-buffer) - (save-restriction - (narrow-to-region to-point to-point) - (insert (mh-filter-out-non-text mh-ins-str)) - (goto-char (point-max)) ;Needed for sc-cite-original - (push-mark) ;Needed for sc-cite-original - (goto-char (point-min)) ;Needed for sc-cite-original - (mh-insert-prefix-string mh-ins-buf-prefix) - (if (or (eq 'attribution mh-yank-from-start-of-msg) - (eq 'autoattrib mh-yank-from-start-of-msg)) - (insert from-attr "\n\n")) - ;; If the user has selected a region, he has already "edited" the - ;; text, so leave the cursor at the end of the yanked text. In - ;; either case, leave a mark at the opposite end of the included - ;; text to make it easy to jump or delete to the other end of the - ;; text. - (push-mark) - (goto-char (point-max)) - (if (null yank-region) - (mh-exchange-point-and-mark-preserving-active-mark))))) - (error "There is no current message"))) - -(defun mh-filter-out-non-text (string) - "Return STRING but without adornments such as MIME buttons and smileys." - (with-temp-buffer - ;; Insert the string to filter - (insert string) - (goto-char (point-min)) - - ;; Remove the MIME buttons - (let ((can-move-forward t) - (in-button nil)) - (while can-move-forward - (cond ((and (not (get-text-property (point) 'mh-data)) - in-button) - (delete-region (1- (point)) (point)) - (setq in-button nil)) - ((get-text-property (point) 'mh-data) - (delete-region (point) - (save-excursion (forward-line) (point))) - (setq in-button t)) - (t (setq can-move-forward (= (forward-line) 0)))))) - - ;; Return the contents without properties... This gets rid of emphasis - ;; and smileys - (buffer-substring-no-properties (point-min) (point-max)))) - -(defun mh-insert-prefix-string (mh-ins-string) - "Insert prefix string before each line in buffer. -The inserted letter is cited using `sc-cite-original' if -`mh-yank-from-start-of-msg' is one of 'supercite or 'autosupercite. Otherwise, -simply insert MH-INS-STRING before each line." - (goto-char (point-min)) - (cond ((or (eq mh-yank-from-start-of-msg 'supercite) - (eq mh-yank-from-start-of-msg 'autosupercite)) - (sc-cite-original)) - (mail-citation-hook - (run-hooks 'mail-citation-hook)) - (mh-yank-hooks ;old hook name - (run-hooks 'mh-yank-hooks)) - (t - (or (bolp) (forward-line 1)) - (while (< (point) (point-max)) - (insert mh-ins-string) - (forward-line 1)) - (goto-char (point-min))))) ;leave point like sc-cite-original - -;;;###mh-autoload -(defun mh-fully-kill-draft () - "Kill the draft message file and the draft message buffer. -Use \\[kill-buffer] if you don't want to delete the draft message file." - (interactive) - (if (y-or-n-p "Kill draft message? ") - (let ((config mh-previous-window-config)) - (if (file-exists-p buffer-file-name) - (delete-file buffer-file-name)) - (set-buffer-modified-p nil) - (kill-buffer (buffer-name)) - (message "") - (if config - (set-window-configuration config))) - (error "Message not killed"))) - -(defun mh-current-fill-prefix () - "Return the `fill-prefix' on the current line as a string." - (save-excursion - (beginning-of-line) - ;; This assumes that the major-mode sets up adaptive-fill-regexp - ;; correctly such as mh-letter-mode or sendmail.el's mail-mode. But - ;; perhaps I should use the variable and simply inserts its value here, - ;; and set it locally in a let scope. --psg - (if (re-search-forward adaptive-fill-regexp nil t) - (match-string 0) - ""))) - -;;;###mh-autoload -(defun mh-open-line () - "Insert a newline and leave point after it. -In addition, insert newline and quoting characters before text after point. -This is useful in breaking up paragraphs in replies." - (interactive) - (let ((column (current-column)) - (prefix (mh-current-fill-prefix))) - (if (> (length prefix) column) - (message "Sorry, point seems to be within the line prefix") - (newline 2) - (insert prefix) - (while (> column (current-column)) - (insert " ")) - (forward-line -1)))) - -;;;###mh-autoload -(defun mh-letter-complete (arg) - "Perform completion on header field or word preceding point. -Alias completion is done within the mail header on selected fields and -by the function designated by `mh-letter-complete-function' elsewhere, -passing the prefix ARG if any." - (interactive "P") - (let ((case-fold-search t)) - (if (and (mh-in-header-p) - (save-excursion - (mh-header-field-beginning) - (looking-at "^.*\\(to\\|cc\\|from\\):"))) - (mh-alias-letter-expand-alias) - (funcall mh-letter-complete-function arg)))) - -;;; Build the letter-mode keymap: -;;; If this changes, modify mh-letter-mode-help-messages accordingly, above. -(gnus-define-keys mh-letter-mode-map - "\C-c?" mh-help - "\C-c\C-c" mh-send-letter - "\C-c\C-d" mh-insert-identity - "\C-c\C-e" mh-edit-mhn - "\C-c\C-f\C-b" mh-to-field - "\C-c\C-f\C-c" mh-to-field - "\C-c\C-f\C-d" mh-to-field - "\C-c\C-f\C-f" mh-to-fcc - "\C-c\C-f\C-r" mh-to-field - "\C-c\C-f\C-s" mh-to-field - "\C-c\C-f\C-t" mh-to-field - "\C-c\C-fb" mh-to-field - "\C-c\C-fc" mh-to-field - "\C-c\C-fd" mh-to-field - "\C-c\C-ff" mh-to-fcc - "\C-c\C-fr" mh-to-field - "\C-c\C-fs" mh-to-field - "\C-c\C-ft" mh-to-field - "\C-c\C-i" mh-insert-letter - "\C-c\C-m\C-e" mh-mml-secure-message-encrypt-pgpmime - "\C-c\C-m\C-f" mh-compose-forward - "\C-c\C-m\C-i" mh-compose-insertion - "\C-c\C-m\C-m" mh-mml-to-mime - "\C-c\C-m\C-s" mh-mml-secure-message-sign-pgpmime - "\C-c\C-m\C-u" mh-revert-mhn-edit - "\C-c\C-me" mh-mml-secure-message-encrypt-pgpmime - "\C-c\C-mf" mh-compose-forward - "\C-c\C-mi" mh-compose-insertion - "\C-c\C-mm" mh-mml-to-mime - "\C-c\C-ms" mh-mml-secure-message-sign-pgpmime - "\C-c\C-mu" mh-revert-mhn-edit - "\C-c\C-o" mh-open-line - "\C-c\C-q" mh-fully-kill-draft - "\C-c\C-\\" mh-fully-kill-draft ;if no C-q - "\C-c\C-s" mh-insert-signature - "\C-c\C-^" mh-insert-signature ;if no C-s - "\C-c\C-w" mh-check-whom - "\C-c\C-y" mh-yank-cur-msg - "\M-\t" mh-letter-complete) - -;; "C-c /" prefix is used in mh-letter-mode by pgp.el and mailcrypt.el. - -(provide 'mh-comp) - -;;; Local Variables: -;;; indent-tabs-mode: nil -;;; sentence-end-double-space: nil -;;; End: - -;;; mh-comp.el ends here
--- a/lisp/mail/mh-customize.el Sun Jan 26 01:33:33 2003 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1751 +0,0 @@ -;;; mh-customize.el --- MH-E customization - -;; Copyright (C) 2002 Free Software Foundation, Inc. - -;; Author: Bill Wohler <wohler@newt.com> -;; Maintainer: Bill Wohler <wohler@newt.com> -;; Keywords: mail -;; See: mh-e.el - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; All of the defgroups, defcustoms, and deffaces in MH-E are found here. This -;; makes it possible to customize modules that aren't loaded yet. It also -;; makes it easier to organize the customization groups. - -;; This file contains the following sections: -;; -;; 1. MH-E Customization Groups -;; -;; These are the customization group definitions. These are organized in a -;; logical order. High-level, windows and toolbar, folder, message, -;; composing and hooks. -;; -;; 2. MH-E Customization -;; -;; Here are the actual customization variables. There is a sub-section for -;; each group in the MH-E Customization Groups section. Within each -;; section, variables are sorted alphabetically. The manual section -;; dictates which group a variable should be placed. New variables should -;; be placed in the section where they would most likely be defined. -;; -;; All hooks should be placed in the 'mh-hook group; in addition, add the -;; group in which the hook is defined in the manual (or, if it is new, -;; where it would be defined). These two actions insures that the hooks -;; appear last in each group. -;; -;; 3. Faces - -;;; Change Log: - -;; $Id: mh-customize.el,v 1.18 2003/01/08 00:45:37 wohler Exp $ - -;;; Code: - -;;;###mh-autoload -(defun mh-customize () - "Customize MH-E variables." - (interactive) - (customize-group 'mh)) - -;;; MH-E Customization Groups - -(defgroup mh nil - "GNU Emacs interface to the MH mail system." - :link '(custom-manual "(mh-e)Top") - :group 'mail) - -(defgroup mh-toolbar nil - "Toolbar configuration." - :prefix "mh-" - :group 'mh) - -(defgroup mh-speed nil - "Speedbar and folder configuration." - :prefix "mh-" - :link '(custom-manual "(mh-e)Customizing Moving Mail") - :group 'mh) - -(defgroup mh-folder nil - "Options for controlling scan listing." - :prefix "mh-" - :link '(custom-manual "(mh-e)Customizing Moving Mail") - :group 'mh) - -(defgroup mh-show nil - "Message display." - :prefix "mh-" - :link '(custom-manual "(mh-e)Customizing Reading") - :group 'mh) - -(defgroup mh-letter nil - "Composing messages." - :prefix "mh-" - :link '(custom-manual "(mh-e)Customizing Sending") - :group 'mh) - -(defgroup mh-alias nil - "Alias handling." - :link '(custom-manual "(mh-e)Customizing mh-e") - :prefix "mh-alias-" - :group 'mh) - -(defgroup mh-index nil - "Indexed searching." - :link '(custom-manual "(mh-e)Customizing mh-e") - :prefix "mh-" - :group 'mh) - -(defgroup mh-identity nil - "Multiple personalities." - :link '(custom-manual "(mh-e)Customizing mh-e") - :prefix "mh-" - :group 'mh) - -(defgroup mh-faces nil - "Faces used in MH-E." - :link '(custom-manual "(mh-e)Customizing mh-e") - :prefix "mh-" - :group 'faces - :group 'mh) - -(defgroup mh-hooks nil - "MH-E hooks." - :link '(custom-manual "(mh-e)Customizing mh-e") - :prefix "mh-" - :group 'mh) - -;;; Faces - -(defgroup mh-speed-faces nil - "Faces used in speedbar." - :link '(custom-manual "(mh-e)Customizing mh-e") - :prefix "mh-" - :group 'mh-faces - :group 'mh-speed) - -(defgroup mh-folder-faces nil - "Faces used in scan listing." - :link '(custom-manual "(mh-e)Customizing mh-e") - :prefix "mh-" - :group 'mh-faces - :group 'mh-folder) - -(defgroup mh-show-faces nil - "Faces used in message display." - :link '(custom-manual "(mh-e)Customizing mh-e") - :prefix "mh-" - :group 'mh-faces - :group 'mh-show) - -(defgroup mh-index-faces nil - "Faces used in indexed searches." - :link '(custom-manual "(mh-e)Customizing mh-e") - :prefix "mh-" - :group 'mh-faces - :group 'mh-index) - - - -;;; MH-E Customization (:group mh) - -;;; Toolbar configuration (:group 'mh-toolbar) - -(defconst mh-tool-bar-item-inc "Incorporate new mail in Inbox") -(defconst mh-tool-bar-item-save-mime "Save MIME parts") -(defconst mh-tool-bar-item-prev-msg "Previous message") -(defconst mh-tool-bar-item-page-msg "Page this message") -(defconst mh-tool-bar-item-next-msg "Next message") -(defconst mh-tool-bar-item-delete "Mark for deletion") -(defconst mh-tool-bar-item-refile "Refile this message") -(defconst mh-tool-bar-item-undo "Undo this mark") -(defconst mh-tool-bar-item-perform "Perform moves and deletes") -(defconst mh-tool-bar-item-toggle-show "Toggle showing message") -(defconst mh-tool-bar-item-reply-from "Reply to \"from\"") -(defconst mh-tool-bar-item-reply-to "Reply to \"to\"") -(defconst mh-tool-bar-item-reply-all "Reply to \"all\"") -(defconst mh-tool-bar-item-reply "Reply to this message") -(defconst mh-tool-bar-item-alias "Grab From alias") -(defconst mh-tool-bar-item-compose "Compose new message") -(defconst mh-tool-bar-item-rescan "Rescan this folder") -(defconst mh-tool-bar-item-repack "Repack this folder") -(defconst mh-tool-bar-item-search "Search") -(defconst mh-tool-bar-item-visit "Visit other folder") -(defconst mh-tool-bar-item-prefs "MH-E preferences") -(defconst mh-tool-bar-item-help "Help") -(defconst mh-tool-bar-item-widen "Widen from this sequence") - -(defconst mh-tool-bar-item-send "Send this letter") -(defconst mh-tool-bar-item-attach "Insert attachment") -(defconst mh-tool-bar-item-spell "Check spelling") -(defconst mh-tool-bar-item-save "Save current buffer to its file") -(defconst mh-tool-bar-item-undo-op "Undo last operation") -(defconst mh-tool-bar-item-kill - "Cut (kill) text in region between mark and current position") -(defconst mh-tool-bar-item-copy - "Copy text in region between mark and current position") -(defconst mh-tool-bar-item-paste - "Paste (yank) text cut or copied earlier") -(defconst mh-tool-bar-item-kill-draft "Kill this draft") -(defconst mh-tool-bar-item-comp-prefs "MH-E composition preferences") - -(defcustom mh-tool-bar-reply-3-buttons-flag nil - "*Non-nil means use three buttons for reply commands in tool-bar. -If you have room on your tool-bar because you are using a large font, you -may set this variable to expand the single reply button into three buttons -that won't lead to minibuffer prompt about who to reply to." - :type 'boolean - :group 'mh-toolbar) - -(defcustom mh-tool-bar-search-function 'mh-search-folder - "*Function called by the tool-bar search button. -See `mh-search-folder' and `mh-index-search' for details." - :type '(choice (const mh-search-folder) - (const mh-index-search) - (function :tag "Other function")) - :group 'mh-toolbar) - -(eval-when-compile (defvar tool-bar-map)) -(defvar mh-show-tool-bar-map nil) -(defun mh-tool-bar-show-set () - "Construct toolbar for `mh-show-mode'." - (when (fboundp 'tool-bar-add-item) - (setq - mh-show-tool-bar-map - (let ((tool-bar-map (make-sparse-keymap))) - (if (member mh-tool-bar-item-inc mh-tool-bar-folder-buttons) - (tool-bar-add-item "mail" 'mh-inc-folder 'mh-showtoolbar-inc-folder - :help mh-tool-bar-item-inc)) - (if (member mh-tool-bar-item-save-mime mh-tool-bar-folder-buttons) - (tool-bar-add-item "attach" 'mh-mime-save-parts - 'mh-showtoolbar-mime-save-parts - :help mh-tool-bar-item-save-mime)) - (if (member mh-tool-bar-item-prev-msg mh-tool-bar-folder-buttons) - (tool-bar-add-item "left_arrow" 'mh-show-previous-undeleted-msg - 'mh-showtoolbar-prev - :help mh-tool-bar-item-prev-msg)) - (if (member mh-tool-bar-item-page-msg mh-tool-bar-folder-buttons) - (tool-bar-add-item "page-down" 'mh-show-page-msg 'mh-showtoolbar-page - :help mh-tool-bar-item-page-msg)) - (if (member mh-tool-bar-item-next-msg mh-tool-bar-folder-buttons) - (tool-bar-add-item "right_arrow" 'mh-show-next-undeleted-msg - 'mh-showtoolbar-next - :help mh-tool-bar-item-next-msg)) - (if (member mh-tool-bar-item-delete mh-tool-bar-folder-buttons) - (tool-bar-add-item "close" 'mh-show-delete-msg - 'mh-showtoolbar-delete - :help mh-tool-bar-item-delete)) - (if (member mh-tool-bar-item-refile mh-tool-bar-folder-buttons) - (tool-bar-add-item "refile" 'mh-show-refile-msg - 'mh-showtoolbar-refile - :help mh-tool-bar-item-refile)) - (if (member mh-tool-bar-item-undo mh-tool-bar-folder-buttons) - (tool-bar-add-item "undo" 'mh-show-undo 'mh-showtoolbar-undo - :help mh-tool-bar-item-undo)) - (if (member mh-tool-bar-item-perform mh-tool-bar-folder-buttons) - (tool-bar-add-item "execute" 'mh-show-execute-commands - 'mh-showtoolbar-exec - :help mh-tool-bar-item-perform)) - (if (member mh-tool-bar-item-toggle-show mh-tool-bar-folder-buttons) - (tool-bar-add-item "show" 'mh-show-toggle-showing - 'mh-showtoolbar-toggle-show - :help mh-tool-bar-item-toggle-show)) - (if (member mh-tool-bar-item-reply-from mh-tool-bar-folder-buttons) - (tool-bar-add-item "reply-from" - (lambda (&optional arg) - (interactive "P") - (set-buffer mh-show-folder-buffer) - (mh-reply (mh-get-msg-num nil) "from" arg)) - 'mh-showtoolbar-reply-from - :help mh-tool-bar-item-reply-from)) - (if (member mh-tool-bar-item-reply-to mh-tool-bar-folder-buttons) - (tool-bar-add-item "reply-to" - (lambda (&optional arg) - (interactive "P") - (set-buffer mh-show-folder-buffer) - (mh-reply (mh-get-msg-num nil) "to" arg)) - 'mh-showtoolbar-reply-to - :help mh-tool-bar-item-reply-to)) - (if (member mh-tool-bar-item-reply-all mh-tool-bar-folder-buttons) - (tool-bar-add-item "reply-all" - (lambda (&optional arg) - (interactive "P") - (set-buffer mh-show-folder-buffer) - (mh-reply (mh-get-msg-num nil) "all" arg)) - 'mh-showtoolbar-reply-all - :help mh-tool-bar-item-reply-all)) - (if (member mh-tool-bar-item-reply mh-tool-bar-folder-buttons) - (tool-bar-add-item "mail/reply2" 'mh-show-reply - 'mh-showtoolbar-reply - :help mh-tool-bar-item-reply)) - (if (member mh-tool-bar-item-alias mh-tool-bar-folder-buttons) - (tool-bar-add-item "alias" 'mh-alias-grab-from-field - 'mh-showtoolbar-alias - :help mh-tool-bar-item-alias - :enable '(mh-alias-from-has-no-alias-p))) - (if (member mh-tool-bar-item-compose mh-tool-bar-folder-buttons) - (tool-bar-add-item "mail_compose" 'mh-send 'mh-showtoolbar-compose - :help mh-tool-bar-item-compose)) - (if (member mh-tool-bar-item-rescan mh-tool-bar-folder-buttons) - (tool-bar-add-item "rescan" 'mh-show-rescan-folder - 'mh-showtoolbar-rescan - :help mh-tool-bar-item-rescan)) - (if (member mh-tool-bar-item-repack mh-tool-bar-folder-buttons) - (tool-bar-add-item "repack" 'mh-show-pack-folder - 'mh-showtoolbar-pack - :help mh-tool-bar-item-repack)) - (if (member mh-tool-bar-item-search mh-tool-bar-folder-buttons) - (tool-bar-add-item "search" - (lambda (&optional arg) - (interactive "P") - (call-interactively - mh-tool-bar-search-function)) - 'mh-showtoolbar-search - :help mh-tool-bar-item-search)) - (if (member mh-tool-bar-item-visit mh-tool-bar-folder-buttons) - (tool-bar-add-item "fld_open" 'mh-visit-folder - 'mh-showtoolbar-visit - :help mh-tool-bar-item-visit)) - (if (member mh-tool-bar-item-prefs mh-tool-bar-folder-buttons) - (tool-bar-add-item "preferences" (lambda () - (interactive) - (customize-group "mh")) - 'mh-showtoolbar-customize - :help mh-tool-bar-item-prefs)) - (if (member mh-tool-bar-item-help mh-tool-bar-folder-buttons) - (tool-bar-add-item "help" (lambda () - (interactive) - (Info-goto-node "(mh-e)Top")) - 'mh-showtoolbar-help - :help mh-tool-bar-item-help)) - tool-bar-map)))) - -(defvar mh-letter-tool-bar-map nil) -;;;###mh-autoload -(defun mh-tool-bar-letter-set () - "Construct toolbar for `mh-letter-mode'." - (when (fboundp 'tool-bar-add-item) - (setq - mh-letter-tool-bar-map - (let ((tool-bar-map (make-sparse-keymap))) - (if (member mh-tool-bar-item-send mh-tool-bar-letter-buttons) - (tool-bar-add-item "mail_send" 'mh-send-letter - 'mh-lettertoolbar-send - :help mh-tool-bar-item-send)) - (if (member mh-tool-bar-item-attach mh-tool-bar-letter-buttons) - (tool-bar-add-item "attach" 'mh-compose-insertion - 'mh-lettertoolbar-compose - :help mh-tool-bar-item-attach)) - (if (member mh-tool-bar-item-spell mh-tool-bar-letter-buttons) - (tool-bar-add-item "spell" 'ispell-message 'mh-lettertoolbar-ispell - :help mh-tool-bar-item-spell)) - (if (member mh-tool-bar-item-save mh-tool-bar-letter-buttons) - (tool-bar-add-item-from-menu 'save-buffer "save")) - (if (member mh-tool-bar-item-undo-op mh-tool-bar-letter-buttons) - (tool-bar-add-item-from-menu 'undo "undo")) - (if (member mh-tool-bar-item-kill mh-tool-bar-letter-buttons) - (tool-bar-add-item-from-menu 'kill-region "cut")) - (if (member mh-tool-bar-item-copy mh-tool-bar-letter-buttons) - (tool-bar-add-item-from-menu 'menu-bar-kill-ring-save "copy")) - (if (member mh-tool-bar-item-paste mh-tool-bar-letter-buttons) - (tool-bar-add-item-from-menu 'yank "paste")) - (if (member mh-tool-bar-item-kill-draft mh-tool-bar-letter-buttons) - (tool-bar-add-item "close" 'mh-fully-kill-draft - 'mh-lettertoolbar-kill - :help mh-tool-bar-item-kill-draft)) - (if (member mh-tool-bar-item-comp-prefs mh-tool-bar-letter-buttons) - (tool-bar-add-item "preferences" (lambda () - (interactive) - (customize-group "mh-compose")) - 'mh-lettertoolbar-customize - :help mh-tool-bar-item-comp-prefs)) - (if (member mh-tool-bar-item-help mh-tool-bar-letter-buttons) - (tool-bar-add-item "help" (lambda () - (interactive) - (Info-goto-node "(mh-e)Draft Editing")) - 'mh-lettertoolbar-help - :help mh-tool-bar-item-help)) - tool-bar-map)))) - -(defvar mh-folder-tool-bar-map nil) -(defvar mh-folder-seq-tool-bar-map nil - "Tool-bar to use when narrowed to a sequence in MH-Folder buffers.") -;;;###mh-autoload -(defun mh-tool-bar-folder-set () - "Construct toolbar for `mh-folder-mode'." - (when (fboundp 'tool-bar-add-item) - (setq - mh-folder-tool-bar-map - (let ((tool-bar-map (make-sparse-keymap))) - (if (member mh-tool-bar-item-inc mh-tool-bar-folder-buttons) - (tool-bar-add-item "mail" 'mh-inc-folder - 'mh-foldertoolbar-inc-folder - :help mh-tool-bar-item-inc)) - (if (member mh-tool-bar-item-save-mime mh-tool-bar-folder-buttons) - (tool-bar-add-item "attach" 'mh-mime-save-parts - 'mh-foldertoolbar-mime-save-parts - :help mh-tool-bar-item-save-mime)) - (if (member mh-tool-bar-item-prev-msg mh-tool-bar-folder-buttons) - (tool-bar-add-item "left_arrow" 'mh-previous-undeleted-msg - 'mh-foldertoolbar-prev - :help mh-tool-bar-item-prev-msg)) - (if (member mh-tool-bar-item-page-msg mh-tool-bar-folder-buttons) - (tool-bar-add-item "page-down" 'mh-page-msg 'mh-foldertoolbar-page - :help mh-tool-bar-item-page-msg)) - (if (member mh-tool-bar-item-next-msg mh-tool-bar-folder-buttons) - (tool-bar-add-item "right_arrow" 'mh-next-undeleted-msg - 'mh-foldertoolbar-next - :help mh-tool-bar-item-next-msg)) - (if (member mh-tool-bar-item-delete mh-tool-bar-folder-buttons) - (tool-bar-add-item "close" 'mh-delete-msg 'mh-foldertoolbar-delete - :help mh-tool-bar-item-delete)) - (if (member mh-tool-bar-item-refile mh-tool-bar-folder-buttons) - (tool-bar-add-item "refile" 'mh-refile-msg 'mh-foldertoolbar-refile - :help mh-tool-bar-item-refile)) - (if (member mh-tool-bar-item-undo mh-tool-bar-folder-buttons) - (tool-bar-add-item "undo" 'mh-undo 'mh-foldertoolbar-undo - :help mh-tool-bar-item-undo)) - (if (member mh-tool-bar-item-perform mh-tool-bar-folder-buttons) - (tool-bar-add-item "execute" 'mh-execute-commands - 'mh-foldertoolbar-exec - :help mh-tool-bar-item-perform)) - (if (member mh-tool-bar-item-toggle-show mh-tool-bar-folder-buttons) - (tool-bar-add-item "show" 'mh-toggle-showing - 'mh-foldertoolbar-toggle-show - :help mh-tool-bar-item-toggle-show)) - (if (member mh-tool-bar-item-reply-from mh-tool-bar-folder-buttons) - (tool-bar-add-item "reply-from" - (lambda (&optional arg) - (interactive "P") - (mh-reply (mh-get-msg-num nil) "from" arg)) - 'mh-foldertoolbar-reply-from - :help mh-tool-bar-item-reply-from)) - (if (member mh-tool-bar-item-reply-to mh-tool-bar-folder-buttons) - (tool-bar-add-item "reply-to" - (lambda (&optional arg) - (interactive "P") - (mh-reply (mh-get-msg-num nil) "to" arg)) - 'mh-foldertoolbar-reply-to - :help mh-tool-bar-item-reply-to)) - (if (member mh-tool-bar-item-reply-all mh-tool-bar-folder-buttons) - (tool-bar-add-item "reply-all" - (lambda (&optional arg) - (interactive "P") - (mh-reply (mh-get-msg-num nil) "all" arg)) - 'mh-foldertoolbar-reply-all - :help mh-tool-bar-item-reply-all)) - (if (member mh-tool-bar-item-reply mh-tool-bar-folder-buttons) - (tool-bar-add-item "mail/reply2" 'mh-reply - 'mh-foldertoolbar-reply - :help mh-tool-bar-item-reply)) - (if (member mh-tool-bar-item-alias mh-tool-bar-folder-buttons) - (tool-bar-add-item "alias" 'mh-alias-grab-from-field - 'mh-foldertoolbar-alias - :help mh-tool-bar-item-alias - :enable '(mh-alias-from-has-no-alias-p))) - (if (member mh-tool-bar-item-compose mh-tool-bar-folder-buttons) - (tool-bar-add-item "mail_compose" 'mh-send 'mh-foldertoolbar-compose - :help mh-tool-bar-item-compose)) - (if (member mh-tool-bar-item-rescan mh-tool-bar-folder-buttons) - (tool-bar-add-item "rescan" 'mh-rescan-folder - 'mh-foldertoolbar-rescan - :help mh-tool-bar-item-rescan)) - (if (member mh-tool-bar-item-repack mh-tool-bar-folder-buttons) - (tool-bar-add-item "repack" 'mh-pack-folder 'mh-foldertoolbar-pack - :help mh-tool-bar-item-repack)) - (if (member mh-tool-bar-item-search mh-tool-bar-folder-buttons) - (tool-bar-add-item "search" - (lambda (&optional arg) - (interactive "P") - (call-interactively - mh-tool-bar-search-function)) - 'mh-foldertoolbar-search - :help mh-tool-bar-item-search)) - (if (member mh-tool-bar-item-visit mh-tool-bar-folder-buttons) - (tool-bar-add-item "fld_open" 'mh-visit-folder - 'mh-foldertoolbar-visit - :help mh-tool-bar-item-visit)) - (if (member mh-tool-bar-item-prefs mh-tool-bar-folder-buttons) - (tool-bar-add-item "preferences" (lambda () - (interactive) - (customize-group "mh")) - 'mh-foldertoolbar-customize - :help mh-tool-bar-item-prefs)) - (if (member mh-tool-bar-item-help mh-tool-bar-folder-buttons) - (tool-bar-add-item "help" (lambda () - (interactive) - (Info-goto-node "(mh-e)Top")) - 'mh-foldertoolbar-help - :help mh-tool-bar-item-help)) - tool-bar-map)) - - (setq mh-folder-seq-tool-bar-map - (let ((tool-bar-map (copy-keymap mh-folder-tool-bar-map))) - (if (member mh-tool-bar-item-widen mh-tool-bar-folder-buttons) - (tool-bar-add-item "widen" 'mh-widen 'mh-foldertoolbar-widen - :help mh-tool-bar-item-widen)) - tool-bar-map)))) - -(defun mh-tool-bar-folder-buttons-set (symbol value) - "Update the `mh-tool-bar-folder-buttons' variable, and rebuild the tool-bar. -Sets the default for SYMBOL (e.g. `mh-tool-bar-folder-buttons') to VALUE (as -set in customization). This is called after 'customize is used to alter -`mh-tool-bar-folder-buttons'." - (set-default symbol value) - (mh-tool-bar-show-set) - (mh-tool-bar-folder-set)) - -(custom-declare-variable - 'mh-tool-bar-folder-buttons - '(append - (list mh-tool-bar-item-inc - mh-tool-bar-item-save-mime - mh-tool-bar-item-prev-msg - mh-tool-bar-item-page-msg - mh-tool-bar-item-next-msg - mh-tool-bar-item-delete - mh-tool-bar-item-refile - mh-tool-bar-item-undo - mh-tool-bar-item-perform -;;; mh-tool-bar-item-toggle-show - ) - (if mh-tool-bar-reply-3-buttons-flag - (list mh-tool-bar-item-reply-from - mh-tool-bar-item-reply-to - mh-tool-bar-item-reply-all) - (list mh-tool-bar-item-reply)) - (list mh-tool-bar-item-alias - mh-tool-bar-item-compose - mh-tool-bar-item-rescan -;;; mh-tool-bar-item-repack - mh-tool-bar-item-search - mh-tool-bar-item-visit - mh-tool-bar-item-prefs - mh-tool-bar-item-help - mh-tool-bar-item-widen)) - "Buttons to include in MH-E folder/show toolbar." - :group 'mh-toolbar - :set 'mh-tool-bar-folder-buttons-set - :type `(set (const ,mh-tool-bar-item-inc) - (const ,mh-tool-bar-item-save-mime) - (const ,mh-tool-bar-item-prev-msg) - (const ,mh-tool-bar-item-page-msg) - (const ,mh-tool-bar-item-next-msg) - (const ,mh-tool-bar-item-delete) - (const ,mh-tool-bar-item-refile) - (const ,mh-tool-bar-item-undo) - (const ,mh-tool-bar-item-perform) - (const ,mh-tool-bar-item-toggle-show) - (const ,mh-tool-bar-item-reply-from) - (const ,mh-tool-bar-item-reply-to) - (const ,mh-tool-bar-item-reply-all) - (const ,mh-tool-bar-item-reply) - (const ,mh-tool-bar-item-alias) - (const ,mh-tool-bar-item-compose) - (const ,mh-tool-bar-item-rescan) - (const ,mh-tool-bar-item-repack) - (const ,mh-tool-bar-item-search) - (const ,mh-tool-bar-item-visit) - (const ,mh-tool-bar-item-prefs) - (const ,mh-tool-bar-item-help) - (const ,mh-tool-bar-item-widen))) - -(defun mh-tool-bar-letter-buttons-set (symbol value) - "Update the `mh-tool-bar-letter-buttons' variable, and rebuild the tool-bar. -Sets the default for SYMBOL (e.g. `mh-tool-bar-letter-buttons') to VALUE (as -set in customization). This is called after 'customize is used to alter -`mh-tool-bar-letter-buttons'." - (set-default symbol value) - (mh-tool-bar-letter-set)) - -(custom-declare-variable - 'mh-tool-bar-letter-buttons - '(list mh-tool-bar-item-send - mh-tool-bar-item-attach - mh-tool-bar-item-spell - mh-tool-bar-item-save - mh-tool-bar-item-undo-op - mh-tool-bar-item-kill - mh-tool-bar-item-copy - mh-tool-bar-item-paste - mh-tool-bar-item-kill-draft - mh-tool-bar-item-comp-prefs - mh-tool-bar-item-help) - "Buttons to include in MH-E letter toolbar." - :group 'mh-toolbar - :set 'mh-tool-bar-letter-buttons-set - :type `(set (const ,mh-tool-bar-item-send) - (const ,mh-tool-bar-item-attach) - (const ,mh-tool-bar-item-spell) - (const ,mh-tool-bar-item-save) - (const ,mh-tool-bar-item-undo-op) - (const ,mh-tool-bar-item-kill) - (const ,mh-tool-bar-item-copy) - (const ,mh-tool-bar-item-paste) - (const ,mh-tool-bar-item-kill-draft) - (const ,mh-tool-bar-item-comp-prefs) - (const ,mh-tool-bar-item-help))) - - - -;;; Speedbar and folder configuration (:group 'mh-speed) - -(defcustom mh-large-folder 200 - "The number of messages that indicates a large folder. -If a folder is deemed to be large, that is the number of messages in it exceed -this value, then confirmation is needed when it is visited. Even when -`mh-show-threads-flag' is non-nil, the folder is not automatically threaded, if -it is large. If set to nil all folders are treated as if they are small." - :type '(choice (const :tag "No limit") integer) - :group 'mh-speed) - -(defcustom mh-speed-flists-interval 60 - "Time between calls to flists in seconds. -If 0, flists is not called repeatedly." - :type 'integer - :group 'mh-speed) - -(defcustom mh-speed-run-flists-flag t - "Non-nil means flists is used. -If non-nil, flists is executed every `mh-speed-flists-interval' seconds to -update the display of the number of unseen and total messages in each folder. -If resources are limited, this can be set to nil and the speedbar display can -be updated manually with the \\[mh-speed-flists] command." - :type 'boolean - :group 'mh-speed) - -;;; Options for controlling scan listing (:group 'mh-folder) - -(defcustom mh-adaptive-cmd-note-flag t - "*Non-nil means that the message number width is determined dynamically. -This is done once when a folder is first opened by running scan on the last -message of the folder. The message number for the last message is extracted -and its width calculated. This width is used when calling `mh-set-cmd-note'. - -If you prefer fixed-width message numbers, set this variable to nil and call -`mh-set-cmd-note' with the width specified by the scan format in -`mh-scan-format-file'. For example, the default width is 4, so you would use -\"(mh-set-cmd-note 4)\" if `mh-scan-format-file' were nil." - :type 'boolean - :group 'mh-folder) - -(defcustom mh-auto-folder-collect-flag t - "*Non-nil means to collect all folder names at startup in the background. -Otherwise, the internal list of folder names is built as folders are -referenced." - :type 'boolean - :group 'mh-folder) - -(defcustom mh-inc-prog "inc" - "*Program to run to incorporate new mail into a folder. -Normally \"inc\". This file is searched for relative to -the `mh-progs' directory unless it is an absolute pathname." - :type 'string - :group 'mh-folder) - -(defcustom mh-lpr-command-format "lpr -J '%s'" - "*Format for Unix command that prints a message. -The string should be a Unix command line, with the string '%s' where -the job's name (folder and message number) should appear. The formatted -message text is piped to this command when you type \\<mh-folder-mode-map>`\\[mh-print-msg]'." - :type 'string - :group 'mh-folder) - -(defcustom mh-mime-save-parts-default-directory t - "Default directory to use for `mh-mime-save-parts'. -If nil, prompt and set for next time the command is used during same session. -If t, prompt always" - :type '(choice (const :tag "Prompt the first time" nil) - (const :tag "Prompt always" t) - directory) - :group 'mh-folder) - -(defcustom mh-recenter-summary-flag nil - "*Non-nil means to recenter the summary window. -Recenter the summary window when the show window is toggled off if non-nil." - :type 'boolean - :group 'mh-folder) - -(defcustom mh-print-background-flag nil - "*Non-nil means messages should be printed in the background. -WARNING: do not delete the messages until printing is finished; -otherwise, your output may be truncated." - :type 'boolean - :group 'mh-folder) - -(defcustom mh-recursive-folders-flag nil - "*Non-nil means that commands which operate on folders do so recursively." - :type 'boolean - :group 'mh-folder) - -(defcustom mh-scan-format-file t - "Specifies the format file to pass to the scan program. -If t, the format string will be taken from the either `mh-scan-format-mh' -or `mh-scan-format-nmh' depending on whether MH or nmh is in use. -If nil, the default scan output will be used. - -If you customize the scan format, you may need to modify a few variables -containing regexps that MH-E uses to identify specific portions of the output. -Use `M-x apropos RET mh-scan.*regexp' to obtain a list of these variables. You -may also have to call `mh-set-cmd-note' with the width of your message -numbers. See also `mh-adaptive-cmd-note-flag'." - :type '(choice (const :tag "Use MH-E scan format" t) - (const :tag "Use default scan format" nil) - (file :tag "Specify a scan format file")) - :group 'mh-folder) - -(defcustom mh-scan-prog "scan" - "*Program to run to generate one-line-per-message listing of a folder. -Normally \"scan\" or a file name linked to scan. This file is searched -for relative to the `mh-progs' directory unless it is an absolute pathname." - :type 'string - :group 'mh-folder) -(make-variable-buffer-local 'mh-scan-prog) - -(defcustom mh-show-threads-flag nil - "Non-nil means new folders start in threaded mode. -Threading large number of messages can be time consuming. So if the flag is -non-nil then threading will be done only if the number of messages being -threaded is less than `mh-large-folder'." - :type 'boolean - :group 'mh-folder) - -(defcustom mh-store-default-directory nil - "*Last directory used by \\[mh-store-msg]; default for next store. -A directory name string, or nil to use current directory." - :type '(choice (const :tag "Current" nil) - directory) - :group 'mh-folder) - -(defcustom mh-update-sequences-after-mh-show-flag t - "*Non-nil means `mh-update-sequence' is called from `mh-show-mode'. -If set, `mh-update-sequence' is run every time a message is shown, telling -MH or nmh that this is your current message. It's useful, for example, to -display MIME content using \"M-! mhshow RET\"" - :type 'boolean - :group 'mh-folder) - -;;; Message display (:group 'mh-show) - -(defcustom mh-bury-show-buffer-flag t - "*Non-nil means that the displayed show buffer for a folder is buried." - :type 'boolean - :group 'mh-show) - -(defcustom mh-clean-message-header-flag t - "*Non-nil means clean headers of messages that are displayed or inserted. -The variables `mh-invisible-headers' and `mh-visible-headers' control -what is removed." - :type 'boolean - :group 'mh-show) - -(defcustom mh-decode-mime-flag (not (not (locate-library "mm-decode"))) - "*Non-nil means that Gnus is used to show MIME attachments with Gnus." - :type 'boolean - :group 'mh-show) - -(defcustom mh-decode-quoted-printable-flag - (not (null (and (fboundp 'executable-find)(executable-find "mimedecode")))) - "Non-nil means decode quoted-printable MIME part with `mimedecode'. - -Quoted-printable message parts are translated to 8-bit characters by the -`mimedecode' command. However, unless there is only one quoted-printable body -part, Gnus will have already decoded the quoted-printable parts. - -This variable is initialized t if `mimedecode' is available. - -The source code for `mimedecode' can be obtained from -http://www.freesoft.org/CIE/FAQ/mimedeco.c." - :type 'boolean - :group 'mh-show) - -(defcustom mh-display-buttons-for-inline-parts-flag nil - "*Non-nil means display buttons for all inline MIME parts. -If non-nil, buttons are displayed for all MIME parts. Inline parts start off -in displayed state but they can be hidden by clicking the button. If nil no -buttons are shown for inline parts." - :type 'boolean - :group 'mh-show) - -(defcustom mh-do-not-confirm-flag nil - "*Non-nil means do not prompt for confirmation. -Commands such as `mh-pack-folder' prompt to confirm whether to process -outstanding moves and deletes or not before continuing. A non-nil setting will -perform the action--which is usually desired but cannot be retracted--without -question." - :type 'boolean - :group 'mh-show) - -(defcustom mh-graphical-smileys-flag t - "*Non-nil means graphical smileys are displayed. -Non-nil means that small graphics will be used in the show buffer instead of -patterns like :-), ;-) etc. The setting only has effect if -`mh-decode-mime-flag' is non-nil." - :type 'boolean - :group 'mh-show) - -(defcustom mh-graphical-emphasis-flag t - "*Non-nil means graphical emphasis is displayed. -Non-nil means that _underline_ will be underlined, *bold* will appear in bold, -/italic/ will appear in italic etc. See `gnus-emphasis-alist' for the whole -list. The setting only has effect if `mh-decode-mime-flag' is non-nil." - :type 'boolean - :group 'mh-show) - -(defcustom mh-highlight-citation-p 'gnus - "How to highlight citations in show buffers. -The gnus method uses a different color for each indentation." - :type '(choice (const :tag "Use gnus" gnus) - (const :tag "Use font-lock" font-lock) - (const :tag "Don't fontify" nil)) - :group 'mh-show) - -(defcustom mh-max-inline-image-height nil - "*Maximum inline image height if Content-Disposition is not present. -If nil, image will be displayed if its height is smaller than the height of -the window." - :type '(choice (const nil) integer) - :group 'mh-show) - -(defcustom mh-max-inline-image-width nil - "*Maximum inline image width if Content-Disposition is not present. -If nil, image will be displayed if its width is smaller than the width of the -window." - :type '(choice (const nil) integer) - :group 'mh-show) - -(defcustom mh-show-maximum-size 0 - "*Maximum size of message (in bytes) to display automatically. -Provides an opportunity to skip over large messages which may be slow to load. -Use a value of 0 to display all messages automatically regardless of size." - :type 'integer - :group 'mh-show) - -;; Use goto-addr if it was already loaded (which probably sets this -;; variable to t), or if this variable is otherwise set to t. -(defcustom mh-show-use-goto-addr-flag (and (boundp 'goto-address-highlight-p) - goto-address-highlight-p) - "*Non-nil means highlight URLs and email addresses. -The `goto-addr' module is used." - :type 'boolean - :group 'mh-show) - -(defcustom mh-show-use-xface-flag - (and window-system - (not (null (cond - (mh-xemacs-flag - (locate-library "x-face")) - ((>= emacs-major-version 21) - (locate-library "x-face-e21")) - (t ;Emacs20 - nil)))) - (not (null (and (fboundp 'executable-find) - (executable-find - "uncompface"))))) - "*Non-nil means display faces in `mh-show-mode' with external x-face package. -It is available from ftp://ftp.jpl.org/pub/elisp/. Download it and put its -files in the Emacs `load-path' and MH-E will invoke it automatically for you if -this variable is non-nil. - -The `uncompface' binary is also required to be in the execute PATH. It can -be obtained from: ftp://ftp.cs.indiana.edu/pub/faces/compface/compface.tar.Z" - :type 'boolean - :group 'mh-show) - -(defcustom mh-summary-height (or (and (fboundp 'frame-height) - (> (frame-height) 24) - (min 10 (/ (frame-height) 6))) - 4) - "*Number of lines in MH-Folder window (including the mode line)." - :type 'integer - :group 'mh-show) - -(defcustom mh-visible-headers nil - "*Contains a regexp specifying the headers to keep when cleaning. -Only used if `mh-clean-message-header-flag' is non-nil. Setting it overrides -the variable `mh-invisible-headers'." - :type '(choice (const nil) regexp) - :group 'mh-show) - -(defcustom mhl-formfile nil - "*Name of format file to be used by mhl to show and print messages. -A value of t means use the default format file. -nil means don't use mhl to format messages when showing; mhl is still used, -with the default format file, to format messages when printing them. -The format used should specify a non-zero value for overflowoffset so -the message continues to conform to RFC 822 and MH-E can parse the headers." - :type '(choice (const nil) (const t) string) - :group 'mh-show) -(put 'mhl-formfile 'info-file "mh-e") - -(defvar mh-invisible-headers nil - "*Regexp matching lines in a message header that are not to be shown. -If `mh-visible-headers' is non-nil, it is used instead to specify what -to keep.") - -(defun mh-invisible-headers () - "Make or remake the variable `mh-invisible-headers'. -Done using `mh-invisible-header-fields' as input." - (setq mh-invisible-headers - (concat - "^" - (let ((max-specpdl-size 1000)) ;workaround for insufficient default - (regexp-opt - (append - (if (not mh-show-use-xface-flag) - '("X-Face: ")) - mh-invisible-header-fields)))))) - -(defun mh-invisible-header-fields-set (symbol value) - "Update `mh-invisible-header-fields'. -The function is called with SYMBOL bound to `mh-invisible-header-fields' and -VALUE is the the list of headers that are invisible. As a side effect, the -variable `mh-invisible-fields' is set." - (set-default symbol value) - (mh-invisible-headers)) - -;; Keep fields alphabetized. Mention source, if known. -(defcustom mh-invisible-header-fields - '("Autoforwarded: " - "Bestservhost: " - "Content-" ; RFC 2045 - "Delivered-To: " ; Egroups/yahoogroups mailing list manager - "Delivery-Date: " ; MH - "Delivery: " - "Encoding: " - "Errors-To: " - "Forwarded: " ; MH - "From " ; sendmail - "Importance: " ; MS Outlook - "In-Reply-To: " ; MH - "Lines: " - "List-" ; Mailman mailing list manager - "List-" ; Unknown mailing list managers - "List-Subscribe: " ; Unknown mailing list managers - "List-Unsubscribe: " ; Unknown mailing list managers - "Mail-from: " ; MH - "Mailing-List: " ; Egroups/yahoogroups mailing list manager - "Message-Id: " ; RFC 822 - "Mime-Version" ; RFC 2045 - "NNTP-" ; News - "Old-Return-Path: " - "Original-Encoded-Information-Types: " ; X400 - "P1-Content-Type: " ; X400 - "P1-Message-Id: " ; X400 - "P1-Recipient: " ; X400 - "Path: " - "Precedence: " - "Prev-Resent" ; MH - "Priority: " - "Received: " ; RFC 822 - "References: " - "Remailed-" ; MH - "Replied: " ; MH - "Resent" ; MH - "Return-Path: " ; RFC 822 - "Sensitivity: " ; MS Outlook - "Status: " ; sendmail - "Ua-Content-Id: " ; X400 - "User-Agent: " - "Via: " ; MH - "X-Abuse-Info: " - "X-Accept-Language: " - "X-Accept-Language: " ; Netscape/Mozilla - "X-Ack: " - "X-Apparently-From: " ; MS Outlook - "X-Apparently-To: " ; Egroups/yahoogroups mailing list manager - "X-Authentication-Warning: " ; sendmail - "X-Beenthere: " ; Mailman mailing list manager - "X-Complaints-To: " - "X-Cron-Env: " - "X-Delivered" - "X-Envelope-Sender: " - "X-Envelope-To: " - "X-Folder: " ; Spam - "X-From-Line" - "X-Gnus-Mail-Source: " ; gnus - "X-Habeas-SWE-1: " ; Spam - "X-Habeas-SWE-2: " ; Spam - "X-Habeas-SWE-3: " ; Spam - "X-Habeas-SWE-4: " ; Spam - "X-Habeas-SWE-5: " ; Spam - "X-Habeas-SWE-6: " ; Spam - "X-Habeas-SWE-7: " ; Spam - "X-Habeas-SWE-8: " ; Spam - "X-Habeas-SWE-9: " ; Spam - "X-Info: " ; NTMail - "X-Juno-" ; Juno - "X-List-Host: " ; Unknown mailing list managers - "X-List-Subscribe: " ; Unknown mailing list managers - "X-List-Unsubscribe: " ; Unknown mailing list managers - "X-Listserver: " ; Unknown mailing list managers - "X-Loop: " ; Unknown mailing list managers - "X-MIME-Autoconverted: " ; sendmail - "X-MIMETrack: " - "X-MS-TNEF-Correlator: " ; MS Outlook - "X-Mailing-List: " ; Unknown mailing list managers - "X-Mailman-Version: " ; Mailman mailing list manager - "X-Message-Id" - "X-MimeOLE: " ; MS Outlook - "X-Mozilla-Status: " ; Netscape/Mozilla - "X-Msmail-" ; MS Outlook - "X-News: " ; News - "X-No-Archive: " - "X-Orcl-Content-Type: " - "X-Original-Complaints-To: " - "X-Original-Date: " ; SourceForge mailing list manager - "X-Original-Trace: " - "X-OriginalArrivalTime: " ; Hotmail - "X-Originating-IP: " ; Hotmail - "X-Priority: " ; MS Outlook - "X-Qotd-" ; User added - "X-Received-Date: " - "X-Received: " - "X-Request-" - "X-SBClass: " ; Spam - "X-SBNote: " ; Spam - "X-SBPass: " ; Spam - "X-SBRule: " ; Spam - "X-Scanned-By" - "X-Sender: " - "X-Server-Date: " - "X-Server-Uuid: " - "X-Sieve: " ; Sieve filtering - "X-Spam-Level: " ; Spam - "X-Spam-Score: " ; Spam - "X-Spam-Status: " ; Spam - "X-SpamBouncer: " ; Spam - "X-Trace: " - "X-UIDL: " - "X-UserInfo1: " - "X-VSMLoop: " ; NTMail - "X-Vms-To: " - "X-Wss-Id: " ; Worldtalk gateways - "X-eGroups-" ; Egroups/yahoogroups mailing list manager - "X-pgp: " - "X-submission-address: " - "X400-" ; X400 - "Xref: ") -"*List of header fields that are not to be shown. -Regexps are not allowed. Unique fields should have a \": \" suffix; -otherwise, the element can be used to render an entire class of fields -that start with the same prefix invisible. -This variable is ignored if `mh-visible-headers' is set." - :type '(repeat (string :tag "Header field")) - :set 'mh-invisible-header-fields-set - :group 'mh-show) - -;;; Composing messages (:group 'mh-letter) - -(defcustom mh-compose-insertion (if (locate-library "mml") 'gnus 'mhn) - "Use either 'gnus or 'mhn to insert MIME message directives in messages." - :type '(choice (const :tag "Use gnus" gnus) - (const :tag "Use mhn" mhn)) - :group 'mh-letter) - -(defcustom mh-compose-letter-function nil - "Invoked when setting up a letter draft. -It is passed three arguments: TO recipients, SUBJECT, and CC recipients." - :type '(choice (const nil) function) - :group 'mh-letter) - -(defcustom mh-delete-yanked-msg-window-flag nil - "*Non-nil means delete any window displaying the message. -Controls window display when a message is yanked by \\<mh-letter-mode-map>\\[mh-yank-cur-msg]. -If non-nil, yanking the current message into a draft letter deletes any -windows displaying the message." - :type 'boolean - :group 'mh-letter) - -(defcustom mh-extract-from-attribution-verb "wrote:" - "*Verb to use for attribution when a message is yanked by \\<mh-letter-mode-map>\\[mh-yank-cur-msg]." - :type '(choice (const "wrote:") - (const "a écrit :") - (string :tag "Custom string")) - :group 'mh-letter) - -(defcustom mh-forward-subject-format "%s: %s" - "*Format to generate the Subject: line contents for a forwarded message. -The two string arguments to the format are the sender of the original -message and the original subject line." - :type 'string - :group 'mh-letter) - -(defcustom mh-ins-buf-prefix "> " - "*String to put before each non-blank line of a yanked or inserted message. -\\<mh-letter-mode-map>Used when the message is inserted into an outgoing letter -by \\[mh-insert-letter] or \\[mh-yank-cur-msg]." - :type 'string - :group 'mh-letter) - -(defcustom mh-insert-mail-followup-to-flag t - "Non-nil means maybe append a Mail-Followup-To field to the header. -The insertion is done if the To: or Cc: fields matches an entry in -`mh-insert-mail-followup-to-list'." - :type 'boolean - :group 'mh-letter) - -(defcustom mh-insert-mail-followup-to-list nil - "Alist of addresses for which a Mail-Followup-To field is inserted. -Each element has the form (REGEXP ADDRESS). -When the REGEXP appears in the To or cc fields of a message, the corresponding -ADDRESS is inserted in a Mail-Followup-To field. - -Here's a customization example: - - regexp: mh-e-users@lists.s\\\\(ourceforge\\\\|f\\\\).net - address: mh-e-users@lists.sourceforge.net - -This corresponds to: - - (setq mh-insert-mail-followup-to-list - '((\"mh-e-users@lists.s\\\\(ourceforge\\\\|f\\\\).net\" - \"mh-e-users@lists.sourceforge.net\"))) - -While it might be tempting to add a descriptive name to the mailing list -address, consider that this field will appear in other people's outgoing -mail in their To: field. It might be best to keep it simple." - :type '(repeat (list (string :tag "regexp") (string :tag "address"))) - :group 'mh-letter) - -(defcustom mh-insert-x-mailer-flag t - "*Non-nil means append an X-Mailer field to the header." - :type 'boolean - :group 'mh-letter) - -(defcustom mh-letter-fill-column 72 - "*Fill column to use in `mh-letter-mode'. -This is usually less than in other text modes because email messages get -quoted by some prefix (sometimes many times) when they are replied to, -and it's best to avoid quoted lines that span more than 80 columns." - :type 'integer - :group 'mh-letter) - -(defcustom mh-reply-default-reply-to nil - "*Sets the person or persons to whom a reply will be sent. -If nil, prompt for recipient. If non-nil, then \\<mh-folder-mode-map>`\\[mh-reply]' will use this -value and it should be one of \"from\", \"to\", \"cc\", or \"all\". -The values \"cc\" and \"all\" do the same thing." - :type '(choice (const :tag "Prompt" nil) - (const "from") (const "to") - (const "cc") (const "all")) - :group 'mh-letter) - -(defcustom mh-reply-show-message-flag t - "*Non-nil means the show buffer is displayed using \\<mh-letter-mode-map>\\[mh-reply]. - -The setting of this variable determines whether the MH `show-buffer' is -displayed with the current message when using `mh-reply' without a prefix -argument. Set it to nil if you already include the message automatically -in your draft using - repl: -filter repl.filter -in your ~/.mh_profile file." - :type 'boolean - :group 'mh-letter) - -(defcustom mh-signature-file-name "~/.signature" - "*Name of file containing the user's signature. -Inserted into message by \\<mh-letter-mode-map>\\[mh-insert-signature]." - :type 'file - :group 'mh-letter) - -(defcustom mh-x-face-file "~/.face" - "*File name containing the encoded X-Face string to insert in outgoing mail. -If nil, or the file does not exist, nothing is added to message headers." - :type 'file - :group 'mh-letter) - -(defvar mh-x-mailer-string nil - "*String containing the contents of the X-Mailer header field. -If nil, this variable is initialized to show the version of MH-E, Emacs, and -MH the first time a message is composed.") - -(defcustom mh-yank-from-start-of-msg 'attribution - "*Controls which part of a message is yanked by \\<mh-letter-mode-map>\\[mh-yank-cur-msg]. -If t, include the entire message, with full headers. This is historically -here for use with supercite, but is now deprecated in favor of the setting -`supercite' below. - -If the symbol `body', then yank the message minus the header. - -If the symbol `supercite', include the entire message, with full headers. -This also causes the invocation of `sc-cite-original' without the setting -of `mail-citation-hook', now deprecated practice. - -If the symbol `autosupercite', do as for `supercite' automatically when -show buffer matches the message being replied-to. When this option is used, -the -noformat switch is passed to the repl program to override a -filter or --format switch. - -If the symbol `attribution', then yank the message minus the header and add -a simple attribution line at the top. - -If the symbol `autoattrib', do as for `attribution' automatically when show -buffer matches the message being replied-to. You can make sure this is -always the case by setting `mh-reply-show-message-flag' to t (which is the -default) and optionally `mh-delete-yanked-msg-window-flag' to t as well such -that the show window is never displayed. When the `autoattrib' option is -used, the -noformat switch is passed to the repl program to override a --filter or -format switch. - -If nil, yank only the portion of the message following the point. - -If the show buffer has a region, this variable is ignored unless its value is -one of `attribution' or `autoattrib' in which case the attribution is added -to the yanked region." - :type '(choice (const :tag "Below point" nil) - (const :tag "Without header" body) - (const :tag "Invoke supercite" supercite) - (const :tag "Invoke supercite, automatically" autosupercite) - (const :tag "Without header, with attribution" attribution) - (const :tag "Without header, with attribution, automatically" - autoattrib) - (const :tag "Entire message with headers" t)) - :group 'mh-letter) - -(defcustom mh-letter-complete-function 'ispell-complete-word - "*Function to call when completing outside of fields specific to aliases." - :type '(choice function (const nil)) - :group 'mh-letter) - -;;; Alias handling (:group 'mh-alias) - -(defcustom mh-alias-system-aliases - '("/etc/nmh/MailAliases" "/usr/lib/mh/MailAliases" "/etc/passwd") - "*A list of system files from which to cull aliases. -If these files are modified, they are automatically reread. This list need -include only system aliases and the passwd file, since personal alias files -listed in your \"AliasFile\" MH profile component are automatically included. -You can update the alias list manually using \\[mh-alias-reload]." - :group 'mh-alias - :type '(choice (file) (repeat file))) - -(defcustom mh-alias-expand-aliases-flag nil - "*Non-nil means to expand aliases entered in the minibuffer. -In other words, aliases entered in the minibuffer will be expanded to the full -address in the message draft. By default, this expansion is not performed." - :group 'mh-alias - :type 'boolean) - -(defcustom mh-alias-completion-ignore-case-flag t - "*Non-nil means don't consider case significant in MH alias completion. -This is the default in plain MH, so it is the default here as well. It -can be useful to set this to t if, for example, you use lowercase -aliases for people and uppercase for mailing lists." - :group 'mh-alias - :type 'boolean) - -(defcustom mh-alias-flash-on-comma t - "*Specify whether to flash or warn on translation. -When a [comma] is pressed while entering aliases or addresses, setting this -variable to the following values has the listed effects: -t Flash alias translation but don't warn if there is no translation. -1 Flash alias translation and warn if there is no translation. -nil Do not flash alias translation nor warn if there is no translation." - :group 'mh-alias - :type '(choice (const :tag "Flash but don't warn if no translation" t) - (const :tag "Flash and warn if no translation" 1) - (const :tag "Don't flash nor warn if no translation" nil))) - -(defcustom mh-alias-local-users t - "*If t, local users are completed in MH-E To: and Cc: prompts. - -Users with a userid greater than some magic number (usually 200) are available -for completion. - -If you set this variable to a string, it will be executed to generate a -password file. A value of \"ypcat passwd\" is helpful if NIS is in use." - :group 'mh-alias - :type '(choice (boolean) (string))) - -(defcustom mh-alias-insert-file nil - "*Filename to use to store new MH-E aliases. -This variable can also be a list of filenames, in which case MH-E will prompt -for one of them. If nil, the default, then MH-E will use the first file found -in the \"AliasFile\" component of the MH profile." - :group 'mh-alias - :type '(choice (const :tag "Use AliasFile MH profile component" nil) - (file :tag "Alias file") - (repeat :tag "List of alias files" file))) - -(defcustom mh-alias-insertion-location 'sorted - "Specifies where new aliases are entered in alias files. -Options are sorted alphabetically, at the top of the file or at the bottom." - :type '(choice (const :tag "Sorted alphabetically" sorted) - (const :tag "At the top of file" top) - (const :tag "At the bottom of file" bottom)) - :group 'mh-alias) - -;;; Indexed searching (:group 'mh-index) - -(defcustom mh-index-program nil - "Indexing program that MH-E shall use. -The possible choices are swish++, swish-e, namazu, glimpse and grep. By -default this variable is nil which means that the programs are tried in order -and the first one found is used." - :type '(choice (const :tag "auto-detect" nil) - (const :tag "swish++" swish++) - (const :tag "swish-e" swish) - (const :tag "namazu" namazu) - (const :tag "glimpse" glimpse) - (const :tag "grep" grep)) - :group 'mh-index) - -;;; Multiple personalities (:group 'mh-identity) - -(defcustom mh-identity-list nil - "*List holding MH-E identity. -Omit the colon and trailing space from the field names. -The keyword name \"none\" is reversed for internal use. -Use the keyname name \"signature\" to specify either a signature file or a -function to call to insert a signature at point. - -Providing an empty Value (\"\") will cause the field to be deleted. - -Example entries using the customize interface: - Keyword name: work - From - Value: John Doe <john@work.com> - Organization - Value: Acme Inc. - Keyword name: home - From - Value: John Doe <johndoe@home.net> - Organization - Value: - -This would produce the equivalent of: - (setq mh-identity-list - '((\"work\" - ((\"From\" . \"John Doe <john@work.com>\") - (\"Organization\" . \"Acme Inc.\"))) - (\"home\" - ((\"From\" . \"John Doe <johndoe@home.net>\") - (\"Organization\" . \"\")))))" - :type '(repeat (list :tag "" - (string :tag "Keyword name") - (repeat :tag "At least one pair from below" - (choice (cons :tag "From field" - (const "From") - (string :tag "Value")) - (cons :tag "Organization field" - (const "Organization") - (string :tag "Value")) - (cons :tag "Signature" - (const "signature") - (choice (file) (function))) - (cons :tag "Other field & value pair" - (string :tag "Field") - (string :tag "Value")))))) - :set 'mh-identity-list-set - :group 'mh-identity) - -(defcustom mh-identity-default nil - "Default identity to use when `mh-letter-mode' is called." - ;; Dynamically render :type corresponding to `mh-identity-list' entries, - ;; e.g.: - ;; :type '(radio (const :tag "none" nil) - ;; (const "home") - ;; (const "work")) - :type (append - '(radio) - (cons '(const :tag "none" nil) - (mapcar (function (lambda (arg) `(const ,arg))) - (mapcar 'car mh-identity-list)))) - :group 'mh-identity) - -;;; Hooks (:group 'mh-hooks + group where hook defined) - -;;; These are alphabetized. All hooks should be placed in the 'mh-hook group; -;;; in addition, add the group in which the hook is defined in the manual (or, -;;; if it is new, where it would be defined). - -(defcustom mh-before-quit-hook nil - "Invoked by \\<mh-folder-mode-map>`\\[mh-quit]' before quitting MH-E. -See also `mh-quit-hook'." - :type 'hook - :group 'mh-hooks - :group 'mh-folder) - -(defcustom mh-before-send-letter-hook nil - "Invoked at the beginning of the \\<mh-letter-mode-map>\\[mh-send-letter] command." - :type 'hook - :group 'mh-hooks - :group 'mh-letter) - -(defcustom mh-delete-msg-hook nil - "Invoked after marking each message for deletion." - :type 'hook - :group 'mh-hooks - :group 'mh-folder) - -(defcustom mh-edit-mhn-hook nil - "Invoked on the formatted letter by \\<mh-letter-mode-map>\\[mh-edit-mhn]." - :type 'hook - :group 'mh-hooks - :group 'mh-letter) - -(defcustom mh-find-path-hook nil - "Invoked by `mh-find-path' after reading the user's MH profile." - :type 'hook - :group 'mh-hooks - :group 'mh-folder) - -(defcustom mh-folder-list-change-hook nil - "Invoked whenever the cached folder list `mh-folder-list' is changed." - :type 'hook - :group 'mh-hooks - :group 'mh-folder) - -(defcustom mh-folder-mode-hook nil - "Invoked in `mh-folder-mode' on a new folder." - :type 'hook - :group 'mh-hooks - :group 'mh-folder) - -(defcustom mh-folder-updated-hook nil - "Invoked when the folder actions (such as moves and deletes) are performed. -Variables that are useful in this hook include `mh-delete-list' and -`mh-refile-list' which can be used to see which changes are being made to -current folder, `mh-current-folder'." - :type 'hook - :group 'mh-hooks) - -(defcustom mh-inc-folder-hook nil - "Invoked by \\<mh-folder-mode-map>`\\[mh-inc-folder]' after incorporating mail into a folder." - :type 'hook - :group 'mh-hooks - :group 'mh-folder) - -(defcustom mh-index-show-hook nil - "Invoked after the message has been displayed." - :type 'hook - :group 'mh-hooks - :group 'mh-index) - -(defcustom mh-letter-insert-signature-hook nil - "Invoked at the beginning of the \\<mh-letter-mode-map>\\[mh-insert-signature] command. -Can be used to determine which signature file to use based on message content. -On return, if `mh-signature-file-name' is non-nil that file will be inserted at -the current point in the buffer." - :type 'hook - :group 'mh-hooks - :group 'mh-letter) - -(defcustom mh-letter-mode-hook nil - "Invoked in `mh-letter-mode' on a new letter." - :type 'hook - :group 'mh-hooks - :group 'mh-letter) - -(defcustom mh-pick-mode-hook nil - "Invoked upon entry to `mh-pick-mode'." - :type 'hook - :group 'mh-hooks - :group 'mh-folder) - -(defcustom mh-quit-hook nil - "Invoked after \\<mh-folder-mode-map>`\\[mh-quit]' quits MH-E. -See also `mh-before-quit-hook'." - :type 'hook - :group 'mh-hooks - :group 'mh-folder) - -(defcustom mh-refile-msg-hook nil - "Invoked after marking each message for refiling." - :type 'hook - :group 'mh-hooks - :group 'mh-folder) - -(defcustom mh-show-hook nil - "Invoked after \\<mh-folder-mode-map>`\\[mh-show]' shows a message." - :type 'hook - :group 'mh-hooks - :group 'mh-show) - -(defcustom mh-show-mode-hook nil - "Invoked upon entry to `mh-show-mode'." - :type 'hook - :group 'mh-hooks - :group 'mh-show) - -(defcustom mh-unseen-updated-hook nil - "Invoked after the unseen sequence has been updated. -The variable `mh-seen-list' can be used to obtain the list of messages which -will be removed from the unseen sequence." - :type 'hook - :group 'mh-hooks - :group 'mh-folder) - - - -;;; Faces - -;;; Faces used in speedbar (:group mh-speed-faces) - -(defface mh-speedbar-folder-face - '((((class color) (background light)) - (:foreground "blue4")) - (((class color) (background dark)) - (:foreground "light blue"))) - "Face used for folders in the speedbar buffer." - :group 'mh-speed-faces) - -(defface mh-speedbar-selected-folder-face - '((((class color) (background light)) - (:foreground "red" :underline t)) - (((class color) (background dark)) - (:foreground "red" :underline t)) - (t (:underline t))) - "Face used for the current folder." - :group 'mh-speed-faces) - -(defface mh-speedbar-folder-with-unseen-messages-face - '((t (:inherit mh-speedbar-folder-face :bold t))) - "Face used for folders in the speedbar buffer which have unread messages." - :group 'mh-speed-faces) - -(defface mh-speedbar-selected-folder-with-unseen-messages-face - '((t (:inherit mh-speedbar-selected-folder-face :bold t))) - "Face used for the current folder when it has unread messages." - :group 'mh-speed-faces) - -;;; Faces used in scan listing (:group mh-folder-faces) - -(defvar mh-folder-body-face 'mh-folder-body-face - "Face for highlighting body text in MH-Folder buffers.") -(defface mh-folder-body-face - '((((type tty) (class color)) (:foreground "green")) - (((class grayscale) (background light)) (:foreground "DimGray" :italic t)) - (((class grayscale) (background dark)) (:foreground "LightGray" :italic t)) - (((class color) (background light)) (:foreground "RosyBrown")) - (((class color) (background dark)) (:foreground "LightSalmon")) - (t (:italic t))) - "Face for highlighting body text in MH-Folder buffers." - :group 'mh-folder-faces) - -(defvar mh-folder-cur-msg-face 'mh-folder-cur-msg-face - "Face for the current message line in MH-Folder buffers.") -(defface mh-folder-cur-msg-face - '((((type tty pc) (class color)) - (:background "LightGreen")) - (((class color) (background light)) - (:background "LightGreen") ;Use this for solid background colour - ;; (:underline t) ;Use this for underlining - ) - (((class color) (background dark)) - (:background "DarkOliveGreen4")) - (t (:underline t))) - "Face for the current message line in MH-Folder buffers." - :group 'mh-folder-faces) - -(defvar mh-folder-cur-msg-number-face 'mh-folder-cur-msg-number-face - "Face for highlighting the current message in MH-Folder buffers.") -(defface mh-folder-cur-msg-number-face - '((((type tty) (class color)) (:foreground "cyan" :weight bold)) - (((class grayscale) (background light)) (:foreground "LightGray" :bold t)) - (((class grayscale) (background dark)) (:foreground "DimGray" :bold t)) - (((class color) (background light)) (:foreground "Purple")) - (((class color) (background dark)) (:foreground "Cyan")) - (t (:bold t))) - "Face for highlighting the current message in MH-Folder buffers." - :group 'mh-folder-faces) - -(defvar mh-folder-date-face 'mh-folder-date-face - "Face for highlighting the date in MH-Folder buffers.") -(defface mh-folder-date-face - '((((class color) (background light)) - (:foreground "snow4")) - (((class color) (background dark)) - (:foreground "snow3")) - (t - (:bold t))) - "Face for highlighting the date in MH-Folder buffers." - :group 'mh-folder-faces) - -(defvar mh-folder-followup-face 'mh-folder-followup-face - "Face for highlighting Re: (followup) subject text in MH-Folder buffers.") -(defface mh-folder-followup-face - '((((class color) (background light)) - (:foreground "blue3")) - (((class color) (background dark)) - (:foreground "LightGoldenRod")) - (t - (:bold t))) - "Face for highlighting Re: (followup) subject text in MH-Folder buffers." - :group 'mh-folder-faces) - -(defvar mh-folder-msg-number-face 'mh-folder-msg-number-face - "Face for highlighting the message number in MH-Folder buffers.") -(defface mh-folder-msg-number-face - '((((class color) (background light)) - (:foreground "snow4")) - (((class color) (background dark)) - (:foreground "snow3")) - (t - (:bold t))) - "Face for highlighting the message number in MH-Folder buffers." - :group 'mh-folder-faces) - -(defvar mh-folder-deleted-face 'mh-folder-deleted-face - "Face for highlighting deleted messages in MH-Folder buffers.") -(copy-face 'mh-folder-msg-number-face 'mh-folder-deleted-face) - -(defvar mh-folder-refiled-face 'mh-folder-refiled-face - "Face for highlighting refiled messages in MH-Folder buffers.") -(defface mh-folder-refiled-face - '((((type tty) (class color)) (:foreground "yellow" :weight light)) - (((class grayscale) (background light)) - (:foreground "Gray90" :bold t :italic t)) - (((class grayscale) (background dark)) - (:foreground "DimGray" :bold t :italic t)) - (((class color) (background light)) (:foreground "DarkGoldenrod")) - (((class color) (background dark)) (:foreground "LightGoldenrod")) - (t (:bold t :italic t))) - "Face for highlighting refiled messages in MH-Folder buffers." - :group 'mh-folder-faces) - -(defvar mh-folder-subject-face 'mh-folder-subject-face - "Face for highlighting subject text in MH-Folder buffers.") -(if (boundp 'facemenu-unlisted-faces) - (add-to-list 'facemenu-unlisted-faces "^mh-folder")) -(defface mh-folder-subject-face - '((((class color) (background light)) - (:foreground "blue4")) - (((class color) (background dark)) - (:foreground "yellow")) - (t - (:bold t))) - "Face for highlighting subject text in MH-Folder buffers." - :group 'mh-folder-faces) - -(defvar mh-folder-address-face 'mh-folder-address-face - "Face for highlighting the address in MH-Folder buffers.") -(copy-face 'mh-folder-subject-face 'mh-folder-address-face) - -(defvar mh-folder-scan-format-face 'mh-folder-scan-format-face - "Face for highlighting `mh-scan-format-regexp' matches in MH-Folder buffers.") -(copy-face 'mh-folder-followup-face 'mh-folder-scan-format-face) - -(defvar mh-folder-to-face 'mh-folder-to-face - "Face for highlighting the To: string in MH-Folder buffers.") -(defface mh-folder-to-face - '((((type tty) (class color)) (:foreground "green")) - (((class grayscale) (background light)) (:foreground "DimGray" :italic t)) - (((class grayscale) (background dark)) (:foreground "LightGray" :italic t)) - (((class color) (background light)) (:foreground "RosyBrown")) - (((class color) (background dark)) (:foreground "LightSalmon")) - (t (:italic t))) - "Face for highlighting the To: string in MH-Folder buffers." - :group 'mh-folder-faces) - -;;; Faces used in message display (:group mh-show-faces) - -(defvar mh-show-cc-face 'mh-show-cc-face - "Face for highlighting cc header fields.") -(defface mh-show-cc-face - '((((type tty) (class color)) (:foreground "yellow" :weight light)) - (((class grayscale) (background light)) - (:foreground "Gray90" :bold t :italic t)) - (((class grayscale) (background dark)) - (:foreground "DimGray" :bold t :italic t)) - (((class color) (background light)) (:foreground "DarkGoldenrod")) - (((class color) (background dark)) (:foreground "LightGoldenrod")) - (t (:bold t :italic t))) - "Face for highlighting cc header fields." - :group 'mh-show-faces) - -(defvar mh-show-date-face 'mh-show-date-face - "Face for highlighting the Date header field.") -(defface mh-show-date-face - '((((type tty) (class color)) (:foreground "green")) - (((class grayscale) (background light)) (:foreground "Gray90" :bold t)) - (((class grayscale) (background dark)) (:foreground "DimGray" :bold t)) - (((class color) (background light)) (:foreground "ForestGreen")) - (((class color) (background dark)) (:foreground "PaleGreen")) - (t (:bold t :underline t))) - "Face for highlighting the Date header field." - :group 'mh-show-faces) - -(defvar mh-show-header-face 'mh-show-header-face - "Face used to deemphasize unspecified header fields.") -(defface mh-show-header-face - '((((type tty) (class color)) (:foreground "green")) - (((class grayscale) (background light)) (:foreground "DimGray" :italic t)) - (((class grayscale) (background dark)) (:foreground "LightGray" :italic t)) - (((class color) (background light)) (:foreground "RosyBrown")) - (((class color) (background dark)) (:foreground "LightSalmon")) - (t (:italic t))) - "Face used to deemphasize unspecified header fields." - :group 'mh-show-faces) - -(defvar mh-show-to-face 'mh-show-to-face - "Face for highlighting the To: header field.") -(if (boundp 'facemenu-unlisted-faces) - (add-to-list 'facemenu-unlisted-faces "^mh-show")) -(defface mh-show-to-face - '((((class grayscale) (background light)) - (:foreground "DimGray" :underline t)) - (((class grayscale) (background dark)) - (:foreground "LightGray" :underline t)) - (((class color) (background light)) (:foreground "SaddleBrown")) - (((class color) (background dark)) (:foreground "burlywood")) - (t (:underline t))) - "Face for highlighting the To: header field." - :group 'mh-show-faces) - -(defvar mh-show-from-face 'mh-show-from-face - "Face for highlighting the From: header field.") -(defface mh-show-from-face - '((((class color) (background light)) - (:foreground "red3")) - (((class color) (background dark)) - (:foreground "cyan")) - (t - (:bold t))) - "Face for highlighting the From: header field." - :group 'mh-show-faces) - -(defvar mh-show-subject-face 'mh-show-subject-face - "Face for highlighting the Subject header field.") -(copy-face 'mh-folder-subject-face 'mh-show-subject-face) - -;;; Faces used in indexed searches (:group mh-index-faces) - -(defvar mh-index-folder-face 'mh-index-folder-face - "Face for highlighting folders in MH-Index buffers.") -(defface mh-index-folder-face - '((((class color) (background light)) - (:foreground "dark green" :bold t)) - (((class color) (background dark)) - (:foreground "indian red" :bold t)) - (t - (:bold t))) - "Face for highlighting folders in MH-Index buffers." - :group 'mh-index-faces) - -(provide 'mh-customize) - -;;; Local Variables: -;;; indent-tabs-mode: nil -;;; sentence-end-double-space: nil -;;; End: - -;;; mh-customize.el ends here
--- a/lisp/mail/mh-e.el Sun Jan 26 01:33:33 2003 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2258 +0,0 @@ -;;; mh-e.el --- GNU Emacs interface to the MH mail system - -;; Copyright (C) 1985,86,87,88,90,92,93,94,95,97,2000,2001,2002 Free Software Foundation, Inc. - -;; Author: Bill Wohler <wohler@newt.com> -;; Maintainer: Bill Wohler <wohler@newt.com> -;; Version: 7.1 -;; Keywords: mail - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; How to Use: -;; M-x mh-rmail to read mail. Type C-h m there for a list of commands. -;; C-u M-x mh-rmail to visit any folder. -;; M-x mh-smail to send mail. From within the mail reader, "m" works, too. - -;; Your .emacs might benefit from these bindings: -;; (global-set-key "\C-cr" 'mh-rmail) -;; (global-set-key "\C-xm" 'mh-smail) -;; (global-set-key "\C-x4m" 'mh-smail-other-window) - -;; MH (Message Handler) is a powerful mail reader. - -;; The MH newsgroup is comp.mail.mh; the mailing list is mh-users@ics.uci.edu -;; (send to mh-users-request to be added). See the monthly Frequently Asked -;; Questions posting there for information on getting MH and MH-E: -;; http://www.faqs.org/faqs/mail/mh-faq/part1/preamble.html - -;; N.B. MH must have been compiled with the MHE compiler flag or several -;; features necessary for MH-E will be missing from MH commands, specifically -;; the -build switch to repl and forw. - -;; MH-E is an Emacs interface to the MH mail system. - -;; MH-E is supported in GNU Emacs 20 and 21, with MH 6.8.4 and nmh 1.0.4. - -;; Mailing Lists: -;; mh-e-users@lists.sourceforge.net -;; mh-e-announce@lists.sourceforge.net -;; mh-e-devel@lists.sourceforge.net -;; -;; Subscribe by sending a "subscribe" message to -;; <list>-request@lists.sourceforge.net, or by using the web interface at -;; https://sourceforge.net/mail/?group_id=13357 - -;; Bug Reports: -;; https://sourceforge.net/tracker/?group_id=13357&atid=113357 -;; Include the output of M-x mh-version in any bug report. - -;; Feature Requests: -;; https://sourceforge.net/tracker/?atid=363357&group_id=13357&func=browse - -;; Support: -;; https://sourceforge.net/tracker/?group_id=13357&atid=213357 - -;;; Change Log: - -;; Original version for Gosling emacs by Brian Reid, Stanford, 1982. -;; Modified by James Larus, BBN, July 1984 and UCB, 1984 & 1985. -;; Rewritten for GNU Emacs, James Larus 1985. larus@ginger.berkeley.edu -;; Modified by Stephen Gildea 1988. gildea@lcs.mit.edu -;; Maintenance picked up by Bill Wohler <wohler@newt.com> and the -;; SourceForge Crew <http://mh-e.sourceforge.net/>. 2001. - -;; $Id: mh-e.el,v 1.240 2003/01/08 00:46:25 wohler Exp $ - -;;; Code: - -(require 'cl) - -(defvar recursive-load-depth-limit) -(eval-when (compile load eval) - (if (and (boundp 'recursive-load-depth-limit) - (integerp recursive-load-depth-limit) - (> 50 recursive-load-depth-limit)) - (setq recursive-load-depth-limit 50))) - -(require 'mh-utils) -(require 'gnus-util) -(require 'easymenu) -(if mh-xemacs-flag - (require 'mh-xemacs-compat)) - -;; Shush the byte-compiler -(defvar font-lock-auto-fontify) -(defvar font-lock-defaults) - -(defconst mh-version "7.1" "Version number of MH-E.") - -;;; Autoloads -(autoload 'Info-goto-node "info") - - - -(defvar mh-note-deleted "D" - "String whose first character is used to notate deleted messages.") - -(defvar mh-note-refiled "^" - "String whose first character is used to notate refiled messages.") - -(defvar mh-note-cur "+" - "String whose first character is used to notate the current message.") - -(defvar mh-partial-folder-mode-line-annotation "select" - "Annotation when displaying part of a folder. -The string is displayed after the folder's name. nil for no annotation.") - -;;; Parameterize MH-E to work with different scan formats. The defaults work -;;; with the standard MH scan listings, in which the first 4 characters on -;;; the line are the message number, followed by two places for notations. - -;; The following scan formats are passed to the scan program if the -;; setting of `mh-scan-format-file' above is nil. They are identical -;; except the later one makes use of the nmh `decode' function to -;; decode RFC 2047 encodings. If you just want to change the width of -;; the msg number, use the `mh-set-cmd-note' function. - -(defvar mh-scan-format-mh - (concat - "%4(msg)" - "%<(cur)+%| %>" - "%<{replied}-" - "%?(nonnull(comp{to}))%<(mymbox{to})t%>" - "%?(nonnull(comp{cc}))%<(mymbox{cc})c%>" - "%?(nonnull(comp{bcc}))%<(mymbox{bcc})b%>" - "%?(nonnull(comp{newsgroups}))n%>" - "%<(zero) %>" - "%02(mon{date})/%02(mday{date})%<{date} %|*%>" - "%<(mymbox{from})%<{to}To:%14(friendly{to})%>%>" - "%<(zero)%17(friendly{from})%> " - "%{subject}%<{body}<<%{body}%>") - "*Scan format string for MH, provided to the scan program via the -format arg. -This format is identical to the default except that additional hints for -fontification have been added to the fifth column (remember that in Emacs, the -first column is 0). - -The values of the fifth column, in priority order, are: `-' if the -message has been replied to, t if an address on the To: line matches -one of the mailboxes of the current user, `c' if the Cc: line matches, -`b' if the Bcc: line matches, and `n' if a non-empty Newsgroups: header -is present.") - -(defvar mh-scan-format-nmh - (concat - "%4(msg)" - "%<(cur)+%| %>" - "%<{replied}-" - "%?(nonnull(comp{to}))%<(mymbox{to})t%>" - "%?(nonnull(comp{cc}))%<(mymbox{cc})c%>" - "%?(nonnull(comp{bcc}))%<(mymbox{bcc})b%>" - "%?(nonnull(comp{newsgroups}))n%>" - "%<(zero) %>" - "%02(mon{date})/%02(mday{date})%<{date} %|*%>" - "%<(mymbox{from})%<{to}To:%14(decode(friendly{to}))%>%>" - "%<(zero)%17(decode(friendly{from}))%> " - "%(decode{subject})%<{body}<<%{body}%>") - "*Scan format string for nmh. -This string is passed to the scan program via the -format arg. -This format is identical to the default except that additional hints for -fontification have been added to the fifth column (remember that in Emacs, the -first column is 0). - -The values of the fifth column, in priority order, are: `-' if the -message has been replied to, t if an address on the To: line matches -one of the mailboxes of the current user, `c' if the Cc: line matches, -`b' if the Bcc: line matches, and `n' if a non-empty Newsgroups: header -is present.") - -(defvar mh-scan-good-msg-regexp "^\\( *[0-9]+\\)[^D^0-9]" - "Regexp specifying the scan lines that are 'good' messages. -The default `mh-folder-font-lock-keywords' expects this expression to contain -at least one parenthesized expression which matches the message number.") - -(defvar mh-scan-deleted-msg-regexp "^\\( *[0-9]+\\)D" - "Regexp matching scan lines of deleted messages. -The default `mh-folder-font-lock-keywords' expects this expression to contain -at least one parenthesized expression which matches the message number.") - -(defvar mh-scan-refiled-msg-regexp "^\\( *[0-9]+\\)\\^" - "Regexp matching scan lines of refiled messages. -The default `mh-folder-font-lock-keywords' expects this expression to contain -at least one parenthesized expression which matches the message number.") - -(defvar mh-scan-valid-regexp "^ *[0-9]" - "Regexp matching scan lines for messages (not error messages).") - -(defvar mh-scan-cur-msg-number-regexp "^\\( *[0-9]+\\+\\).*" - "Regexp matching scan line for the current message. -The default `mh-folder-font-lock-keywords' expects this expression to contain -at least one parenthesized expression which matches the message number. -Don't disable this regexp as it's needed by non fontifying functions.") - -(defvar mh-scan-cur-msg-regexp "^\\( *[0-9]+\\+DISABLED.*\\)" - "Regexp matching scan line for the current message. -The default `mh-folder-font-lock-keywords' expects this expression to contain -at least one parenthesized expression which matches the whole line. -To enable this feature, remove the string DISABLED from the regexp.") - -(defvar mh-scan-date-regexp "\\([0-9][0-9]/[0-9][0-9]\\)" - "Regexp matching a valid date in scan lines. -The default `mh-folder-font-lock-keywords' expects this expression to contain -only one parenthesized expression which matches the date field -\(see `mh-scan-format-regexp').") - -(defvar mh-scan-rcpt-regexp "\\(To:\\)\\(..............\\)" - "Regexp specifying the recipient in scan lines for messages we sent. -The default `mh-folder-font-lock-keywords' expects this expression to contain -two parenthesized expressions. The first is expected to match the To: -that the default scan format file generates. The second is expected to match -the recipient's name.") - -(defvar mh-scan-body-regexp "\\(<<\\([^\n]+\\)?\\)" - "Regexp matching the message body beginning displayed in scan lines. -The default `mh-folder-font-lock-keywords' expects this expression to contain -at least one parenthesized expression which matches the body text.") - -(defvar mh-scan-subject-regexp - ;;"^ *[0-9]+........[ ]*...................\\([Rr][Ee]:\\s-*\\)*\\([^<\n]*\\)" - "^ *[0-9]+........[ ]*...................\\([Rr][Ee]\\(\\[[0-9]+\\]\\)?:\\s-*\\)*\\([^<\n]*\\)" - "*Regexp matching the subject string in MH folder mode. -The default `mh-folder-font-lock-keywords' expects this expression to contain -at least tree parenthesized expressions. The first is expected to match the Re: -string, if any. The second matches an optional bracketed number after Re, -such as in Re[2]: and the third is expected to match the subject line itself.") - -(defvar mh-scan-format-regexp - (concat "\\([bct]\\)" mh-scan-date-regexp " *\\(..................\\)") - "Regexp matching the output of scan. -The default value is based upon the default values of either -`mh-scan-format-mh' or `mh-scan-format-nmh'. -The default `mh-folder-font-lock-keywords' expects this expression to contain -at least three parenthesized expressions. The first should match the -fontification hint, the second is found in `mh-scan-date-regexp', and the -third should match the user name.") - - - -(defvar mh-folder-font-lock-keywords - (list - ;; Folders when displaying index buffer - (list "^\\+.*" - '(0 mh-index-folder-face)) - ;; Marked for deletion - (list (concat mh-scan-deleted-msg-regexp ".*") - '(0 mh-folder-deleted-face)) - ;; Marked for refile - (list (concat mh-scan-refiled-msg-regexp ".*") - '(0 mh-folder-refiled-face)) - ;;after subj - (list mh-scan-body-regexp '(1 mh-folder-body-face nil t)) - '(mh-folder-font-lock-subject - (1 mh-folder-followup-face append t) - (2 mh-folder-subject-face append t)) - ;;current msg - (list mh-scan-cur-msg-number-regexp - '(1 mh-folder-cur-msg-number-face)) - (list mh-scan-good-msg-regexp - '(1 mh-folder-msg-number-face)) ;; Msg number - (list mh-scan-date-regexp '(1 mh-folder-date-face)) ;; Date - (list mh-scan-rcpt-regexp - '(1 mh-folder-to-face) ;; To: - '(2 mh-folder-address-face)) ;; address - ;; scan font-lock name - (list mh-scan-format-regexp - '(1 mh-folder-date-face) - '(3 mh-folder-scan-format-face)) - ;; Current message line - (list mh-scan-cur-msg-regexp - '(1 mh-folder-cur-msg-face prepend t)) - ;; Unseen messages in bold - '(mh-folder-font-lock-unseen (1 'bold append t))) - "Regexp keywords used to fontify the MH-Folder buffer.") - -(defvar mh-scan-cmd-note-width 1 - "Number of columns consumed by the cmd-note field in `mh-scan-format'. -This column will have one of the values: ` ', `D', `^', `+' and where -` ' is the default value, -`D' is the `mh-note-deleted' character, -`^' is the `mh-note-refiled' character, and -`+' is the `mh-note-cur' character.") - -(defvar mh-scan-destination-width 1 - "Number of columns consumed by the destination field in `mh-scan-format'. -This column will have one of ' ', '%', '-', 't', 'c', 'b', or `n' in it. -A ' ' blank space is the default character. -A '%' indicates that the message in in a named MH sequence. -A '-' indicates that the message has been annotated with a replied field. -A 't' indicates that the message contains mymbox in the To: field. -A 'c' indicates that the message contains mymbox in the Cc: field. -A 'b' indicates that the message contains mymbox in the Bcc: field. -A 'n' indicates that the message contains a Newsgroups: field.") - -(defvar mh-scan-date-width 5 - "Number of columns consumed by the date field in `mh-scan-format'. -This column will typically be of the form mm/dd.") - -(defvar mh-scan-date-flag-width 1 - "Number of columns consumed to flag (in)valid dates in `mh-scan-format'. -This column will have ` ' for valid and `*' for invalid or missing dates.") - -(defvar mh-scan-from-mbox-width 17 - "Number of columns consumed with the \"From:\" line in `mh-scan-format'. -This column will have a friendly name or e-mail address of the -originator, or a \"To: address\" for outgoing e-mail messages.") - -(defvar mh-scan-from-mbox-sep-width 2 - "Number of columns consumed by whitespace after from-mbox in `mh-scan-format'. -This column will only ever have spaces in it.") - -(defvar mh-scan-field-from-start-offset - (+ mh-scan-cmd-note-width - mh-scan-destination-width - mh-scan-date-width - mh-scan-date-flag-width) - "The offset from the `mh-cmd-note' to find the start of \"From:\" address.") - -(defvar mh-scan-field-from-end-offset - (+ mh-scan-field-from-start-offset mh-scan-from-mbox-width) - "The offset from the `mh-cmd-note' to find the end of \"From:\" address.") - -(defvar mh-scan-field-subject-start-offset - (+ mh-scan-cmd-note-width - mh-scan-destination-width - mh-scan-date-width - mh-scan-date-flag-width - mh-scan-from-mbox-width - mh-scan-from-mbox-sep-width) - "The offset from the `mh-cmd-note' to find the start of the subject.") - -(defun mh-folder-font-lock-subject (limit) - "Return MH-E scan subject strings to font-lock between point and LIMIT." - (if (not (re-search-forward mh-scan-subject-regexp limit t)) - nil - (if (match-beginning 1) - (set-match-data (list (match-beginning 1) (match-end 3) - (match-beginning 1) (match-end 3) nil nil)) - (set-match-data (list (match-beginning 3) (match-end 3) - nil nil (match-beginning 3) (match-end 3)))) - t)) - - - -;; Fontifify unseen mesages in bold. - -(defvar mh-folder-unseen-seq-name nil - "Name of unseen sequence. -The default for this is provided by the function `mh-folder-unseen-seq-name' -On nmh systems.") - -(defun mh-folder-unseen-seq-name () - "Provide name of unseen sequence from mhparam." - (or mh-progs (mh-find-path)) - (save-excursion - (let ((unseen-seq-name "unseen")) - (with-temp-buffer - (unwind-protect - (progn - (call-process (expand-file-name "mhparam" mh-progs) - nil '(t t) nil "-component" "Unseen-Sequence") - (goto-char (point-min)) - (if (re-search-forward "Unseen-Sequence: \\(.*\\)$" nil t) - (setq unseen-seq-name (match-string 1)))))) - unseen-seq-name))) - -(defun mh-folder-unseen-seq-list () - "Return a list of unseen message numbers for current folder." - (if (not mh-folder-unseen-seq-name) - (setq mh-folder-unseen-seq-name (mh-folder-unseen-seq-name))) - (cond - ((not mh-folder-unseen-seq-name) - nil) - (t - (let ((folder mh-current-folder)) - (save-excursion - (with-temp-buffer - (unwind-protect - (progn - (call-process (expand-file-name "mark" mh-progs) - nil '(t t) nil - folder "-seq" mh-folder-unseen-seq-name - "-list") - (goto-char (point-min)) - (sort (mh-read-msg-list) '<))))))))) - -(defvar mh-folder-unseen-seq-cache nil - "Internal cache variable used for font-lock in MH-E. -Should only be non-nil through font-lock stepping, and nil once font-lock -is done highlighting.") -(make-variable-buffer-local 'mh-folder-unseen-seq-cache) - -(defun mh-folder-font-lock-unseen (limit) - "Return unseen message lines to font-lock between point and LIMIT." - (if (not mh-folder-unseen-seq-cache) - (setq mh-folder-unseen-seq-cache (mh-folder-unseen-seq-list))) - (let ((cur-msg (mh-get-msg-num nil))) - (cond - ((not mh-folder-unseen-seq-cache) - nil) - ((not cur-msg) ;Presumably at end of buffer - (setq mh-folder-unseen-seq-cache nil) - nil) - ((member cur-msg mh-folder-unseen-seq-cache) - (let ((bpoint (progn (beginning-of-line)(point))) - (epoint (progn (forward-line 1)(point)))) - (if (<= limit (point)) - (setq mh-folder-unseen-seq-cache nil)) - (set-match-data (list bpoint epoint bpoint epoint)) - t)) - (t - ;; move forward one line at a time, checking each message number. - (while (and - (= 0 (forward-line 1)) - (> limit (point)) - (not (member (mh-get-msg-num nil) mh-folder-unseen-seq-cache)))) - ;; Examine how we must have exited the loop... - (let ((cur-msg (mh-get-msg-num nil))) - (cond - ((or (not cur-msg) - (<= limit (point)) - (not (member cur-msg mh-folder-unseen-seq-cache))) - (setq mh-folder-unseen-seq-cache nil) - nil) - ((member cur-msg mh-folder-unseen-seq-cache) - (let ((bpoint (progn (beginning-of-line)(point))) - (epoint (progn (forward-line 1)(point)))) - (if (<= limit (point)) - (setq mh-folder-unseen-seq-cache nil)) - (set-match-data (list bpoint epoint bpoint epoint)) - t)))))))) - - - -;;; Internal variables: - -(defvar mh-last-destination nil) ;Destination of last refile or write - ;command. -(defvar mh-last-destination-folder nil) ;Destination of last refile command. -(defvar mh-last-destination-write nil) ;Destination of last write command. - -(defvar mh-folder-mode-map (make-keymap) - "Keymap for MH folders.") - -(defvar mh-delete-list nil) ;List of msg numbers to delete. - -(defvar mh-refile-list nil) ;List of folder names in mh-seq-list. - -(defvar mh-next-direction 'forward) ;Direction to move to next message. - -(defvar mh-narrowed-to-seq nil) ;Sequence display is narrowed to or - ;nil if not narrowed. - -(defvar mh-view-ops ()) ;Stack of ops that change the folder - ;view (such as narrowing or threading). - -(defvar mh-index-data nil) ;Info about index search results -(defvar mh-index-previous-search nil) -(defvar mh-index-msg-checksum-map nil) -(defvar mh-index-checksum-origin-map nil) - -(defvar mh-first-msg-num nil) ;Number of first msg in buffer. - -(defvar mh-last-msg-num nil) ;Number of last msg in buffer. - -(defvar mh-mode-line-annotation nil) ;Message range displayed in buffer. - -;;; Macros and generic functions: - -(defun mh-mapc (function list) - "Apply FUNCTION to each element of LIST for side effects only." - (while list - (funcall function (car list)) - (setq list (cdr list)))) - -(defun mh-scan-format () - "Return \"-format\" argument for the scan program." - (if (equal mh-scan-format-file t) - (list "-format" (if mh-nmh-flag - (list (mh-update-scan-format - mh-scan-format-nmh mh-cmd-note)) - (list (mh-update-scan-format - mh-scan-format-mh mh-cmd-note)))) - (if (not (equal mh-scan-format-file nil)) - (list "-format" mh-scan-format-file)))) - - - -;;; Entry points: - -;;;###autoload -(defun mh-rmail (&optional arg) - "Inc(orporate) new mail with MH. -Scan an MH folder if ARG is non-nil. This function is an entry point to MH-E, -the Emacs front end to the MH mail system." - (interactive "P") - (mh-find-path) - (if arg - (call-interactively 'mh-visit-folder) - (mh-inc-folder))) - -;;;###autoload -(defun mh-nmail (&optional arg) - "Check for new mail in inbox folder. -Scan an MH folder if ARG is non-nil. This function is an entry point to MH-E, -the Emacs front end to the MH mail system." - (interactive "P") - (mh-find-path) ; init mh-inbox - (if arg - (call-interactively 'mh-visit-folder) - (mh-visit-folder mh-inbox))) - - - -;;; User executable MH-E commands: - -(defun mh-delete-msg (msg-or-seq) - "Mark the specified MSG-OR-SEQ for subsequent deletion and move to the next. - -Default is the displayed message. If optional prefix argument is given then -prompt for the message sequence. If variable `transient-mark-mode' is non-nil -and the mark is active, then the selected region is marked for deletion." - (interactive (list (cond - ((mh-mark-active-p t) - (mh-region-to-msg-list (region-beginning) (region-end))) - (current-prefix-arg - (mh-read-seq-default "Delete" t)) - (t - (mh-get-msg-num t))))) - (mh-delete-msg-no-motion msg-or-seq) - (mh-next-msg)) - -(defun mh-delete-msg-no-motion (msg-or-seq) - "Mark the specified MSG-OR-SEQ for subsequent deletion. -Default is the displayed message. If optional prefix argument is provided, -then prompt for the message sequence." - (interactive (list (if current-prefix-arg - (mh-read-seq-default "Delete" t) - (mh-get-msg-num t)))) - (if (numberp msg-or-seq) - (mh-delete-a-msg msg-or-seq) - (mh-map-to-seq-msgs 'mh-delete-a-msg msg-or-seq))) - -(defun mh-execute-commands () - "Process outstanding delete and refile requests." - (interactive) - (if mh-narrowed-to-seq (mh-widen)) - (mh-process-commands mh-current-folder) - (mh-set-scan-mode) - (mh-goto-cur-msg) ; after mh-set-scan-mode for efficiency - (mh-make-folder-mode-line) - t) ; return t for write-file-functions - -(defun mh-first-msg () - "Move to the first message." - (interactive) - (goto-char (point-min)) - (while (and (not (eobp)) (not (looking-at mh-scan-valid-regexp))) - (forward-line 1))) - -(defun mh-header-display () - "Show the current message with all its headers. -Displays headers that might have been suppressed by setting the -variables `mh-clean-message-header-flag' or `mhl-formfile', or by the fallback -behavior of scrolling uninteresting headers off the top of the window. -Type \"\\[mh-show]\" to show the message normally again." - (interactive) - (and (not mh-showing-with-headers) - (or mhl-formfile mh-clean-message-header-flag) - (mh-invalidate-show-buffer)) - (let ((mh-decode-mime-flag nil) - (mhl-formfile nil) - (mh-clean-message-header-flag nil)) - (mh-show-msg nil) - (mh-in-show-buffer (mh-show-buffer) - (goto-char (point-min)) - (mh-recenter 0)) - (setq mh-showing-with-headers t))) - -(defun mh-inc-folder (&optional maildrop-name) - "Inc(orporate)s new mail into the Inbox folder. -Optional argument MAILDROP-NAME specifies an alternate maildrop from the -default. If the prefix argument is given, incorporates mail into the current -folder, otherwise uses the folder named by `mh-inbox'. -The value of `mh-inc-folder-hook' is a list of functions to be called, with no -arguments, after incorporating new mail. -Do not call this function from outside MH-E; use \\[mh-rmail] instead." - (interactive (list (if current-prefix-arg - (expand-file-name - (read-file-name "inc mail from file: " - mh-user-path))))) - (let ((threading-needed-flag nil)) - (let ((config (current-window-configuration))) - (if (not maildrop-name) - (cond ((not (get-buffer mh-inbox)) - (mh-make-folder mh-inbox) - (setq threading-needed-flag mh-show-threads-flag) - (setq mh-previous-window-config config)) - ((not (eq (current-buffer) (get-buffer mh-inbox))) - (switch-to-buffer mh-inbox) - (setq mh-previous-window-config config))))) - (mh-get-new-mail maildrop-name) - (when (and threading-needed-flag - (save-excursion - (goto-char (point-min)) - (or (null mh-large-folder) - (not (equal (forward-line mh-large-folder) 0)) - (and (message "Not threading since the number of messages exceeds `mh-large-folder'") - nil)))) - (mh-toggle-threads)) - (if mh-showing-mode (mh-show)) - (run-hooks 'mh-inc-folder-hook))) - -(defun mh-last-msg () - "Move to the last message." - (interactive) - (goto-char (point-max)) - (while (and (not (bobp)) (not (looking-at mh-scan-valid-regexp))) - (forward-line -1)) - (mh-recenter nil)) - -(defun mh-next-undeleted-msg (&optional arg) - "Move to the next undeleted message ARG in window." - (interactive "p") - (setq mh-next-direction 'forward) - (forward-line 1) - (cond ((re-search-forward mh-scan-good-msg-regexp nil t arg) - (beginning-of-line) - (mh-maybe-show)) - (t (forward-line -1) - (message "No more undeleted messages")))) - -(defun mh-refile-msg (msg-or-seq folder) - "Refile MSG-OR-SEQ (default: displayed message) into FOLDER. -If optional prefix argument provided, then prompt for message sequence. -If variable `transient-mark-mode' is non-nil and the mark is active, then the -selected region is marked for refiling." - (interactive - (list (cond - ((mh-mark-active-p t) - (mh-region-to-msg-list (region-beginning) (region-end))) - (current-prefix-arg - (mh-read-seq-default "Refile" t)) - (t - (mh-get-msg-num t))) - (intern - (mh-prompt-for-folder - "Destination" - (or (and mh-default-folder-for-message-function - (let ((refile-file (mh-msg-filename (mh-get-msg-num t)))) - (save-excursion - (set-buffer (get-buffer-create mh-temp-buffer)) - (erase-buffer) - (insert-file-contents refile-file) - (let ((buffer-file-name refile-file)) - (funcall mh-default-folder-for-message-function))))) - (and (eq 'refile (car mh-last-destination-folder)) - (symbol-name (cdr mh-last-destination-folder))) - "") - t)))) - (setq mh-last-destination (cons 'refile folder) - mh-last-destination-folder mh-last-destination) - (if (numberp msg-or-seq) - (mh-refile-a-msg msg-or-seq folder) - (mh-map-to-seq-msgs 'mh-refile-a-msg msg-or-seq folder)) - (mh-next-msg)) - -(defun mh-refile-or-write-again (message) - "Re-execute the last refile or write command on the given MESSAGE. -Default is the displayed message. Use the same folder or file as the previous -refile or write command." - (interactive (list (mh-get-msg-num t))) - (if (null mh-last-destination) - (error "No previous refile or write")) - (cond ((eq (car mh-last-destination) 'refile) - (mh-refile-a-msg message (cdr mh-last-destination)) - (message "Destination folder: %s" (cdr mh-last-destination))) - (t - (apply 'mh-write-msg-to-file message (cdr mh-last-destination)) - (message "Destination: %s" (cdr mh-last-destination)))) - (mh-next-msg)) - -(defun mh-quit () - "Quit the current MH-E folder. -Restore the previous window configuration, if one exists. -The value of `mh-before-quit-hook' is a list of functions to be called, with -no arguments, immediately upon entry to this function. -The value of `mh-quit-hook' is a list of functions to be called, with no -arguments, upon exit of this function." - (interactive) - (run-hooks 'mh-before-quit-hook) - (let ((show-buffer (get-buffer mh-show-buffer))) - (when show-buffer - (kill-buffer show-buffer))) - (mh-update-sequences) - (mh-destroy-postponed-handles) - (bury-buffer (current-buffer)) - (if (get-buffer mh-temp-buffer) - (kill-buffer mh-temp-buffer)) - (if (get-buffer mh-temp-folders-buffer) - (kill-buffer mh-temp-folders-buffer)) - (if (get-buffer mh-temp-sequences-buffer) - (kill-buffer mh-temp-sequences-buffer)) - (if mh-previous-window-config - (set-window-configuration mh-previous-window-config)) - (run-hooks 'mh-quit-hook)) - -(defun mh-page-msg (&optional arg) - "Page the displayed message forwards. -Scrolls ARG lines or a full screen if no argument is supplied. Show buffer -first if not displayed. Show the next undeleted message if looking at the -bottom of the current message." - (interactive "P") - (if mh-showing-mode - (if mh-page-to-next-msg-flag - (if (equal mh-next-direction 'backward) - (mh-previous-undeleted-msg) - (mh-next-undeleted-msg)) - (if (mh-in-show-buffer (mh-show-buffer) - (pos-visible-in-window-p (point-max))) - (progn - (message (format - "End of message (Type %s to read %s undeleted message)" - (single-key-description last-input-event) - (if (equal mh-next-direction 'backward) - "previous" - "next"))) - (setq mh-page-to-next-msg-flag t)) - (scroll-other-window arg))) - (mh-show))) - -(defun mh-previous-page (&optional arg) - "Page the displayed message backwards. -Scrolls ARG lines or a full screen if no argument is supplied." - (interactive "P") - (mh-in-show-buffer (mh-show-buffer) - (scroll-down arg))) - -(defun mh-previous-undeleted-msg (&optional arg) - "Move to the previous undeleted message ARG in window." - (interactive "p") - (setq mh-next-direction 'backward) - (beginning-of-line) - (cond ((re-search-backward mh-scan-good-msg-regexp nil t arg) - (mh-maybe-show)) - (t (message "No previous undeleted message")))) - -(defun mh-previous-unread-msg (&optional count) - "Move to previous unread message. -With optional argument COUNT, COUNT-1 unread messages before current message -are skipped." - (interactive "p") - (unless (> count 0) - (error "The function mh-previous-unread-msg expects positive argument")) - (setq count (1- count)) - (let ((unread-sequence (cdr (assoc mh-unseen-seq mh-seq-list))) - (cur-msg (mh-get-msg-num nil))) - (cond ((and (not cur-msg) (not (bobp)) - ;; If we are at the end of the buffer back up one line and go - ;; to unread message after that. - (progn - (forward-line -1) - (setq cur-msg (mh-get-msg-num nil))) - nil)) - ((or (null unread-sequence) (not cur-msg)) - ;; No unread message or there aren't any messages in buffer... - (message "No more unread messages")) - ((progn - ;; Skip count messages... - (while (and unread-sequence (>= (car unread-sequence) cur-msg)) - (setq unread-sequence (cdr unread-sequence))) - (while (> count 0) - (setq unread-sequence (cdr unread-sequence)) - (setq count (1- count))) - (not (car unread-sequence))) - (message "No more unread messages")) - (t (mh-goto-msg (car unread-sequence)))))) - -(defun mh-goto-next-button (backward-flag &optional criterion) - "Search for next button satisfying criterion. -If BACKWARD-FLAG is non-nil search backward in the buffer for a mime button. If -CRITERION is a function or a symbol which has a function binding then that -function must return non-nil at the button we stop." - (unless (or (and (symbolp criterion) (fboundp criterion)) - (functionp criterion)) - (setq criterion (lambda (x) t))) - ;; Move to the next button in the buffer satisfying criterion - (goto-char (or (save-excursion - (beginning-of-line) - ;; Find point before current button - (let ((point-before-current-button - (save-excursion - (while (get-text-property (point) 'mh-data) - (unless (= (forward-line - (if backward-flag 1 -1)) - 0) - (if backward-flag - (goto-char (point-min)) - (goto-char (point-max))))) - (point)))) - ;; Skip over current button - (while (and (get-text-property (point) 'mh-data) - (not (if backward-flag (bobp) (eobp)))) - (forward-line (if backward-flag -1 1))) - ;; Stop at next MIME button if any exists. - (block loop - (while (/= (progn - (unless (= (forward-line - (if backward-flag -1 1)) - 0) - (if backward-flag - (goto-char (point-max)) - (goto-char (point-min))) - (beginning-of-line)) - (point)) - point-before-current-button) - (when (and (get-text-property (point) 'mh-data) - (funcall criterion (point))) - (return-from loop (point)))) - nil))) - (point)))) - -(defun mh-next-button (&optional backward-flag) - "Go to the next MIME button. -Advance point to the next MIME button in the show buffer. If the end -of buffer is reached then the search wraps over to the start of the -buffer. With prefix argument, BACKWARD-FLAG the point will move to the -previous MIME button." - (interactive (list current-prefix-arg)) - (unless mh-showing-mode - (mh-show)) - (mh-in-show-buffer (mh-show-buffer) - (mh-goto-next-button backward-flag))) - -(defun mh-prev-button () - "Go to the prev MIME button. -Move point to the previous MIME button in the show buffer. If the beginning -of the buffer is reached then the search wraps over to the end of the -buffer." - (interactive) - (mh-next-button t)) - -(defun mh-folder-mime-action (part-index action include-security-flag) - "Go to PART-INDEX and carry out ACTION. -If PART-INDEX is nil then go to the next part in the buffer. The search for -the next buffer wraps around if end of buffer is reached. If argument -INCLUDE-SECURITY-FLAG is non-nil then include security info buttons when -searching for a suitable parts." - (unless mh-showing-mode - (mh-show)) - (mh-in-show-buffer (mh-show-buffer) - (let ((criterion - (cond (part-index - (lambda (p) - (let ((part (get-text-property p 'mh-part))) - (and (integerp part) (= part part-index))))) - (t (lambda (p) - (if include-security-flag - (get-text-property p 'mh-data) - (integerp (get-text-property p 'mh-part))))))) - (point (point))) - (cond ((and (get-text-property point 'mh-part) - (or (null part-index) - (= (get-text-property point 'mh-part) part-index))) - (funcall action)) - ((and (get-text-property point 'mh-data) - include-security-flag - (null part-index)) - (funcall action)) - (t - (mh-goto-next-button nil criterion) - (if (= (point) point) - (message "No matching MIME part found") - (funcall action))))))) - -(defun mh-folder-toggle-mime-part (part-index) - "Toggle display of button. -If point in show buffer is at a button then that part is toggled. -If not at a button and PART-INDEX is non-nil point is moved to that part. -With nil PART-INDEX find the first button after point (search wraps around if -end of buffer is reached) and toggle it." - (interactive "P") - (when (consp part-index) (setq part-index (car part-index))) - (mh-folder-mime-action part-index #'mh-press-button t)) - -(defun mh-folder-inline-mime-part (part-index) - "Show the raw bytes of MIME part inline. -If point in show buffer is at a mime part then that part is inlined. -If not at a mime-part and PART-INDEX is non-nil point is moved to that part. -With nil PART-INDEX find the first button after point (search wraps around if -end of buffer is reached) and inline it." - (interactive "P") - (when (consp part-index) (setq part-index (car part-index))) - (mh-folder-mime-action part-index #'mh-mime-inline-part nil)) - -(defun mh-folder-save-mime-part (part-index) - "Save MIME part. -If point in show buffer is at a mime part then that part is saved. -If not at a mime-part and PART-INDEX is non-nil point is moved to that part. -With nil PART-INDEX find the first button after point (search wraps around if -end of buffer is reached) and save it." - (interactive "P") - (when (consp part-index) (setq part-index (car part-index))) - (mh-folder-mime-action part-index #'mh-mime-save-part nil)) - -(defun mh-reset-threads-and-narrowing () - "Reset all variables pertaining to threads and narrowing. -Also removes all content from the folder buffer." - (setq mh-view-ops ()) - (setq mh-narrowed-to-seq nil) - (let ((buffer-read-only nil)) (erase-buffer))) - -(defun mh-rescan-folder (&optional range dont-exec-pending) - "Rescan a folder after optionally processing the outstanding commands. -If optional prefix argument RANGE is provided, prompt for the range of -messages to display. Otherwise show the entire folder. -If optional argument DONT-EXEC-PENDING is non-nil then pending deletes and -refiles aren't carried out." - (interactive (list (if current-prefix-arg - (mh-read-msg-range mh-current-folder t) - nil))) - (setq mh-next-direction 'forward) - (let ((threaded-flag (memq 'unthread mh-view-ops))) - (mh-reset-threads-and-narrowing) - (mh-scan-folder mh-current-folder (or range "all") dont-exec-pending) - (cond (threaded-flag (mh-toggle-threads)) - (mh-index-data (mh-index-insert-folder-headers))))) - -(defun mh-write-msg-to-file (msg file no-headers) - "Append MSG to the end of a FILE. -If prefix argument NO-HEADERS is provided, write only the message body. -Otherwise send the entire message including the headers." - (interactive - (list (mh-get-msg-num t) - (let ((default-dir (if (eq 'write (car mh-last-destination-write)) - (file-name-directory - (car (cdr mh-last-destination-write))) - default-directory))) - (read-file-name (format "Save message%s in file: " - (if current-prefix-arg " body" "")) - default-dir - (if (eq 'write (car mh-last-destination-write)) - (car (cdr mh-last-destination-write)) - (expand-file-name "mail.out" default-dir)))) - current-prefix-arg)) - (let ((msg-file-to-output (mh-msg-filename msg)) - (output-file (mh-expand-file-name file))) - (setq mh-last-destination (list 'write file (if no-headers 'no-headers)) - mh-last-destination-write mh-last-destination) - (save-excursion - (set-buffer (get-buffer-create mh-temp-buffer)) - (erase-buffer) - (insert-file-contents msg-file-to-output) - (goto-char (point-min)) - (if no-headers (search-forward "\n\n")) - (append-to-file (point) (point-max) output-file)))) - -(defun mh-toggle-showing () - "Toggle the scanning mode/showing mode of displaying messages." - (interactive) - (if mh-showing-mode - (mh-set-scan-mode) - (mh-show))) - -(defun mh-undo (msg-or-seq) - "Undo the pending deletion or refile of the specified MSG-OR-SEQ. -Default is the displayed message. -If optional prefix argument is provided, then prompt for the message sequence. -If variable `transient-mark-mode' is non-nil and the mark is active, then the -selected region is unmarked." - (interactive (list (cond - ((mh-mark-active-p t) - (mh-region-to-msg-list (region-beginning) (region-end))) - (current-prefix-arg - (mh-read-seq-default "Undo" t)) - (t - (mh-get-msg-num t))))) - (cond ((numberp msg-or-seq) - (let ((original-position (point))) - (beginning-of-line) - (while (not (or (looking-at mh-scan-deleted-msg-regexp) - (looking-at mh-scan-refiled-msg-regexp) - (and (eq mh-next-direction 'forward) (bobp)) - (and (eq mh-next-direction 'backward) - (save-excursion (forward-line) (eobp))))) - (forward-line (if (eq mh-next-direction 'forward) -1 1))) - (if (or (looking-at mh-scan-deleted-msg-regexp) - (looking-at mh-scan-refiled-msg-regexp)) - (progn - (mh-undo-msg (mh-get-msg-num t)) - (mh-maybe-show)) - (goto-char original-position) - (error "Nothing to undo")))) - (t - (mh-map-to-seq-msgs 'mh-undo-msg msg-or-seq))) - (if (not (mh-outstanding-commands-p)) - (mh-set-folder-modified-p nil))) - -;;;###mh-autoload -(defun mh-folder-line-matches-show-buffer-p () - "Return t if the message under point in folder-mode is in the show buffer. -Return nil in any other circumstance (no message under point, no show buffer, -the message in the show buffer doesn't match." - (and (eq major-mode 'mh-folder-mode) - (mh-get-msg-num nil) - mh-show-buffer - (get-buffer mh-show-buffer) - (buffer-file-name (get-buffer mh-show-buffer)) - (string-match ".*/\\([0-9]+\\)$" - (buffer-file-name (get-buffer mh-show-buffer))) - (string-equal - (match-string 1 (buffer-file-name (get-buffer mh-show-buffer))) - (int-to-string (mh-get-msg-num nil))))) - -(eval-when-compile (require 'gnus)) - -(defmacro mh-macro-expansion-time-gnus-version () - "Return Gnus version available at macro expansion time. -The macro evaluates the Gnus version at macro expansion time. If MH-E was -compiled then macro expansion happens at compile time." - gnus-version) - -(defun mh-run-time-gnus-version () - "Return Gnus version available at run time." - (require 'gnus) - gnus-version) - -;;;###autoload -(defun mh-version () - "Display version information about MH-E and the MH mail handling system." - (interactive) - (mh-find-progs) - (set-buffer (get-buffer-create mh-temp-buffer)) - (erase-buffer) - ;; MH-E version. - (insert "MH-E " mh-version "\n\n") - ;; MH-E compilation details. - (insert "MH-E compilation details:\n") - (let* ((compiled-mhe (byte-code-function-p (symbol-function 'mh-version))) - (gnus-compiled-version (if compiled-mhe - (mh-macro-expansion-time-gnus-version) - "N/A"))) - (insert " Byte compiled:\t\t" (if compiled-mhe "yes" "no") "\n" - " Gnus (compile-time):\t" gnus-compiled-version "\n" - " Gnus (run-time):\t" (mh-run-time-gnus-version) "\n\n")) - ;; Emacs version. - (insert (emacs-version) "\n\n") - ;; MH version. - (let ((help-start (point))) - (condition-case err-data - (mh-exec-cmd-output "inc" nil (if mh-nmh-flag "-version" "-help")) - (file-error (insert (mapconcat 'concat (cdr err-data) ": ") "\n"))) - (goto-char help-start) - (if mh-nmh-flag - (search-forward "inc -- " nil t) - (search-forward "version: " nil t)) - (delete-region help-start (point))) - (goto-char (point-max)) - (insert " mh-progs:\t" mh-progs "\n" - " mh-lib:\t" mh-lib "\n" - " mh-lib-progs:\t" mh-lib-progs "\n\n") - ;; Linux version. - (condition-case () - (call-process "uname" nil t nil "-a") - (file-error)) - (goto-char (point-min)) - (display-buffer mh-temp-buffer)) - -(defun mh-parse-flist-output-line (line) - "Parse LINE to generate folder name, unseen messages and total messages." - (with-temp-buffer - (insert line) - (goto-char (point-max)) - (let (folder unseen total p) - (when (search-backward " out of " (point-min) t) - (setq total (read-from-string - (buffer-substring-no-properties - (match-end 0) (line-end-position)))) - (when (search-backward " in sequence " (point-min) t) - (setq p (point)) - (when (search-backward " has " (point-min) t) - (setq unseen (read-from-string (buffer-substring-no-properties - (match-end 0) p))) - (while (or (eq (char-after) ?+) (eq (char-after) ? )) - (backward-char)) - (setq folder (buffer-substring-no-properties - (point-min) (1+ (point)))) - (values (format "+%s" folder) (car unseen) (car total)))))))) - -(defun mh-folder-size (folder) - "Find size of FOLDER." - (with-temp-buffer - (call-process (expand-file-name "flist" mh-progs) nil t nil - "-norecurse" folder) - (goto-char (point-min)) - (multiple-value-bind (folder1 unseen total) - (mh-parse-flist-output-line - (buffer-substring (point) (line-end-position))) - (unless (equal folder folder1) - (error "Call to flist failed on folder %s" folder)) - (values total unseen)))) - -(defun mh-visit-folder (folder &optional range index-data) - "Visit FOLDER and display RANGE of messages. -Do not call this function from outside MH-E; see \\[mh-rmail] instead. - -If RANGE is nil (the default if it is omitted when called non-interactively), -then all messages in FOLDER are displayed. - -If an index buffer is being created then INDEX-DATA is used to initialize the -index buffer specific data structures." - (interactive (let ((folder-name (mh-prompt-for-folder "Visit" mh-inbox t))) - (list folder-name (mh-read-msg-range folder-name)))) - (let ((config (current-window-configuration)) - (threaded-view-flag mh-show-threads-flag)) - (save-excursion - (when (get-buffer folder) - (set-buffer folder) - (setq threaded-view-flag (memq 'unthread mh-view-ops)) - (mh-reset-threads-and-narrowing))) - (when index-data - (mh-make-folder folder) - (setq mh-index-data (car index-data) - mh-index-msg-checksum-map (make-hash-table :test #'equal) - mh-index-checksum-origin-map (make-hash-table :test #'equal)) - (mh-index-update-maps folder (cadr index-data))) - (mh-scan-folder folder (or range "all")) - (cond ((and threaded-view-flag - (save-excursion - (goto-char (point-min)) - (or (null mh-large-folder) - (not (equal (forward-line mh-large-folder) 0)) - (and (message "Not threading since the number of messages exceeds `mh-large-folder'") - nil)))) - (mh-toggle-threads)) - (mh-index-data - (mh-index-insert-folder-headers))) - (unless mh-showing-mode (delete-other-windows)) - (setq mh-previous-window-config config)) - nil) - -;;;###mh-autoload -(defun mh-update-sequences () - "Update MH's Unseen-Sequence and current folder and message. -Flush MH-E's state out to MH. The message at the cursor becomes current." - (interactive) - ;; mh-update-sequences is the opposite of mh-read-folder-sequences, - ;; which updates MH-E's state from MH. - (let ((folder-set (mh-update-unseen)) - (new-cur (mh-get-msg-num nil))) - (if new-cur - (let ((seq-entry (mh-find-seq 'cur))) - (mh-remove-cur-notation) - (setcdr seq-entry - (list new-cur)) ;delete-seq-locally, add-msgs-to-seq - (mh-define-sequence 'cur (list new-cur)) - (beginning-of-line) - (if (looking-at mh-scan-good-msg-regexp) - (mh-notate nil mh-note-cur mh-cmd-note))) - (or folder-set - (save-excursion - ;; psg - mh-current-folder is nil if mh-summary-height < 4 ! - ;; So I added this sanity check. - (if (stringp mh-current-folder) - (mh-exec-cmd-quiet t "folder" mh-current-folder "-fast") - (mh-exec-cmd-quiet t "folder" "-fast"))))))) - - - -;;; Support routines. - -(defun mh-delete-a-msg (msg) - "Delete the MSG. -The value of `mh-delete-msg-hook' is a list of functions to be called, with no -arguments, after the message has been deleted." - (save-excursion - (mh-goto-msg msg nil t) - (if (looking-at mh-scan-refiled-msg-regexp) - (error "Message %d is refiled. Undo refile before deleting" msg)) - (if (looking-at mh-scan-deleted-msg-regexp) - nil - (mh-set-folder-modified-p t) - (setq mh-delete-list (cons msg mh-delete-list)) - (mh-notate msg mh-note-deleted mh-cmd-note) - (run-hooks 'mh-delete-msg-hook)))) - -(defun mh-refile-a-msg (msg folder) - "Refile MSG in FOLDER. -Folder is a symbol, not a string. -The value of `mh-refile-msg-hook' is a list of functions to be called, with no -arguments, after the message has been refiled." - (save-excursion - (mh-goto-msg msg nil t) - (cond ((looking-at mh-scan-deleted-msg-regexp) - (error "Message %d is deleted. Undo delete before moving" msg)) - ((looking-at mh-scan-refiled-msg-regexp) - (if (y-or-n-p - (format "Message %d already refiled. Copy to %s as well? " - msg folder)) - (mh-exec-cmd "refile" (mh-get-msg-num t) "-link" - "-src" mh-current-folder - (symbol-name folder)) - (message "Message not copied."))) - (t - (mh-set-folder-modified-p t) - (cond ((null (assoc folder mh-refile-list)) - (push (list folder msg) mh-refile-list)) - ((not (member msg (cdr (assoc folder mh-refile-list)))) - (push msg (cdr (assoc folder mh-refile-list))))) - (mh-notate msg mh-note-refiled mh-cmd-note) - (run-hooks 'mh-refile-msg-hook))))) - -(defun mh-next-msg () - "Move backward or forward to the next undeleted message in the buffer." - (if (eq mh-next-direction 'forward) - (mh-next-undeleted-msg 1) - (mh-previous-undeleted-msg 1))) - -(defun mh-next-unread-msg (&optional count) - "Move to next unread message. -With optional argument COUNT, COUNT-1 unread messages are skipped." - (interactive "p") - (unless (> count 0) - (error "The function mh-next-unread-msg expects positive argument")) - (setq count (1- count)) - (let ((unread-sequence (reverse (cdr (assoc mh-unseen-seq mh-seq-list)))) - (cur-msg (mh-get-msg-num nil))) - (cond ((and (not cur-msg) (not (bobp)) - ;; If we are at the end of the buffer back up one line and go - ;; to unread message after that. - (progn - (forward-line -1) - (setq cur-msg (mh-get-msg-num nil))) - nil)) - ((or (null unread-sequence) (not cur-msg)) - ;; No unread message or there aren't any messages in buffer... - (message "No more unread messages")) - ((progn - ;; Skip messages - (while (and unread-sequence (>= cur-msg (car unread-sequence))) - (setq unread-sequence (cdr unread-sequence))) - (while (> count 0) - (setq unread-sequence (cdr unread-sequence)) - (setq count (1- count))) - (not (car unread-sequence))) - (message "No more unread messages")) - (t (mh-goto-msg (car unread-sequence)))))) - -(defun mh-set-scan-mode () - "Display the scan listing buffer, but do not show a message." - (if (get-buffer mh-show-buffer) - (delete-windows-on mh-show-buffer)) - (mh-showing-mode 0) - (force-mode-line-update) - (if mh-recenter-summary-flag - (mh-recenter nil))) - -(defun mh-undo-msg (msg) - "Undo the deletion or refile of one MSG." - (cond ((memq msg mh-delete-list) - (setq mh-delete-list (delq msg mh-delete-list))) - (t - (dolist (folder-msg-list mh-refile-list) - (setf (cdr folder-msg-list) (remove msg (cdr folder-msg-list)))) - (setq mh-refile-list (loop for x in mh-refile-list - unless (null (cdr x)) collect x)))) - (mh-notate msg ? mh-cmd-note)) - - - -;;; The folder data abstraction. - -(defun mh-make-folder (name) - "Create a new mail folder called NAME. -Make it the current folder." - (switch-to-buffer name) - (setq buffer-read-only nil) - (erase-buffer) - (if mh-adaptive-cmd-note-flag - (mh-set-cmd-note (mh-message-number-width name))) - (setq buffer-read-only t) - (mh-folder-mode) - (mh-set-folder-modified-p nil) - (setq buffer-file-name mh-folder-filename) - (mh-make-folder-mode-line)) - -;;; Ensure new buffers won't get this mode if default-major-mode is nil. -(put 'mh-folder-mode 'mode-class 'special) - - - -;;; Menu extracted from mh-menubar.el V1.1 (31 July 2001) -;;; Menus for folder mode: folder, message, sequence (in that order) -;;; folder-mode "Sequence" menu -(easy-menu-define - mh-folder-sequence-menu mh-folder-mode-map "Menu for MH-E folder-sequence." - '("Sequence" - ["Add Message to Sequence..." mh-put-msg-in-seq (mh-get-msg-num nil)] - ["List Sequences for Message" mh-msg-is-in-seq (mh-get-msg-num nil)] - ["Delete Message from Sequence..." mh-delete-msg-from-seq - (mh-get-msg-num nil)] - ["List Sequences in Folder..." mh-list-sequences t] - ["Delete Sequence..." mh-delete-seq t] - ["Narrow to Sequence..." mh-narrow-to-seq t] - ["Widen from Sequence" mh-widen mh-narrowed-to-seq] - "--" - ["Narrow to Subject Sequence" mh-narrow-to-subject t] - ["Delete Rest of Same Subject" mh-delete-subject t] - "--" - ["Push State Out to MH" mh-update-sequences t])) - -;;; folder-mode "Message" menu -(easy-menu-define - mh-folder-message-menu mh-folder-mode-map "Menu for MH-E folder-message." - '("Message" - ["Show Message" mh-show (mh-get-msg-num nil)] - ["Show Message with Header" mh-header-display (mh-get-msg-num nil)] - ["Next Message" mh-next-undeleted-msg t] - ["Previous Message" mh-previous-undeleted-msg t] - ["Go to First Message" mh-first-msg t] - ["Go to Last Message" mh-last-msg t] - ["Go to Message by Number..." mh-goto-msg t] - ["Modify Message" mh-modify] - ["Delete Message" mh-delete-msg (mh-get-msg-num nil)] - ["Refile Message" mh-refile-msg (mh-get-msg-num nil)] - ["Undo Delete/Refile" mh-undo t] - ["Process Delete/Refile" mh-execute-commands - (or mh-refile-list mh-delete-list)] - "--" - ["Compose a New Message" mh-send t] - ["Reply to Message..." mh-reply (mh-get-msg-num nil)] - ["Forward Message..." mh-forward (mh-get-msg-num nil)] - ["Redistribute Message..." mh-redistribute (mh-get-msg-num nil)] - ["Edit Message Again" mh-edit-again (mh-get-msg-num nil)] - ["Re-edit a Bounced Message" mh-extract-rejected-mail t] - "--" - ["Copy Message to Folder..." mh-copy-msg (mh-get-msg-num nil)] - ["Print Message" mh-print-msg (mh-get-msg-num nil)] - ["Write Message to File..." mh-write-msg-to-file - (mh-get-msg-num nil)] - ["Pipe Message to Command..." mh-pipe-msg (mh-get-msg-num nil)] - ["Unpack Uuencoded Message..." mh-store-msg (mh-get-msg-num nil)] - ["Burst Digest Message" mh-burst-digest (mh-get-msg-num nil)])) - -;;; folder-mode "Folder" menu -(easy-menu-define - mh-folder-folder-menu mh-folder-mode-map "Menu for MH-E folder." - '("Folder" - ["Incorporate New Mail" mh-inc-folder t] - ["Toggle Show/Folder" mh-toggle-showing t] - ["Execute Delete/Refile" mh-execute-commands - (or mh-refile-list mh-delete-list)] - ["Rescan Folder" mh-rescan-folder t] - ["Thread Folder" mh-toggle-threads - (not (memq 'unthread mh-view-ops))] - ["Pack Folder" mh-pack-folder t] - ["Sort Folder" mh-sort-folder t] - "--" - ["List Folders" mh-list-folders t] - ["Visit a Folder..." mh-visit-folder t] - ["Search a Folder..." mh-search-folder t] - ["Indexed Search..." mh-index-search t] - "--" - ["Quit MH-E" mh-quit t])) - - - -(defmacro mh-remove-xemacs-horizontal-scrollbar () - "Get rid of the horizontal scrollbar that XEmacs insists on putting in." - (when mh-xemacs-flag - `(if (and (featurep 'scrollbar) - (fboundp 'set-specifier)) - (set-specifier horizontal-scrollbar-visible-p nil - (cons (current-buffer) nil))))) - -(defmacro mh-write-file-functions-compat () - "Return `write-file-functions' if it exists. -Otherwise return `local-write-file-hooks'. This macro exists purely for -compatibility. The former symbol is used in Emacs 21.4 onward while the latter -is used in previous versions and XEmacs." - (if (boundp 'write-file-functions) - ''write-file-functions ;Emacs 21.4 - ''local-write-file-hooks)) ;<Emacs 21.4, XEmacs - -(define-derived-mode mh-folder-mode fundamental-mode "MH-Folder" - "Major MH-E mode for \"editing\" an MH folder scan listing.\\<mh-folder-mode-map> - -You can show the message the cursor is pointing to, and step through the -messages. Messages can be marked for deletion or refiling into another -folder; these commands are executed all at once with a separate command. - -A prefix argument (\\[universal-argument]) to delete, refile, list, or undo -applies the action to a message sequence. If `transient-mark-mode', -is non-nil, the action is applied to the region. - -Options that control this mode can be changed with \\[customize-group]; -specify the \"mh\" group. In particular, please see the `mh-scan-format-file' -option if you wish to modify scan's format. - -When a folder is visited, the hook `mh-folder-mode-hook' is run. - -\\{mh-folder-mode-map}" - - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults '(mh-folder-font-lock-keywords t)) - (mh-make-local-vars - 'mh-current-folder (buffer-name) ; Name of folder, a string - 'mh-show-buffer (format "show-%s" (buffer-name)) ; Buffer that displays msgs - 'mh-folder-filename ; e.g. "/usr/foobar/Mail/inbox/" - (file-name-as-directory (mh-expand-file-name (buffer-name))) - 'mh-showing-mode nil ; Show message also? - 'mh-delete-list nil ; List of msgs nums to delete - 'mh-refile-list nil ; List of folder names in mh-seq-list - 'mh-seq-list nil ; Alist of (seq . msgs) nums - 'mh-seen-list nil ; List of displayed messages - 'mh-next-direction 'forward ; Direction to move to next message - 'mh-narrowed-to-seq nil ; Sequence display is narrowed to - 'mh-view-ops () ; Stack that keeps track of the order - ; in which narrowing/threading has been - ; carried out. - 'mh-index-data nil ; If the folder was created by a call - ; to mh-index-search this contains info - ; about the search results. - 'mh-index-previous-search nil ; Previous folder and search-regexp - 'mh-index-msg-checksum-map nil ; msg -> checksum map - 'mh-index-checksum-origin-map nil ; checksum -> ( orig-folder, orig-msg ) - 'mh-first-msg-num nil ; Number of first msg in buffer - 'mh-last-msg-num nil ; Number of last msg in buffer - 'mh-msg-count nil ; Number of msgs in buffer - 'mh-mode-line-annotation nil ; Indicates message range - 'mh-previous-window-config nil) ; Previous window configuration - (mh-remove-xemacs-horizontal-scrollbar) - (setq truncate-lines t) - (auto-save-mode -1) - (setq buffer-offer-save t) - (add-hook (mh-write-file-functions-compat) 'mh-execute-commands nil t) - (make-local-variable 'revert-buffer-function) - (make-local-variable 'hl-line-mode) ; avoid pollution - (if (fboundp 'hl-line-mode) - (hl-line-mode 1)) - (setq revert-buffer-function 'mh-undo-folder) - (or (assq 'mh-showing-mode minor-mode-alist) - (setq minor-mode-alist - (cons '(mh-showing-mode " Show") minor-mode-alist))) - (easy-menu-add mh-folder-sequence-menu) - (easy-menu-add mh-folder-message-menu) - (easy-menu-add mh-folder-folder-menu) - (if (and (boundp 'tool-bar-mode) tool-bar-mode) - (set (make-local-variable 'tool-bar-map) mh-folder-tool-bar-map)) - (if (and mh-xemacs-flag - font-lock-auto-fontify) - (turn-on-font-lock))) ; Force font-lock in XEmacs. - -(defun mh-make-local-vars (&rest pairs) - "Initialize local variables according to the variable-value PAIRS." - - (while pairs - (set (make-local-variable (car pairs)) (car (cdr pairs))) - (setq pairs (cdr (cdr pairs))))) - -(defun mh-scan-folder (folder range &optional dont-exec-pending) - "Scan the FOLDER over the RANGE. -If the optional argument DONT-EXEC-PENDING is non-nil then pending deletes and -refiles aren't carried out. -Return in the folder's buffer." - (cond ((null (get-buffer folder)) - (mh-make-folder folder)) - (t - (or dont-exec-pending (mh-process-or-undo-commands folder)) - (switch-to-buffer folder))) - (mh-regenerate-headers range) - (if (zerop (buffer-size)) - (if (equal range "all") - (message "Folder %s is empty" folder) - (message "No messages in %s, range %s" folder range)) - (mh-goto-cur-msg)) - (save-excursion - (when dont-exec-pending - ;; Re-annotate messages to be refiled... - (dolist (folder-msg-list mh-refile-list) - (dolist (msg (cdr folder-msg-list)) - (mh-notate msg mh-note-refiled mh-cmd-note))) - ;; Re-annotate messages to be deleted... - (dolist (msg mh-delete-list) - (mh-notate msg mh-note-deleted mh-cmd-note))))) - -(defun mh-set-cmd-note (width) - "Set `mh-cmd-note' to WIDTH characters (minimum of 2). - -If `mh-scan-format-file' specifies nil or a filename, then this function -will NOT update `mh-cmd-note'." - ;; Add one to the width to always have whitespace in column zero. - (setq width (max (1+ width) 2)) - (if (and (equal mh-scan-format-file t) - (not (eq mh-cmd-note width))) - (setq mh-cmd-note width)) - mh-cmd-note) - -(defun mh-regenerate-headers (range &optional update) - "Scan folder over range RANGE. -If UPDATE, append the scan lines, otherwise replace." - (let ((folder mh-current-folder) - (range (if (and range (atom range)) (list range) range)) - scan-start) - (message "Scanning %s..." folder) - (with-mh-folder-updating (nil) - (if update - (goto-char (point-max)) - (delete-region (point-min) (point-max)) - (if mh-adaptive-cmd-note-flag - (mh-set-cmd-note (mh-message-number-width folder)))) - (setq scan-start (point)) - (apply #'mh-exec-cmd-output - mh-scan-prog nil - (mh-scan-format) - "-noclear" "-noheader" - "-width" (window-width) - folder range) - (goto-char scan-start) - (cond ((looking-at "scan: no messages in") - (keep-lines mh-scan-valid-regexp)) ; Flush random scan lines - ((looking-at "scan: bad message list ") - (keep-lines mh-scan-valid-regexp)) - ((looking-at "scan: ")) ; Keep error messages - (t - (keep-lines mh-scan-valid-regexp))) ; Flush random scan lines - (setq mh-seq-list (mh-read-folder-sequences folder nil)) - (mh-notate-user-sequences) - (or update - (setq mh-mode-line-annotation - (if (equal range '("all")) - nil - mh-partial-folder-mode-line-annotation))) - (mh-make-folder-mode-line)) - (message "Scanning %s...done" folder))) - -(defun mh-generate-new-cmd-note (folder) - "Fix the `mh-cmd-note' value for this FOLDER. - -After doing an `mh-get-new-mail' operation in this FOLDER, at least -one line that looks like a truncated message number was found. - -Remove the text added by the last `mh-inc' command. It should be the -messages cur-last. Call `mh-set-cmd-note' with the widest message number -in FOLDER. - -Reformat the message number width on each line in the buffer and trim -the line length to fit in the window. - -Rescan the FOLDER in the range cur-last in order to display the -messages that were removed earlier. They should all fit in the scan -line now with no message truncation." - (save-excursion - (let ((maxcol (1- (window-width))) - (old-cmd-note mh-cmd-note) - mh-cmd-note-fmt - msgnum) - ;; Nuke all of the lines just added by the last inc - (delete-char (- (point-max) (point))) - ;; Update the current buffer to reflect the new mh-cmd-note - ;; value needed to display messages. - (mh-set-cmd-note (mh-message-number-width folder)) - (setq mh-cmd-note-fmt (concat "%" (format "%d" mh-cmd-note) "d")) - ;; Cleanup the messages that are in the buffer right now - (goto-char (point-min)) - (cond ((memq 'unthread mh-view-ops) - (mh-thread-add-spaces (- mh-cmd-note old-cmd-note))) - (t (while (re-search-forward mh-scan-msg-number-regexp nil 0 1) - ;; reformat the number to fix in mh-cmd-note columns - (setq msgnum (string-to-number - (buffer-substring - (match-beginning 1) (match-end 1)))) - (replace-match (format mh-cmd-note-fmt msgnum)) - ;; trim the line to fix in the window - (end-of-line) - (let ((eol (point))) - (move-to-column maxcol) - (if (<= (point) eol) - (delete-char (- eol (point)))))))) - ;; now re-read the lost messages - (goto-char (point-max)) - (prog1 (point) - (mh-regenerate-headers "cur-last" t))))) - -(defun mh-get-new-mail (maildrop-name) - "Read new mail from MAILDROP-NAME into the current buffer. -Return in the current buffer." - (let ((point-before-inc (point)) - (folder mh-current-folder) - (new-mail-flag nil)) - (with-mh-folder-updating (t) - (if maildrop-name - (message "inc %s -file %s..." folder maildrop-name) - (message "inc %s..." folder)) - (setq mh-next-direction 'forward) - (goto-char (point-max)) - (let ((start-of-inc (point))) - (mh-remove-cur-notation) - (if maildrop-name - ;; I think MH 5 used "-ms-file" instead of "-file", - ;; which would make inc'ing from maildrops fail. - (mh-exec-cmd-output mh-inc-prog nil folder - (mh-scan-format) - "-file" (expand-file-name maildrop-name) - "-width" (window-width) - "-truncate") - (mh-exec-cmd-output mh-inc-prog nil - (mh-scan-format) - "-width" (window-width))) - (if maildrop-name - (message "inc %s -file %s...done" folder maildrop-name) - (message "inc %s...done" folder)) - (goto-char start-of-inc) - (cond ((save-excursion - (re-search-forward "^inc: no mail" nil t)) - (message "No new mail%s%s" (if maildrop-name " in " "") - (if maildrop-name maildrop-name ""))) - ((and (when mh-narrowed-to-seq - (let ((saved-text (buffer-substring-no-properties - start-of-inc (point-max)))) - (delete-region start-of-inc (point-max)) - (unwind-protect (mh-widen) - (goto-char (point-max)) - (setq start-of-inc (point)) - (insert saved-text) - (goto-char start-of-inc)))) - nil)) - ((re-search-forward "^inc:" nil t) ; Error messages - (error "Error incorporating mail")) - ((and - (equal mh-scan-format-file t) - mh-adaptive-cmd-note-flag - ;; Have we reached an edge condition? - (save-excursion - (re-search-forward mh-scan-msg-overflow-regexp nil 0 1)) - (setq start-of-inc (mh-generate-new-cmd-note folder)) - nil)) - (t - (setq new-mail-flag t))) - (keep-lines mh-scan-valid-regexp) ; Flush random scan lines - (setq mh-seq-list (mh-read-folder-sequences folder t)) - (when (equal (point-max) start-of-inc) - (mh-notate-seq 'cur mh-note-cur mh-cmd-note)) - (mh-notate-user-sequences) - (if new-mail-flag - (progn - (mh-make-folder-mode-line) - (when (memq 'unthread mh-view-ops) - (mh-thread-inc folder start-of-inc)) - (mh-goto-cur-msg)) - (goto-char point-before-inc)))))) - -(defun mh-make-folder-mode-line (&optional ignored) - "Set the fields of the mode line for a folder buffer. -The optional argument is now obsolete and IGNORED. It used to be used to pass -in what is now stored in the buffer-local variable `mh-mode-line-annotation'." - (save-excursion - (save-window-excursion - (mh-first-msg) - (let ((new-first-msg-num (mh-get-msg-num nil))) - (when (or (not (memq 'unthread mh-view-ops)) - (null mh-first-msg-num) - (null new-first-msg-num) - (< new-first-msg-num mh-first-msg-num)) - (setq mh-first-msg-num new-first-msg-num))) - (mh-last-msg) - (let ((new-last-msg-num (mh-get-msg-num nil))) - (when (or (not (memq 'unthread mh-view-ops)) - (null mh-last-msg-num) - (null new-last-msg-num) - (> new-last-msg-num mh-last-msg-num)) - (setq mh-last-msg-num new-last-msg-num))) - (setq mh-msg-count (if mh-first-msg-num - (count-lines (point-min) (point-max)) - 0)) - (setq mode-line-buffer-identification - (list (format "{%%b%s} %s msg%s" - (if mh-mode-line-annotation - (format "/%s" mh-mode-line-annotation) - "") - (if (zerop mh-msg-count) - "no" - (format "%d" mh-msg-count)) - (if (zerop mh-msg-count) - "s" - (cond ((> mh-msg-count 1) - (format "s (%d-%d)" mh-first-msg-num - mh-last-msg-num)) - (mh-first-msg-num - (format " (%d)" mh-first-msg-num)) - (""))))))))) - -(defun mh-unmark-all-headers (remove-all-flags) - "Remove all '+' flags from the folder listing. -With non-nil argument REMOVE-ALL-FLAGS, remove all 'D', '^' and '%' flags too. -Optimized for speed (i.e., no regular expressions)." - (save-excursion - (let ((case-fold-search nil) - (last-line (1- (point-max))) - char) - (mh-first-msg) - (while (<= (point) last-line) - (forward-char mh-cmd-note) - (setq char (following-char)) - (if (or (and remove-all-flags - (or (= char (aref mh-note-deleted 0)) - (= char (aref mh-note-refiled 0)))) - (= char (aref mh-note-cur 0))) - (progn - (delete-char 1) - (insert " "))) - (if remove-all-flags - (progn - (forward-char 1) - (if (= (following-char) (aref mh-note-seq 0)) - (progn - (delete-char 1) - (insert " "))))) - (forward-line))))) - -(defun mh-remove-cur-notation () - "Remove old cur notation." - (let ((cur-msg (car (mh-seq-to-msgs 'cur)))) - (save-excursion - (and cur-msg - (mh-goto-msg cur-msg t t) - (looking-at mh-scan-cur-msg-number-regexp) - (mh-notate nil ? mh-cmd-note))))) - -(defun mh-remove-all-notation () - "Remove all notations on all scan lines that MH-E introduces." - (save-excursion - (goto-char (point-min)) - (while (not (eobp)) - (unless (or (equal (char-after) ?+) (eolp)) - (mh-notate nil ? mh-cmd-note) - (when (eq (char-after (+ (point) mh-cmd-note 1)) (elt mh-note-seq 0)) - (mh-notate nil ? (1+ mh-cmd-note)))) - (forward-line)))) - -;;;###mh-autoload -(defun mh-goto-cur-msg (&optional minimal-changes-flag) - "Position the cursor at the current message. -When optional argument MINIMAL-CHANGES-FLAG is non-nil, the function doesn't -recenter the folder buffer." - (let ((cur-msg (car (mh-seq-to-msgs 'cur)))) - (cond ((and cur-msg - (mh-goto-msg cur-msg t t)) - (unless minimal-changes-flag - (mh-notate nil mh-note-cur mh-cmd-note) - (mh-recenter 0) - (mh-maybe-show cur-msg))) - (t - (message "No current message"))))) - -(defun mh-process-or-undo-commands (folder) - "If FOLDER has outstanding commands, then either process or discard them. -Called by functions like `mh-sort-folder', so also invalidate show buffer." - (set-buffer folder) - (if (mh-outstanding-commands-p) - (if (or mh-do-not-confirm-flag - (y-or-n-p - "Process outstanding deletes and refiles (or lose them)? ")) - (mh-process-commands folder) - (mh-undo-folder))) - (mh-update-unseen) - (mh-invalidate-show-buffer)) - -(defun mh-process-commands (folder) - "Process outstanding commands for FOLDER. -The value of `mh-folder-updated-hook' is a list of functions to be called, -with no arguments, before the commands are processed." - (message "Processing deletes and refiles for %s..." folder) - (set-buffer folder) - (with-mh-folder-updating (nil) - ;; Run the hook while the lists are still valid - (run-hooks 'mh-folder-updated-hook) - - ;; Update the unseen sequence if it exists - (mh-update-unseen) - - (let ((redraw-needed-flag mh-index-data)) - ;; Remove invalid scan lines if we are in an index folder and then remove - ;; the real messages - (when mh-index-data - (mh-index-delete-folder-headers) - (mh-index-execute-commands)) - - ;; Then refile messages - (mh-mapc #'(lambda (folder-msg-list) - (let ((dest-folder (symbol-name (car folder-msg-list))) - (msgs (cdr folder-msg-list))) - (setq redraw-needed-flag t) - (apply #'mh-exec-cmd - "refile" "-src" folder dest-folder - (mh-coalesce-msg-list msgs)) - (mh-delete-scan-msgs msgs))) - mh-refile-list) - (setq mh-refile-list ()) - - ;; Now delete messages - (cond (mh-delete-list - (setq redraw-needed-flag t) - (apply 'mh-exec-cmd "rmm" folder - (mh-coalesce-msg-list mh-delete-list)) - (mh-delete-scan-msgs mh-delete-list) - (setq mh-delete-list nil))) - - ;; Don't need to remove sequences since delete and refile do so. - ;; Mark cur message - (if (> (buffer-size) 0) - (mh-define-sequence 'cur (list (or (mh-get-msg-num nil) "last")))) - - ;; Redraw folder buffer if needed - (when (and redraw-needed-flag) - (cond ((memq 'unthread mh-view-ops) (mh-thread-inc folder (point-max))) - (mh-index-data (mh-index-insert-folder-headers))))) - - (and (buffer-file-name (get-buffer mh-show-buffer)) - (not (file-exists-p (buffer-file-name (get-buffer mh-show-buffer)))) - ;; If "inc" were to put a new msg in this file, - ;; we would not notice, so mark it invalid now. - (mh-invalidate-show-buffer)) - - (setq mh-seq-list (mh-read-folder-sequences mh-current-folder nil)) - (mh-unmark-all-headers t) - (mh-notate-user-sequences) - (message "Processing deletes and refiles for %s...done" folder))) - -(defun mh-update-unseen () - "Synchronize the unseen sequence with MH. -Return non-nil iff the MH folder was set. -The value of `mh-unseen-updated-hook' is a list of functions to be called, -with no arguments, after the unseen sequence is updated." - (if mh-seen-list - (let* ((unseen-seq (mh-find-seq mh-unseen-seq)) - (unseen-msgs (mh-seq-msgs unseen-seq))) - (if unseen-msgs - (progn - (mh-undefine-sequence mh-unseen-seq mh-seen-list) - (run-hooks 'mh-unseen-updated-hook) - (while mh-seen-list - (setq unseen-msgs (delq (car mh-seen-list) unseen-msgs)) - (setq mh-seen-list (cdr mh-seen-list))) - (setcdr unseen-seq unseen-msgs) - t) ;since we set the folder - (setq mh-seen-list nil))))) - -(defun mh-delete-scan-msgs (msgs) - "Delete the scan listing lines for MSGS." - (save-excursion - (while msgs - (when (mh-goto-msg (car msgs) t t) - (when (memq 'unthread mh-view-ops) - (mh-thread-forget-message (car msgs))) - (mh-delete-line 1)) - (setq msgs (cdr msgs))))) - -(defun mh-outstanding-commands-p () - "Return non-nil if there are outstanding deletes or refiles." - (or mh-delete-list mh-refile-list)) - -(defun mh-coalesce-msg-list (messages) - "Give a list of MESSAGES, return a list of message number ranges. -Sort of the opposite of `mh-read-msg-list', which expands ranges. -Message lists passed to MH programs go through this so -command line arguments won't exceed system limits." - (let ((msgs (sort (copy-sequence messages) 'mh-greaterp)) - (range-high nil) - (prev -1) - (ranges nil)) - (while prev - (if range-high - (if (or (not (numberp prev)) - (not (equal (car msgs) (1- prev)))) - (progn ;non-sequential, flush old range - (if (eq prev range-high) - (setq ranges (cons range-high ranges)) - (setq ranges (cons (format "%s-%s" prev range-high) ranges))) - (setq range-high nil)))) - (or range-high - (setq range-high (car msgs))) ;start new or first range - (setq prev (car msgs)) - (setq msgs (cdr msgs))) - ranges)) - -(defun mh-greaterp (msg1 msg2) - "Return the greater of two message indicators MSG1 and MSG2. -Strings are \"smaller\" than numbers. -Legal values are things like \"cur\", \"last\", 1, and 1820." - (if (numberp msg1) - (if (numberp msg2) - (> msg1 msg2) - t) - (if (numberp msg2) - nil - (string-lessp msg2 msg1)))) - -(defun mh-lessp (msg1 msg2) - "Return the lesser of two message indicators MSG1 and MSG2. -Strings are \"smaller\" than numbers. -Legal values are things like \"cur\", \"last\", 1, and 1820." - (not (mh-greaterp msg1 msg2))) - - - -;;; Basic sequence handling - -(defun mh-delete-seq-locally (seq) - "Remove MH-E's record of SEQ." - (let ((entry (mh-find-seq seq))) - (setq mh-seq-list (delq entry mh-seq-list)))) - -(defun mh-read-folder-sequences (folder save-refiles) - "Read and return the predefined sequences for a FOLDER. -If SAVE-REFILES is non-nil, then keep the sequences -that note messages to be refiled." - (let ((seqs ())) - (cond (save-refiles - (mh-mapc (function (lambda (seq) ; Save the refiling sequences - (if (mh-folder-name-p (mh-seq-name seq)) - (setq seqs (cons seq seqs))))) - mh-seq-list))) - (save-excursion - (if (eq 0 (mh-exec-cmd-quiet nil "mark" folder "-list")) - (progn - ;; look for name in line of form "cur: 4" or "myseq (private): 23" - (while (re-search-forward "^[^: ]+" nil t) - (setq seqs (cons (mh-make-seq (intern (buffer-substring - (match-beginning 0) - (match-end 0))) - (mh-read-msg-list)) - seqs))) - (delete-region (point-min) (point))))) ; avoid race with - ; mh-process-daemon - seqs)) - -(defun mh-read-msg-list () - "Return a list of message numbers from point to the end of the line. -Expands ranges into set of individual numbers." - (let ((msgs ()) - (end-of-line (save-excursion (end-of-line) (point))) - num) - (while (re-search-forward "[0-9]+" end-of-line t) - (setq num (string-to-int (buffer-substring (match-beginning 0) - (match-end 0)))) - (cond ((looking-at "-") ; Message range - (forward-char 1) - (re-search-forward "[0-9]+" end-of-line t) - (let ((num2 (string-to-int (buffer-substring (match-beginning 0) - (match-end 0))))) - (if (< num2 num) - (error "Bad message range: %d-%d" num num2)) - (while (<= num num2) - (setq msgs (cons num msgs)) - (setq num (1+ num))))) - ((not (zerop num)) ;"pick" outputs "0" to mean no match - (setq msgs (cons num msgs))))) - msgs)) - -(defun mh-notate-user-sequences () - "Mark the scan listing of all messages in user-defined sequences." - (let ((seqs mh-seq-list) - name) - (while seqs - (setq name (mh-seq-name (car seqs))) - (if (not (mh-internal-seq name)) - (mh-notate-seq name mh-note-seq (1+ mh-cmd-note))) - (setq seqs (cdr seqs))))) - -(defun mh-internal-seq (name) - "Return non-nil if NAME is the name of an internal MH-E sequence." - (or (memq name '(answered cur deleted forwarded printed)) - (eq name mh-unseen-seq) - (eq name mh-previous-seq) - (mh-folder-name-p name))) - -(defun mh-delete-msg-from-seq (message sequence &optional internal-flag) - "Delete MESSAGE from SEQUENCE. -MESSAGE defaults to displayed message. From Lisp, optional third arg -INTERNAL-FLAG non-nil means do not inform MH of the change." - (interactive (list (mh-get-msg-num t) - (mh-read-seq-default "Delete from" t) - nil)) - (let ((entry (mh-find-seq sequence))) - (cond (entry - (mh-notate-if-in-one-seq message ? (1+ mh-cmd-note) sequence) - (if (not internal-flag) - (mh-undefine-sequence sequence (list message))) - (setcdr entry (delq message (mh-seq-msgs entry))))))) - -(defun mh-undefine-sequence (seq msgs) - "Remove from the SEQ the list of MSGS." - (mh-exec-cmd "mark" mh-current-folder "-delete" - "-sequence" (symbol-name seq) - (mh-coalesce-msg-list msgs))) - -(defun mh-define-sequence (seq msgs) - "Define the SEQ to contain the list of MSGS. -Do not mark pseudo-sequences or empty sequences. -Signals an error if SEQ is an illegal name." - (if (and msgs - (not (mh-folder-name-p seq))) - (save-excursion - (mh-exec-cmd-error nil "mark" mh-current-folder "-add" "-zero" - "-sequence" (symbol-name seq) - (mh-coalesce-msg-list msgs))))) - -(defun mh-map-over-seqs (function seq-list) - "Apply FUNCTION to each sequence in SEQ-LIST. -The sequence name and the list of messages are passed as arguments." - (while seq-list - (funcall function - (mh-seq-name (car seq-list)) - (mh-seq-msgs (car seq-list))) - (setq seq-list (cdr seq-list)))) - -(defun mh-notate-if-in-one-seq (msg character offset seq) - "Notate MSG. -The CHARACTER is placed at the given OFFSET from the beginning of the listing. -The notation is performed if the MSG is only in SEQ." - (let ((in-seqs (mh-seq-containing-msg msg nil))) - (if (and (eq seq (car in-seqs)) (null (cdr in-seqs))) - (mh-notate msg character offset)))) - -(defun mh-seq-containing-msg (msg &optional include-internal-flag) - "Return a list of the sequences containing MSG. -If INCLUDE-INTERNAL-FLAG non-nil, include MH-E internal sequences in list." - (let ((l mh-seq-list) - (seqs ())) - (while l - (and (memq msg (mh-seq-msgs (car l))) - (or include-internal-flag - (not (mh-internal-seq (mh-seq-name (car l))))) - (setq seqs (cons (mh-seq-name (car l)) seqs))) - (setq l (cdr l))) - seqs)) - - - -;;; User prompting commands. - -(defun mh-read-msg-range (folder &optional always-prompt-flag) - "Prompt for message range from FOLDER. -If optional second argument ALWAYS-PROMPT-FLAG is non-nil then always ask for -range." - (multiple-value-bind (total unseen) (mh-folder-size folder) - (cond - ((and (not always-prompt-flag) (numberp unseen) (> unseen 0)) - (list (symbol-name mh-unseen-seq))) - ((or (null mh-large-folder) (not (numberp total))) - (list "all")) - ((and (numberp total) (or always-prompt-flag (> total mh-large-folder))) - (let* ((prompt - (format "Range or number of messages to read (default: %s): " - total)) - (in (read-string prompt nil nil (number-to-string total)))) - (cond ((string-match "^[ \f\t\n\r\v]*[0-9]+[ \f\t\n\r\v]*$" in) - (list (format "last:%s" (car (read-from-string in))))) - ((equal in "") (list "all")) - (t (split-string in))))) - (t (list "all"))))) - - - -;;; Build the folder-mode keymap: - -(suppress-keymap mh-folder-mode-map) - -;; Use defalias to make sure the documented primary key bindings -;; appear in menu lists. -(defalias 'mh-alt-show 'mh-show) -(defalias 'mh-alt-refile-msg 'mh-refile-msg) -(defalias 'mh-alt-send 'mh-send) -(defalias 'mh-alt-visit-folder 'mh-visit-folder) - -;; Save the `b' binding for a future `back'. Maybe? -(gnus-define-keys mh-folder-mode-map - " " mh-page-msg - "!" mh-refile-or-write-again - "," mh-header-display - "." mh-alt-show - ">" mh-write-msg-to-file - "?" mh-help - "E" mh-extract-rejected-mail - "M" mh-modify - "\177" mh-previous-page - "\C-d" mh-delete-msg-no-motion - "\t" mh-index-next-folder - [backtab] mh-index-previous-folder - "\M-\t" mh-index-previous-folder - "\e<" mh-first-msg - "\e>" mh-last-msg - "\ed" mh-redistribute - "\r" mh-show - "^" mh-alt-refile-msg - "c" mh-copy-msg - "d" mh-delete-msg - "e" mh-edit-again - "f" mh-forward - "g" mh-goto-msg - "i" mh-inc-folder - "k" mh-delete-subject-or-thread - "l" mh-print-msg - "m" mh-alt-send - "n" mh-next-undeleted-msg - "\M-n" mh-next-unread-msg - "o" mh-refile-msg - "p" mh-previous-undeleted-msg - "\M-p" mh-previous-unread-msg - "q" mh-quit - "r" mh-reply - "s" mh-send - "t" mh-toggle-showing - "u" mh-undo - "v" mh-index-visit-folder - "x" mh-execute-commands - "|" mh-pipe-msg) - -(gnus-define-keys (mh-folder-map "F" mh-folder-mode-map) - "?" mh-prefix-help - "S" mh-sort-folder - "f" mh-alt-visit-folder - "i" mh-index-search - "k" mh-kill-folder - "l" mh-list-folders - "o" mh-alt-visit-folder - "p" mh-pack-folder - "r" mh-rescan-folder - "s" mh-search-folder - "u" mh-undo-folder - "v" mh-visit-folder) - -(gnus-define-keys (mh-sequence-map "S" mh-folder-mode-map) - "?" mh-prefix-help - "d" mh-delete-msg-from-seq - "k" mh-delete-seq - "l" mh-list-sequences - "n" mh-narrow-to-seq - "p" mh-put-msg-in-seq - "s" mh-msg-is-in-seq - "w" mh-widen) - -(gnus-define-keys (mh-thread-map "T" mh-folder-mode-map) - "?" mh-prefix-help - "u" mh-thread-ancestor - "p" mh-thread-previous-sibling - "n" mh-thread-next-sibling - "t" mh-toggle-threads - "d" mh-thread-delete - "o" mh-thread-refile) - -(gnus-define-keys (mh-limit-map "/" mh-folder-mode-map) - "?" mh-prefix-help - "s" mh-narrow-to-subject - "w" mh-widen) - -(gnus-define-keys (mh-extract-map "X" mh-folder-mode-map) - "?" mh-prefix-help - "s" mh-store-msg ;shar - "u" mh-store-msg) ;uuencode - -(gnus-define-keys (mh-digest-map "D" mh-folder-mode-map) - " " mh-page-digest - "?" mh-prefix-help - "\177" mh-page-digest-backwards - "b" mh-burst-digest) - -(gnus-define-keys (mh-mime-map "K" mh-folder-mode-map) - "?" mh-prefix-help - "a" mh-mime-save-parts - "i" mh-folder-inline-mime-part - "o" mh-folder-save-mime-part - "v" mh-folder-toggle-mime-part - "\t" mh-next-button - [backtab] mh-prev-button - "\M-\t" mh-prev-button) - -(cond - (mh-xemacs-flag - (define-key mh-folder-mode-map [button2] 'mh-show-mouse)) - (t - (define-key mh-folder-mode-map [mouse-2] 'mh-show-mouse))) - -;; "C-c /" prefix is used in mh-folder-mode by pgp.el and mailcrypt - - - -;;; Help Messages - -;;; If you add a new prefix, add appropriate text to the nil key. -;;; -;;; In general, messages are grouped logically. Taking the main commands for -;;; example, the first line is "ways to view messages," the second line is -;;; "things you can do with messages", and the third is "composing" messages. -;;; -;;; When adding a new prefix, ensure that the help message contains "what" the -;;; prefix is for. For example, if the word "folder" were not present in the -;;; `F' entry, it would not be clear what these commands operated upon. -(defvar mh-help-messages - '((nil "[i]nc, [.]show, [,]show all, [n]ext, [p]revious,\n" - "[d]elete, [o]refile, e[x]ecute,\n" - "[s]end, [r]eply.\n" - "Prefix characters:\n [F]older, [S]equence, MIME [K]eys, " - "[T]hread, / Limit, e[X]tract, [D]igest.") - - (?F "[l]ist, [v]isit folder;\n" - "[t]hread; [s]earch; [i]ndexed search;\n" - "[p]ack; [S]ort; [r]escan; [k]ill") - (?S "[p]ut message in sequence, [n]arrow, [w]iden,\n" - "[s]equences, [l]ist,\n" - "[d]elete message from sequence, [k]ill sequence") - (?T "[t]oggle, [d]elete, [o]refile thread") - (?/ "Limit to [s]ubject; [w]iden") - (?X "un[s]har, [u]udecode message") - (?D "[b]urst digest") - (?K "[v]iew, [i]nline, [o]utput/save MIME part; save [a]ll parts; \n" - "[TAB] next; [SHIFT-TAB] previous")) - "Key binding cheat sheet. - -This is an associative array which is used to show the most common commands. -The key is a prefix char. The value is one or more strings which are -concatenated together and displayed in the minibuffer if ? is pressed after -the prefix character. The special key nil is used to display the -non-prefixed commands. - -The substitutions described in `substitute-command-keys' are performed as -well.") - - - -(dolist (mess '("^Cursor not pointing to message$" - "^There is no other window$")) - (add-to-list 'debug-ignored-errors mess)) - -(provide 'mh-e) - -;;; Local Variables: -;;; indent-tabs-mode: nil -;;; sentence-end-double-space: nil -;;; End: - -;;; mh-e.el ends here
--- a/lisp/mail/mh-funcs.el Sun Jan 26 01:33:33 2003 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,436 +0,0 @@ -;;; mh-funcs.el --- MH-E functions not everyone will use right away - -;; Copyright (C) 1993, 1995, 2001, 2002 Free Software Foundation, Inc. - -;; Author: Bill Wohler <wohler@newt.com> -;; Maintainer: Bill Wohler <wohler@newt.com> -;; Keywords: mail -;; See: mh-e.el - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Internal support for MH-E package. -;; Putting these functions in a separate file lets MH-E start up faster, -;; since less Lisp code needs to be loaded all at once. - -;;; Change Log: - -;; $Id: mh-funcs.el,v 1.36 2002/12/23 05:52:07 satyaki Exp $ - -;;; Code: - -(require 'mh-e) - -;;; Customization - -(defvar mh-sortm-args nil - "Extra arguments to have \\[mh-sort-folder] pass to the \"sortm\" command. -The arguments are passed to sortm if \\[mh-sort-folder] is given a -prefix argument. Normally default arguments to sortm are specified in the -MH profile. -For example, '(\"-nolimit\" \"-textfield\" \"subject\") is a useful setting.") - -(defvar mh-note-copied "C" - "String whose first character is used to notate copied messages.") - -(defvar mh-note-printed "P" - "String whose first character is used to notate printed messages.") - -;;; Functions - -;;;###mh-autoload -(defun mh-burst-digest () - "Burst apart the current message, which should be a digest. -The message is replaced by its table of contents and the messages from the -digest are inserted into the folder after that message." - (interactive) - (let ((digest (mh-get-msg-num t))) - (mh-process-or-undo-commands mh-current-folder) - (mh-set-folder-modified-p t) ; lock folder while bursting - (message "Bursting digest...") - (mh-exec-cmd "burst" mh-current-folder digest "-inplace") - (with-mh-folder-updating (t) - (beginning-of-line) - (delete-region (point) (point-max))) - (mh-regenerate-headers (format "%d-last" digest) t) - (mh-goto-cur-msg) - (message "Bursting digest...done"))) - -;;;###mh-autoload -(defun mh-copy-msg (msg-or-seq folder) - "Copy the specified MSG-OR-SEQ to another FOLDER without deleting them. -Default is the displayed message. If optional prefix argument is provided, -then prompt for the message sequence." - (interactive (list (cond - ((mh-mark-active-p t) - (mh-region-to-msg-list (region-beginning) (region-end))) - (current-prefix-arg - (mh-read-seq-default "Copy" t)) - (t - (mh-get-msg-num t))) - (mh-prompt-for-folder "Copy to" "" t))) - (mh-exec-cmd "refile" - (cond ((numberp msg-or-seq) msg-or-seq) - ((listp msg-or-seq) msg-or-seq) - (t (mh-coalesce-msg-list (mh-seq-to-msgs msg-or-seq)))) - "-link" "-src" mh-current-folder folder) - (if (numberp msg-or-seq) - (mh-notate msg-or-seq mh-note-copied mh-cmd-note) - (mh-notate-seq msg-or-seq mh-note-copied mh-cmd-note))) - -;;;###mh-autoload -(defun mh-kill-folder () - "Remove the current folder and all included messages. -Removes all of the messages (files) within the specified current folder, -and then removes the folder (directory) itself. -The value of `mh-folder-list-change-hook' is a list of functions to be called, -with no arguments, after the folders has been removed." - (interactive) - (if (yes-or-no-p (format "Remove folder %s (and all included messages)?" - mh-current-folder)) - (let ((folder mh-current-folder)) - (if (null mh-folder-list) - (mh-set-folder-list)) - (mh-set-folder-modified-p t) ; lock folder to kill it - (mh-exec-cmd-daemon "rmf" folder) - (setq mh-folder-list - (delq (assoc folder mh-folder-list) mh-folder-list)) - (when (boundp 'mh-speed-folder-map) - (mh-speed-invalidate-map folder)) - (run-hooks 'mh-folder-list-change-hook) - (message "Folder %s removed" folder) - (mh-set-folder-modified-p nil) ; so kill-buffer doesn't complain - (if (get-buffer mh-show-buffer) - (kill-buffer mh-show-buffer)) - (if (get-buffer folder) - (kill-buffer folder))) - (message "Folder not removed"))) - -;; Avoid compiler warning... -(defvar view-exit-action) - -;;;###mh-autoload -(defun mh-list-folders () - "List mail folders." - (interactive) - (let ((temp-buffer mh-temp-folders-buffer)) - (with-output-to-temp-buffer temp-buffer - (save-excursion - (set-buffer temp-buffer) - (erase-buffer) - (message "Listing folders...") - (mh-exec-cmd-output "folders" t (if mh-recursive-folders-flag - "-recurse" - "-norecurse")) - (goto-char (point-min)) - (view-mode 1) - (setq view-exit-action 'kill-buffer) - (message "Listing folders...done"))))) - -;;;###mh-autoload -(defun mh-pack-folder (range) - "Renumber the messages of a folder to be 1..n. -First, offer to execute any outstanding commands for the current folder. If -optional prefix argument provided, prompt for the RANGE of messages to display -after packing. Otherwise, show the entire folder." - (interactive (list (if current-prefix-arg - (mh-read-msg-range mh-current-folder t) - '("all")))) - (let ((threaded-flag (memq 'unthread mh-view-ops))) - (mh-pack-folder-1 range) - (mh-goto-cur-msg) - (when mh-index-data - (mh-index-update-maps mh-current-folder)) - (cond (threaded-flag (mh-toggle-threads)) - (mh-index-data (mh-index-insert-folder-headers)))) - (message "Packing folder...done")) - -(defun mh-pack-folder-1 (range) - "Close and pack the current folder. -Display the given RANGE of messages after packing. If RANGE is nil, show the -entire folder." - (mh-process-or-undo-commands mh-current-folder) - (message "Packing folder...") - (mh-set-folder-modified-p t) ; lock folder while packing - (save-excursion - (mh-exec-cmd-quiet t "folder" mh-current-folder "-pack" - "-norecurse" "-fast")) - (mh-reset-threads-and-narrowing) - (mh-regenerate-headers range)) - -;;;###mh-autoload -(defun mh-pipe-msg (command include-headers) - "Pipe the current message through the given shell COMMAND. -If INCLUDE-HEADERS (prefix argument) is provided, send the entire message. -Otherwise just send the message's body without the headers." - (interactive - (list (read-string "Shell command on message: ") current-prefix-arg)) - (let ((msg-file-to-pipe (mh-msg-filename (mh-get-msg-num t))) - (message-directory default-directory)) - (save-excursion - (set-buffer (get-buffer-create mh-temp-buffer)) - (erase-buffer) - (insert-file-contents msg-file-to-pipe) - (goto-char (point-min)) - (if (not include-headers) (search-forward "\n\n")) - (let ((default-directory message-directory)) - (shell-command-on-region (point) (point-max) command nil))))) - -;;;###mh-autoload -(defun mh-page-digest () - "Advance displayed message to next digested message." - (interactive) - (mh-in-show-buffer (mh-show-buffer) - ;; Go to top of screen (in case user moved point). - (move-to-window-line 0) - (let ((case-fold-search nil)) - ;; Search for blank line and then for From: - (or (and (search-forward "\n\n" nil t) - (re-search-forward "^From:" nil t)) - (error "No more messages in digest"))) - ;; Go back to previous blank line, then forward to the first non-blank. - (search-backward "\n\n" nil t) - (forward-line 2) - (mh-recenter 0))) - -;;;###mh-autoload -(defun mh-page-digest-backwards () - "Back up displayed message to previous digested message." - (interactive) - (mh-in-show-buffer (mh-show-buffer) - ;; Go to top of screen (in case user moved point). - (move-to-window-line 0) - (let ((case-fold-search nil)) - (beginning-of-line) - (or (and (search-backward "\n\n" nil t) - (re-search-backward "^From:" nil t)) - (error "No previous message in digest"))) - ;; Go back to previous blank line, then forward to the first non-blank. - (if (search-backward "\n\n" nil t) - (forward-line 2)) - (mh-recenter 0))) - -;;;###mh-autoload -(defun mh-print-msg (msg-or-seq) - "Print MSG-OR-SEQ (default: displayed message) on printer. -If optional prefix argument provided, then prompt for the message sequence. -The variable `mh-lpr-command-format' is used to generate the print command. -The messages are formatted by mhl. See the variable `mhl-formfile'." - (interactive (list (if current-prefix-arg - (reverse (mh-seq-to-msgs - (mh-read-seq-default "Print" t))) - (mh-get-msg-num t)))) - (if (numberp msg-or-seq) - (message "Printing message...") - (message "Printing sequence...")) - (let ((print-command - (if (numberp msg-or-seq) - (format "%s -nobell -clear %s %s | %s" - (expand-file-name "mhl" mh-lib-progs) - (mh-msg-filename msg-or-seq) - (if (stringp mhl-formfile) - (format "-form %s" mhl-formfile) - "") - (format mh-lpr-command-format - (if (numberp msg-or-seq) - (format "%s/%d" mh-current-folder - msg-or-seq) - (format "Sequence from %s" mh-current-folder)))) - (format "(scan -clear %s ; %s -nobell -clear %s %s) | %s" - (mapconcat (function (lambda (msg) msg)) msg-or-seq " ") - (expand-file-name "mhl" mh-lib-progs) - (if (stringp mhl-formfile) - (format "-form %s" mhl-formfile) - "") - (mh-msg-filenames msg-or-seq) - (format mh-lpr-command-format - (if (numberp msg-or-seq) - (format "%s/%d" mh-current-folder - msg-or-seq) - (format "Sequence from %s" - mh-current-folder))))))) - (if mh-print-background-flag - (mh-exec-cmd-daemon shell-file-name "-c" print-command) - (call-process shell-file-name nil nil nil "-c" print-command)) - (if (numberp msg-or-seq) - (mh-notate msg-or-seq mh-note-printed mh-cmd-note) - (mh-notate-seq msg-or-seq mh-note-printed mh-cmd-note)) - (mh-add-msgs-to-seq msg-or-seq 'printed t) - (if (numberp msg-or-seq) - (message "Printing message...done") - (message "Printing sequence...done")))) - -(defun mh-msg-filenames (msgs &optional folder) - "Return a list of file names for MSGS in FOLDER (default current folder)." - (mapconcat (function (lambda (msg) (mh-msg-filename msg folder))) msgs " ")) - -;;;###mh-autoload -(defun mh-sort-folder (&optional extra-args) - "Sort the messages in the current folder by date. -Calls the MH program sortm to do the work. -The arguments in the list `mh-sortm-args' are passed to sortm if the optional -argument EXTRA-ARGS is given." - (interactive "P") - (mh-process-or-undo-commands mh-current-folder) - (setq mh-next-direction 'forward) - (mh-set-folder-modified-p t) ; lock folder while sorting - (message "Sorting folder...") - (let ((threaded-flag (memq 'unthread mh-view-ops))) - (mh-exec-cmd "sortm" mh-current-folder (if extra-args mh-sortm-args)) - (when mh-index-data - (mh-index-update-maps mh-current-folder)) - (message "Sorting folder...done") - (mh-reset-threads-and-narrowing) - (mh-scan-folder mh-current-folder "all") - (cond (threaded-flag (mh-toggle-threads)) - (mh-index-data (mh-index-insert-folder-headers))))) - -;;;###mh-autoload -(defun mh-undo-folder (&rest ignore) - "Undo all pending deletes and refiles in current folder. -Argument IGNORE is deprecated." - (interactive) - (cond ((or mh-do-not-confirm-flag - (yes-or-no-p "Undo all commands in folder? ")) - (setq mh-delete-list nil - mh-refile-list nil - mh-seq-list nil - mh-next-direction 'forward) - (with-mh-folder-updating (nil) - (mh-unmark-all-headers t))) - (t - (message "Commands not undone.") - (sit-for 2)))) - -;;;###mh-autoload -(defun mh-store-msg (directory) - "Store the file(s) contained in the current message into DIRECTORY. -The message can contain a shar file or uuencoded file. -Default directory is the last directory used, or initially the value of -`mh-store-default-directory' or the current directory." - (interactive (list (let ((udir (or mh-store-default-directory - default-directory))) - (read-file-name "Store message in directory: " - udir udir nil)))) - (let ((msg-file-to-store (mh-msg-filename (mh-get-msg-num t)))) - (save-excursion - (set-buffer (get-buffer-create mh-temp-buffer)) - (erase-buffer) - (insert-file-contents msg-file-to-store) - (mh-store-buffer directory)))) - -;;;###mh-autoload -(defun mh-store-buffer (directory) - "Store the file(s) contained in the current buffer into DIRECTORY. -The buffer can contain a shar file or uuencoded file. -Default directory is the last directory used, or initially the value of -`mh-store-default-directory' or the current directory." - (interactive (list (let ((udir (or mh-store-default-directory - default-directory))) - (read-file-name "Store buffer in directory: " - udir udir nil)))) - (let ((store-directory (expand-file-name directory)) - (sh-start (save-excursion - (goto-char (point-min)) - (if (re-search-forward - "^#![ \t]*/bin/sh\\|^#\\|^: " nil t) - (progn - ;; The "cut here" pattern was removed from above - ;; because it seemed to hurt more than help. - ;; But keep this to make it easier to put it back. - (if (looking-at "^[^a-z0-9\"]*cut here\\b") - (forward-line 1)) - (beginning-of-line) - (if (looking-at "^[#:]....+\n\\( ?\n\\)?end$") - nil ;most likely end of a uuencode - (point)))))) - (log-buffer (get-buffer-create "*Store Output*")) - (command "sh") - (uudecode-filename "(unknown filename)")) - (if (not sh-start) - (save-excursion - (goto-char (point-min)) - (if (re-search-forward "^begin [0-7]+ " nil t) - (setq uudecode-filename - (buffer-substring (point) - (progn (end-of-line) (point))))))) - (save-excursion - (set-buffer log-buffer) - (erase-buffer) - (if (not (file-directory-p store-directory)) - (progn - (insert "mkdir " directory "\n") - (call-process "mkdir" nil log-buffer t store-directory))) - (insert "cd " directory "\n") - (setq mh-store-default-directory directory) - (if (not sh-start) - (progn - (setq command "uudecode") - (insert uudecode-filename " being uudecoded...\n")))) - (set-window-start (display-buffer log-buffer) 0) ;watch progress - (let (value) - (let ((default-directory (file-name-as-directory store-directory))) - (setq value (call-process-region sh-start (point-max) command - nil log-buffer t))) - (set-buffer log-buffer) - (mh-handle-process-error command value)) - (insert "\n(mh-store finished)\n"))) - - - -;;; Help Functions - -(defun mh-ephem-message (string) - "Display STRING in the minibuffer momentarily." - (message "%s" string) - (sit-for 5) - (message "")) - -;;;###mh-autoload -(defun mh-help () - "Display cheat sheet for the MH-Folder commands in minibuffer." - (interactive) - (mh-ephem-message - (substitute-command-keys - (mapconcat 'identity (cdr (assoc nil mh-help-messages)) "")))) - -;;;###mh-autoload -(defun mh-prefix-help () - "Display cheat sheet for the commands of the current prefix in minibuffer." - (interactive) - ;; We got here because the user pressed a `?', but he pressed a prefix key - ;; before that. Since the the key vector starts at index 0, the index of the - ;; last keystroke is length-1 and thus the second to last keystroke is at - ;; length-2. We use that information to obtain a suitable prefix character - ;; from the recent keys. - (let* ((keys (recent-keys)) - (prefix-char (elt keys (- (length keys) 2)))) - (mh-ephem-message - (substitute-command-keys - (mapconcat 'identity (cdr (assoc prefix-char mh-help-messages)) ""))))) - -(provide 'mh-funcs) - -;;; Local Variables: -;;; indent-tabs-mode: nil -;;; sentence-end-double-space: nil -;;; End: - -;;; mh-funcs.el ends here
--- a/lisp/mail/mh-identity.el Sun Jan 26 01:33:33 2003 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,219 +0,0 @@ -;;; mh-identity.el --- Multiple Identify support for MH-E. - -;; Copyright (C) 2002 Free Software Foundation, Inc. - -;; Author: Peter S. Galbraith <psg@debian.org> -;; Maintainer: Bill Wohler <wohler@newt.com> -;; Keywords: mail -;; See: mh-e.el - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Multiple identity support for MH-E. -;; -;; Used to easily set different fields such as From and Organization, as -;; well as different signature files. -;; -;; Customize the variable `mh-identity-list' and an Identity menu will -;; appear in mh-letter-mode. The command 'mh-insert-identity can be used -;; from the command line. - -;;; Change Log: - -;; $Id: mh-identity.el,v 1.17 2002/12/03 15:54:27 psg Exp $ - -;;; Code: - - -(require 'cl) - -(eval-when (compile load eval) - (defvar mh-comp-loaded nil) - (unless mh-comp-loaded - (setq mh-comp-loaded t) - (require 'mh-comp))) ;Since we do this on sending - -(autoload 'mml-insert-tag "mml") - -;;;###mh-autoload -(defun mh-identity-make-menu () - "Build (or rebuild) the Identity menu (e.g. after the list is modified)." - (when (and mh-identity-list (boundp 'mh-letter-mode-map)) - (easy-menu-define mh-identity-menu mh-letter-mode-map - "mh-e identity menu" - (append - '("Identity") - ;; Dynamically render :type corresponding to `mh-identity-list' - ;; e.g.: - ;; ["home" (mh-insert-identity "home") - ;; :style radio :active (not (equal mh-identity-local "home")) - ;; :selected (equal mh-identity-local "home")] - (mapcar (function - (lambda (arg) - `[,arg (mh-insert-identity ,arg) :style radio - :active (not (equal mh-identity-local ,arg)) - :selected (equal mh-identity-local ,arg)])) - (mapcar 'car mh-identity-list)) - '("--" - ["none" (mh-insert-identity "none") mh-identity-local] - ["Set Default for Session" - (setq mh-identity-default mh-identity-local) t] - ["Save as Default" - (customize-save-variable - 'mh-identity-default mh-identity-local) t] - ))))) - -;;;###mh-autoload -(defun mh-identity-list-set (symbol value) - "Update the `mh-identity-list' variable, and rebuild the menu. -Sets the default for SYMBOL (e.g. `mh-identity-list') to VALUE (as set in -customization). This is called after 'customize is used to alter -`mh-identity-list'." - (set-default symbol value) - (mh-identity-make-menu)) - -(defvar mh-identity-local nil - "Buffer-local variable holding the identity currently in use.") -(make-variable-buffer-local 'mh-identity-local) - -(defun mh-header-field-delete (field value-only) - "Delete FIELD in the mail header, or only its value if VALUE-ONLY is t. -Return t if anything is deleted." - (when (mh-goto-header-field field) - (if (not value-only) - (beginning-of-line) - (forward-char)) - (delete-region (point) - (progn (mh-header-field-end) - (if (not value-only) (forward-char 1)) - (point))) - t)) - -(defvar mh-identity-signature-start nil - "Marker for the beginning of a signature inserted by `mh-insert-identity'.") -(defvar mh-identity-signature-end nil - "Marker for the end of a signature inserted by `mh-insert-identity'.") - -;;;###mh-autoload -(defun mh-insert-identity (identity) - "Insert proper fields for given IDENTITY. -Edit the `mh-identity-list' variable to define identity." - (interactive - (list (completing-read - "Identity: " - (if mh-identity-local - (cons '("none") - (mapcar 'list (mapcar 'car mh-identity-list))) - (mapcar 'list (mapcar 'car mh-identity-list))) - nil t))) - (save-excursion - ;;First remove old settings, if any. - (when mh-identity-local - (let ((pers-list (cadr (assoc mh-identity-local mh-identity-list)))) - (while pers-list - (let ((field (concat (caar pers-list) ":"))) - (cond - ((string-equal "signature:" field) - (when (and (boundp 'mh-identity-signature-start) - (markerp mh-identity-signature-start)) - (goto-char mh-identity-signature-start) - (forward-char -1) - (delete-region (point) mh-identity-signature-end))) - ((mh-header-field-delete field nil)))) - (setq pers-list (cdr pers-list))))) - ;; Then insert the replacement - (when (not (equal "none" identity)) - (let ((pers-list (cadr (assoc identity mh-identity-list)))) - (while pers-list - (let ((field (concat (caar pers-list) ":")) - (value (cdar pers-list))) - (cond - ;; No value, remove field - ((or (not value) - (string= value "")) - (mh-header-field-delete field nil)) - ;; Existing field, replace - ((mh-header-field-delete field t) - (insert value)) - ;; Handle "signature" special case. Insert file or call function. - ((and (string-equal "signature:" field) - (or (and (stringp value) - (file-readable-p value)) - (fboundp value))) - (goto-char (point-max)) - (if (not (looking-at "^$")) - (insert "\n")) - (insert "\n") - (save-restriction - (narrow-to-region (point) (point)) - (set (make-local-variable 'mh-identity-signature-start) - (make-marker)) - (set-marker mh-identity-signature-start (point)) - (cond - ;; If MIME composition done, insert signature at the end as - ;; an inline MIME part. - ((and (boundp 'mh-mhn-compose-insert-flag) - mh-mhn-compose-insert-flag) - (insert "#\n" "Content-Description: Signature\n")) - ((and (boundp 'mh-mml-compose-insert-flag) - mh-mml-compose-insert-flag) - (mml-insert-tag 'part 'type "text/plain" - 'disposition "inline" - 'description "Signature"))) - (if (stringp value) - (insert-file-contents value) - (funcall value)) - (goto-char (point-min)) - (when (not (re-search-forward "^--" nil t)) - (if (and (boundp 'mh-mhn-compose-insert-flag) - mh-mhn-compose-insert-flag) - (forward-line 2)) - (if (and (boundp 'mh-mml-compose-insert-flag) - mh-mml-compose-insert-flag) - (forward-line 1)) - (insert "-- \n")) - (set (make-local-variable 'mh-identity-signature-end) - (make-marker)) - (set-marker mh-identity-signature-end (point-max)))) - ;; Handle "From" field differently, adding it at the beginning. - ((string-equal "From:" field) - (goto-char (point-min)) - (insert "From: " value "\n")) - ;; Skip empty signature (Can't remove what we don't know) - ((string-equal "signature:" field)) - ;; Other field, add at end - (t ;Otherwise, add the end. - (goto-char (point-min)) - (mh-goto-header-end 0) - (mh-insert-fields field value)))) - (setq pers-list (cdr pers-list)))))) - ;; Remember what is in use in this buffer - (if (equal "none" identity) - (setq mh-identity-local nil) - (setq mh-identity-local identity))) - -(provide 'mh-identity) - -;;; Local Variables: -;;; indent-tabs-mode: nil -;;; sentence-end-double-space: nil -;;; End: - -;;; mh-identity.el ends here
--- a/lisp/mail/mh-index.el Sun Jan 26 01:33:33 2003 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,948 +0,0 @@ -;;; mh-index -- MH-E interface to indexing programs - -;; Copyright (C) 2002 Free Software Foundation, Inc. - -;; Author: Satyaki Das <satyaki@theforce.stanford.edu> -;; Maintainer: Bill Wohler <wohler@newt.com> -;; Keywords: mail -;; See: mh-e.el - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;;; (1) The following search engines are supported: -;;; swish++ -;;; swish-e -;;; namazu -;;; glimpse -;;; grep -;;; -;;; (2) To use this package, you first have to build an index. Please read -;;; the documentation for `mh-index-search' to get started. That -;;; documentation will direct you to the specific instructions for your -;;; particular indexer. - -;;; Change Log: - -;; $Id: mh-index.el,v 1.73 2003/01/07 21:15:49 satyaki Exp $ - -;;; Code: - -(require 'cl) -(require 'mh-e) -(require 'mh-mime) - -(autoload 'gnus-local-map-property "gnus-util") -(autoload 'gnus-eval-format "gnus-spec") -(autoload 'widget-convert-button "wid-edit") -(autoload 'executable-find "executable") - -;; Support different indexing programs -(defvar mh-indexer-choices - '((swish++ - mh-swish++-binary mh-swish++-execute-search mh-swish++-next-result) - (swish - mh-swish-binary mh-swish-execute-search mh-swish-next-result) - (namazu - mh-namazu-binary mh-namazu-execute-search mh-namazu-next-result) - (glimpse - mh-glimpse-binary mh-glimpse-execute-search mh-glimpse-next-result) - (grep - mh-grep-binary mh-grep-execute-search mh-grep-next-result)) - "List of possible indexer choices.") -(defvar mh-indexer nil - "Chosen index program.") -(defvar mh-index-execute-search-function nil - "Function which executes the search program.") -(defvar mh-index-next-result-function nil - "Function to parse the next line of output.") - -;; FIXME: This should be a defcustom... -(defvar mh-index-folder "+mhe-index" - "Folder that contains the folders resulting from the index searches.") - -;; Temporary buffers for search results -(defvar mh-index-temp-buffer " *mh-index-temp*") -(defvar mh-checksum-buffer " *mh-checksum-buffer*") - - - -;;; A few different checksum programs are supported. The supported programs -;;; are: -;;; 1. md5sum -;;; 2. md5 -;;; 3. openssl -;;; -;;; To add support for your favorite checksum program add a clause to the cond -;;; statement in mh-checksum-choose. This should set the variable -;;; mh-checksum-cmd to the command line needed to run the checsum program and -;;; should set mh-checksum-parser to a function which returns a cons cell -;;; containing the message number and checksum string. - -(defvar mh-checksum-cmd) -(defvar mh-checksum-parser) - -(defun mh-checksum-choose () - "Check if a program to create a checksum is present." - (unless (boundp 'mh-checksum-cmd) - (let ((exec-path (append '("/sbin" "/usr/sbin") exec-path))) - (cond ((executable-find "md5sum") - (setq mh-checksum-cmd (list (executable-find "md5sum"))) - (setq mh-checksum-parser #'mh-md5sum-parser)) - ((executable-find "openssl") - (setq mh-checksum-cmd (list (executable-find "openssl") "md5")) - (setq mh-checksum-parser #'mh-openssl-parser)) - ((executable-find "md5") - (setq mh-checksum-cmd (list (executable-find "md5"))) - (setq mh-checksum-parser #'mh-md5-parser)) - (t (error "No suitable checksum program")))))) - -(defun mh-md5sum-parser () - "Parse md5sum output." - (let ((begin (line-beginning-position)) - (end (line-end-position)) - first-space last-slash) - (setq first-space (search-forward " " end t)) - (goto-char end) - (setq last-slash (search-backward "/" begin t)) - (cond ((and first-space last-slash) - (cons (car (read-from-string (buffer-substring-no-properties - (1+ last-slash) end))) - (buffer-substring-no-properties begin (1- first-space)))) - (t (cons nil nil))))) - -(defun mh-openssl-parser () - "Parse openssl output." - (let ((begin (line-beginning-position)) - (end (line-end-position)) - last-space last-slash) - (goto-char end) - (setq last-space (search-backward " " begin t)) - (setq last-slash (search-backward "/" begin t)) - (cond ((and last-slash last-space) - (cons (car (read-from-string (buffer-substring-no-properties - (1+ last-slash) (1- last-space)))) - (buffer-substring-no-properties (1+ last-space) end)))))) - -(defalias 'mh-md5-parser 'mh-openssl-parser) - - - -;;; Make sure that we don't produce too long a command line. - -(defvar mh-index-max-cmdline-args 500 - "Maximum number of command line args.") - -(defun mh-index-execute (cmd &rest args) - "Partial imitation of xargs. -The current buffer contains a list of strings, one on each line. The function -will execute CMD with ARGS and pass the first `mh-index-max-cmdline-args' -strings to it. This is repeated till all the strings have been used." - (goto-char (point-min)) - (let ((out (get-buffer-create " *mh-xargs-output*"))) - (save-excursion - (set-buffer out) - (erase-buffer)) - (while (not (eobp)) - (let ((arg-list (reverse args)) - (count 0)) - (while (and (not (eobp)) (< count mh-index-max-cmdline-args)) - (push (buffer-substring-no-properties (point) (line-end-position)) - arg-list) - (incf count) - (forward-line)) - (apply #'call-process cmd nil (list out nil) nil (nreverse arg-list)))) - (erase-buffer) - (insert-buffer-substring out))) - - - -(defun mh-index-update-single-msg (msg checksum origin-map) - "Update various maps for one message. -MSG is a index folder message, CHECKSUM its MD5 hash and ORIGIN-MAP, if -non-nil, a hashtable containing which maps each message in the index folder to -the folder and message that it was copied from. The function updates the hash -tables `mh-index-msg-checksum-map' and `mh-index-checksum-origin-map'. - -This function should only be called in the appropriate index folder buffer." - (cond ((and origin-map (gethash checksum mh-index-checksum-origin-map)) - (let* ((intermediate (gethash msg origin-map)) - (ofolder (car intermediate)) - (omsg (cdr intermediate))) - ;; This is most probably a duplicate. So eliminate it. - (call-process "rm" nil nil nil - (format "%s%s/%s" mh-user-path - (substring mh-current-folder 1) msg)) - (remhash omsg (gethash ofolder mh-index-data)))) - (t - (setf (gethash msg mh-index-msg-checksum-map) checksum) - (when origin-map - (setf (gethash checksum mh-index-checksum-origin-map) - (gethash msg origin-map)))))) - -;;;###mh-autoload -(defun mh-index-update-maps (folder &optional origin-map) - "Annotate all as yet unannotated messages in FOLDER with their MD5 hash. -As a side effect msg -> checksum map is updated. Optional argument ORIGIN-MAP -is a hashtable which maps each message in the index folder to the original -folder and message from whence it was copied. If present the -checksum -> (origin-folder, origin-index) map is updated too." - (clrhash mh-index-msg-checksum-map) - (save-excursion - ;; Clear temp buffer - (set-buffer (get-buffer-create mh-checksum-buffer)) - (erase-buffer) - ;; Run scan to check if any messages needs MD5 annotations at all - (with-temp-buffer - (mh-exec-cmd-output mh-scan-prog nil "-width" "80" - "-format" "%(msg)\n%{x-mhe-checksum}\n" - folder "all") - (goto-char (point-min)) - (let (msg checksum) - (while (not (eobp)) - (setq msg (buffer-substring-no-properties - (point) (line-end-position))) - (forward-line) - (save-excursion - (cond ((eolp) - ;; need to compute checksum - (set-buffer mh-checksum-buffer) - (insert mh-user-path (substring folder 1) "/" msg "\n")) - (t - ;; update maps - (setq checksum (buffer-substring-no-properties - (point) (line-end-position))) - (let ((msg (car (read-from-string msg)))) - (set-buffer folder) - (mh-index-update-single-msg msg checksum origin-map))))) - (forward-line)))) - ;; Run checksum program if needed - (unless (and (eobp) (bobp)) - (apply #'mh-index-execute mh-checksum-cmd) - (goto-char (point-min)) - (while (not (eobp)) - (let* ((intermediate (funcall mh-checksum-parser)) - (msg (car intermediate)) - (checksum (cdr intermediate))) - (when msg - ;; annotate - (mh-exec-cmd "anno" folder msg "-component" "X-MHE-Checksum" - "-nodate" "-text" checksum "-inplace") - ;; update maps - (save-excursion - (set-buffer folder) - (mh-index-update-single-msg msg checksum origin-map))) - (forward-line)))))) - -(defun mh-index-generate-pretty-name (string) - "Given STRING generate a name which is suitable for use as a folder name. -White space from the beginning and end are removed. All spaces in the name are -replaced with underscores and all / are replaced with $. If STRING is longer -than 20 it is truncated too." - (with-temp-buffer - (insert string) - (goto-char (point-min)) - (while (and (not (eobp)) (memq (char-after) '(? ?\t ?\n ?\r))) - (delete-char 1)) - (goto-char (point-max)) - (while (and (not (bobp)) (memq (char-before) '(? ?\t ?\n ?\r))) - (delete-backward-char 1)) - (subst-char-in-region (point-min) (point-max) ? ?_ t) - (subst-char-in-region (point-min) (point-max) ?\t ?_ t) - (subst-char-in-region (point-min) (point-max) ?\n ?_ t) - (subst-char-in-region (point-min) (point-max) ?\r ?_ t) - (subst-char-in-region (point-min) (point-max) ?/ ?$ t) - (truncate-string-to-width (buffer-substring (point-min) (point-max)) 20))) - -;;;###mh-autoload -(defun mh-index-search (redo-search-flag folder search-regexp) - "Perform an indexed search in an MH mail folder. - -If REDO-SEARCH-FLAG is non-nil and the current folder buffer was generated by a -index search, then the search is repeated. Otherwise, FOLDER is searched with -SEARCH-REGEXP and the results are presented in an MH-E folder. If FOLDER is -\"+\" then mail in all folders are searched. - -Four indexing programs are supported; if none of these are present, then grep -is used. This function picks the first program that is available on your -system. If you would prefer to use a different program, set the customization -variable `mh-index-program' accordingly. - -The documentation for the following functions describes how to generate the -index for each program: - - - `mh-swish++-execute-search' - - `mh-swish-execute-search' - - `mh-namazu-execute-search' - - `mh-glimpse-execute-search' - -This and related functions use an X-MHE-Checksum header to cache the MD5 -checksum of a message. This means that already present X-MHE-Checksum headers -in the incoming email could result in messages not being found. The following -procmail recipe should avoid this: - - :0 wf - | formail -R \"X-MHE-Checksum\" \"Old-X-MHE-Checksum\" - -This has the effect of renaming already present X-MHE-Checksum headers." - (interactive - (list current-prefix-arg - (progn - (unless mh-find-path-run (mh-find-path)) - (or (and current-prefix-arg (car mh-index-previous-search)) - (mh-prompt-for-folder "Search" "+" nil "all"))) - (progn - ;; Yes, we do want to call mh-index-choose every time in case the - ;; user has switched the indexer manually. - (unless (mh-index-choose) (error "No indexing program found")) - (or (and current-prefix-arg (cadr mh-index-previous-search)) - (read-string (format "%s regexp: " - (upcase-initials - (symbol-name mh-indexer)))))))) - (mh-checksum-choose) - (let ((result-count 0) - (old-window-config mh-previous-window-config) - (previous-search mh-index-previous-search) - (index-folder (format "%s/%s" mh-index-folder - (mh-index-generate-pretty-name search-regexp)))) - ;; Create a new folder for the search results or recreate the old one... - (if (and redo-search-flag mh-index-previous-search) - (let ((buffer-name (buffer-name (current-buffer)))) - (mh-process-or-undo-commands buffer-name) - (save-excursion (mh-exec-cmd-quiet nil "rmf" buffer-name)) - (mh-exec-cmd-quiet nil "folder" "-create" "-fast" buffer-name) - (setq index-folder buffer-name)) - (setq index-folder (mh-index-new-folder index-folder))) - - (let ((folder-path (format "%s%s" mh-user-path (substring folder 1))) - (folder-results-map (make-hash-table :test #'equal)) - (origin-map (make-hash-table :test #'equal))) - ;; Run search program... - (message "Executing %s... " mh-indexer) - (funcall mh-index-execute-search-function folder-path search-regexp) - - ;; Parse indexer output - (message "Processing %s output... " mh-indexer) - (goto-char (point-min)) - (loop for next-result = (funcall mh-index-next-result-function) - when (null next-result) return nil - do (unless (eq next-result 'error) - (unless (gethash (car next-result) folder-results-map) - (setf (gethash (car next-result) folder-results-map) - (make-hash-table :test #'equal))) - (setf (gethash (cadr next-result) - (gethash (car next-result) folder-results-map)) - t))) - - ;; Copy the search results over - (maphash #'(lambda (folder msgs) - (let ((msgs (sort (loop for msg being the hash-keys of msgs - collect msg) - #'<))) - (mh-exec-cmd "refile" msgs "-src" folder - "-link" index-folder) - (loop for msg in msgs - do (incf result-count) - (setf (gethash result-count origin-map) - (cons folder msg))))) - folder-results-map) - - ;; Generate scan lines for the hits. - (let ((mh-show-threads-flag nil)) - (mh-visit-folder index-folder () (list folder-results-map origin-map))) - - (goto-char (point-min)) - (forward-line) - (mh-update-sequences) - (mh-recenter nil) - - ;; Maintain history - (when (and redo-search-flag previous-search) - (setq mh-previous-window-config old-window-config)) - (setq mh-index-previous-search (list folder search-regexp)) - - (message "%s found %s matches in %s folders" - (upcase-initials (symbol-name mh-indexer)) - (loop for msg-hash being hash-values of mh-index-data - sum (hash-table-count msg-hash)) - (loop for msg-hash being hash-values of mh-index-data - count (> (hash-table-count msg-hash) 0)))))) - -;;;###mh-autoload -(defun mh-index-next-folder (&optional backward-flag) - "Jump to the next folder marker. -The function is only applicable to folders displaying index search results. -With non-nil optional argument BACKWARD-FLAG, jump to the previous group of -results." - (interactive "P") - (if (or (null mh-index-data) - (memq 'unthread mh-view-ops)) - (message "Only applicable in an unthreaded MH-E index search buffer") - (let ((point (point))) - (forward-line (if backward-flag -1 1)) - (cond ((if backward-flag - (re-search-backward "^+" (point-min) t) - (re-search-forward "^+" (point-max) t)) - (beginning-of-line)) - ((and (if backward-flag - (goto-char (point-max)) - (goto-char (point-min))) - nil)) - ((if backward-flag - (re-search-backward "^+" (point-min) t) - (re-search-forward "^+" (point-max) t)) - (beginning-of-line)) - (t (goto-char point)))))) - -;;;###mh-autoload -(defun mh-index-previous-folder () - "Jump to the previous folder marker." - (interactive) - (mh-index-next-folder t)) - -(defun mh-folder-exists-p (folder) - "Check if FOLDER exists." - (and (mh-folder-name-p folder) - (save-excursion - (with-temp-buffer - (mh-exec-cmd-output "folder" nil "-fast" "-nocreate" folder) - (goto-char (point-min)) - (not (eobp)))))) - -(defun mh-msg-exists-p (msg folder) - "Check if MSG exists in FOLDER." - (file-exists-p (format "%s%s/%s" mh-user-path (substring folder 1) msg))) - -(defun mh-index-new-folder (name) - "Create and return an MH folder name based on NAME. -If the folder NAME already exists then check if NAME<2> exists. If it doesn't -then it is created and returned. Otherwise try NAME<3>. This is repeated till -we find a new folder name." - (unless (mh-folder-name-p name) - (error "The argument should be a valid MH folder name")) - (let ((chosen-name name)) - (block unique-name - (unless (mh-folder-exists-p name) - (return-from unique-name)) - (loop for index from 2 - do (let ((new-name (format "%s<%s>" name index))) - (unless (mh-folder-exists-p new-name) - (setq chosen-name new-name) - (return-from unique-name))))) - (mh-exec-cmd-quiet nil "folder" "-create" "-fast" chosen-name) - (when (boundp 'mh-speed-folder-map) - (mh-speed-add-folder chosen-name)) - (push (list chosen-name) mh-folder-list) - chosen-name)) - -;;;###mh-autoload -(defun mh-index-insert-folder-headers () - "Annotate the search results with original folder names." - (let ((cur-msg (mh-get-msg-num nil)) - (old-buffer-modified-flag (buffer-modified-p)) - (buffer-read-only nil) - current-folder last-folder) - (goto-char (point-min)) - (while (not (eobp)) - (setq current-folder (car (gethash (gethash (mh-get-msg-num nil) - mh-index-msg-checksum-map) - mh-index-checksum-origin-map))) - (when (and current-folder (not (eq current-folder last-folder))) - (insert (if last-folder "\n" "") current-folder "\n") - (setq last-folder current-folder)) - (forward-line)) - (when cur-msg (mh-goto-msg cur-msg t)) - (set-buffer-modified-p old-buffer-modified-flag))) - -;;;###mh-autoload -(defun mh-index-delete-folder-headers () - "Delete the folder headers." - (let ((cur-msg (mh-get-msg-num nil)) - (old-buffer-modified-flag (buffer-modified-p)) - (buffer-read-only nil)) - (goto-char (point-min)) - (while (not (eobp)) - (if (or (char-equal (char-after) ?+) (char-equal (char-after) 10)) - (delete-region (point) (progn (forward-line) (point))) - (forward-line))) - (when cur-msg (mh-goto-msg cur-msg t t)) - (set-buffer-modified-p old-buffer-modified-flag))) - -;;;###mh-autoload -(defun mh-index-visit-folder () - "Visit original folder from where the message at point was found." - (interactive) - (unless mh-index-data - (error "Not in an index folder")) - (let (folder msg) - (save-excursion - (cond ((and (bolp) (eolp)) - (ignore-errors (forward-line -1)) - (setq msg (mh-get-msg-num t))) - ((equal (char-after (line-beginning-position)) ?+) - (setq folder (buffer-substring-no-properties - (line-beginning-position) (line-end-position)))) - (t (setq msg (mh-get-msg-num t))))) - (when (not folder) - (setq folder (car (gethash (gethash msg mh-index-msg-checksum-map) - mh-index-checksum-origin-map)))) - (mh-visit-folder - folder (loop for x being the hash-keys of (gethash folder mh-index-data) - when (mh-msg-exists-p x folder) collect x)))) - -(defun mh-index-match-checksum (msg folder checksum) - "Check if MSG in FOLDER has X-MHE-Checksum header value of CHECKSUM." - (with-temp-buffer - (mh-exec-cmd-output mh-scan-prog nil "-width" "80" - "-format" "%{x-mhe-checksum}\n" folder msg) - (goto-char (point-min)) - (string-equal (buffer-substring-no-properties (point) (line-end-position)) - checksum))) - -;;;###mh-autoload -(defun mh-index-execute-commands () - "Delete/refile the actual messages. -The copies in the searched folder are then deleted/refiled to get the desired -result. Before deleting the messages we make sure that the message being -deleted is identical to the one that the user has marked in the index buffer." - (let ((message-table (make-hash-table :test #'equal))) - (dolist (msg-list (cons mh-delete-list (mapcar #'cdr mh-refile-list))) - (dolist (msg msg-list) - (let* ((checksum (gethash msg mh-index-msg-checksum-map)) - (pair (gethash checksum mh-index-checksum-origin-map))) - (when (and checksum (car pair) (cdr pair) - (mh-index-match-checksum (cdr pair) (car pair) checksum)) - (push (cdr pair) (gethash (car pair) message-table)) - (remhash (cdr pair) (gethash (car pair) mh-index-data)))))) - (maphash (lambda (folder msgs) - (apply #'mh-exec-cmd "rmm" folder (mh-coalesce-msg-list msgs))) - message-table))) - - - -;; Glimpse interface - -(defvar mh-glimpse-binary (executable-find "glimpse")) -(defvar mh-glimpse-directory ".glimpse") - -;;;###mh-autoload -(defun mh-glimpse-execute-search (folder-path search-regexp) - "Execute glimpse and read the results. - -In the examples below, replace /home/user/Mail with the path to your MH -directory. - -First create the directory /home/user/Mail/.glimpse. Then create the file -/home/user/Mail/.glimpse/.glimpse_exclude with the following contents: - - */.* - */#* - */,* - */*~ - ^/home/user/Mail/.glimpse - ^/home/user/Mail/mhe-index - -If there are any directories you would like to ignore, append lines like the -following to .glimpse_exclude: - - ^/home/user/Mail/scripts - -You do not want to index the folders that hold the results of your searches -since they tend to be ephemeral and the original messages are indexed anyway. -The configuration file above assumes that the results are found in sub-folders -of `mh-index-folder' which is +mhe-index by default. - -Use the following command line to generate the glimpse index. Run this -daily from cron: - - glimpseindex -H /home/user/Mail/.glimpse /home/user/Mail - -FOLDER-PATH is the directory in which SEARCH-REGEXP is used to search." - (set-buffer (get-buffer-create mh-index-temp-buffer)) - (erase-buffer) - (call-process mh-glimpse-binary nil '(t nil) nil - ;(format "-%s" fuzz) - "-i" "-y" - "-H" (format "%s%s" mh-user-path mh-glimpse-directory) - "-F" (format "^%s" folder-path) - search-regexp) - (goto-char (point-min))) - -(defun mh-glimpse-next-result () - "Read the next result. -Parse it and return the message folder, message index and the match. If no -other matches left then return nil. If the current record is invalid return -'error." - (prog1 - (block nil - (when (eobp) - (return nil)) - (let ((eol-pos (line-end-position)) - (bol-pos (line-beginning-position)) - folder-start msg-end) - (goto-char bol-pos) - (unless (search-forward mh-user-path eol-pos t) - (return 'error)) - (setq folder-start (point)) - (unless (search-forward ": " eol-pos t) - (return 'error)) - (let ((match (buffer-substring-no-properties (point) eol-pos))) - (forward-char -2) - (setq msg-end (point)) - (unless (search-backward "/" folder-start t) - (return 'error)) - (list (format "+%s" (buffer-substring-no-properties - folder-start (point))) - (let ((val (ignore-errors (read-from-string - (buffer-substring-no-properties - (1+ (point)) msg-end))))) - (if (and (consp val) (integerp (car val))) - (car val) - (return 'error))) - match)))) - (forward-line))) - - - -;; Grep interface - -(defvar mh-grep-binary (executable-find "grep")) - -(defun mh-grep-execute-search (folder-path search-regexp) - "Execute grep and read the results. -FOLDER-PATH is the directory in which SEARCH-REGEXP is used to search." - (set-buffer (get-buffer-create mh-index-temp-buffer)) - (erase-buffer) - (call-process mh-grep-binary nil '(t nil) nil - "-i" "-r" search-regexp folder-path) - (goto-char (point-min))) - -(defun mh-grep-next-result () - "Read the next result. -Parse it and return the message folder, message index and the match. If no -other matches left then return nil. If the current record is invalid return -'error." - (prog1 - (block nil - (when (eobp) - (return nil)) - (let ((eol-pos (line-end-position)) - (bol-pos (line-beginning-position)) - folder-start msg-end) - (goto-char bol-pos) - (unless (search-forward mh-user-path eol-pos t) - (return 'error)) - (setq folder-start (point)) - (unless (search-forward ":" eol-pos t) - (return 'error)) - (let ((match (buffer-substring-no-properties (point) eol-pos))) - (forward-char -1) - (setq msg-end (point)) - (unless (search-backward "/" folder-start t) - (return 'error)) - (list (format "+%s" (buffer-substring-no-properties - folder-start (point))) - (let ((val (ignore-errors (read-from-string - (buffer-substring-no-properties - (1+ (point)) msg-end))))) - (if (and (consp val) (integerp (car val))) - (car val) - (return 'error))) - match)))) - (forward-line))) - - - -;; Swish interface - -(defvar mh-swish-binary (executable-find "swish-e")) -(defvar mh-swish-directory ".swish") -(defvar mh-swish-folder nil) - -;;;###mh-autoload -(defun mh-swish-execute-search (folder-path search-regexp) - "Execute swish-e and read the results. - -In the examples below, replace /home/user/Mail with the path to your MH -directory. - -First create the directory /home/user/Mail/.swish. Then create the file -/home/user/Mail/.swish/config with the following contents: - - IndexDir /home/user/Mail - IndexFile /home/user/Mail/.swish/index - IndexName \"Mail Index\" - IndexDescription \"Mail Index\" - IndexPointer \"http://nowhere\" - IndexAdmin \"nobody\" - #MetaNames automatic - IndexReport 3 - FollowSymLinks no - UseStemming no - IgnoreTotalWordCountWhenRanking yes - WordCharacters abcdefghijklmnopqrstuvwxyz0123456789- - BeginCharacters abcdefghijklmnopqrstuvwxyz - EndCharacters abcdefghijklmnopqrstuvwxyz0123456789 - IgnoreLimit 50 1000 - IndexComments 0 - FileRules pathname contains /home/user/Mail/.swish - FileRules pathname contains /home/user/Mail/mhe-index - FileRules filename is index - FileRules filename is \..* - FileRules filename is #.* - FileRules filename is ,.* - FileRules filename is .*~ - -If there are any directories you would like to ignore, append lines like the -following to config: - - FileRules pathname contains /home/user/Mail/scripts - -You do not want to index the folders that hold the results of your searches -since they tend to be ephemeral and the original messages are indexed anyway. -The configuration file above assumes that the results are found in sub-folders -of `mh-index-folder' which is +mhe-index by default. - -Use the following command line to generate the swish index. Run this -daily from cron: - - swish-e -c /home/user/Mail/.swish/config - -FOLDER-PATH is the directory in which SEARCH-REGEXP is used to search." - (set-buffer (get-buffer-create mh-index-temp-buffer)) - (erase-buffer) - (unless mh-swish-binary - (error "Set mh-swish-binary appropriately")) - (call-process mh-swish-binary nil '(t nil) nil - "-w" search-regexp - "-f" (format "%s%s/index" mh-user-path mh-swish-directory)) - (goto-char (point-min)) - (setq mh-swish-folder - (let ((last-char (substring folder-path (1- (length folder-path))))) - (if (equal last-char "/") - folder-path - (format "%s/" folder-path))))) - -(defun mh-swish-next-result () - "Get the next result from swish output." - (prog1 - (block nil - (when (or (eobp) (equal (char-after (point)) ?.)) - (return nil)) - (when (equal (char-after (point)) ?#) - (return 'error)) - (let* ((start (search-forward " " (line-end-position) t)) - (end (search-forward " " (line-end-position) t))) - (unless (and start end) - (return 'error)) - (setq end (1- end)) - (unless (file-exists-p (buffer-substring-no-properties start end)) - (return 'error)) - (unless (search-backward "/" start t) - (return 'error)) - (list (let* ((s (buffer-substring-no-properties start (1+ (point))))) - (unless (string-match mh-swish-folder s) - (return 'error)) - (if (string-match mh-user-path s) - (format "+%s" - (substring s (match-end 0) (1- (length s)))) - (return 'error))) - (let* ((s (buffer-substring-no-properties (1+ (point)) end)) - (val (ignore-errors (read-from-string s)))) - (if (and (consp val) (numberp (car val))) - (car val) - (return 'error))) - nil))) - (forward-line))) - - - -;; Swish++ interface - -(defvar mh-swish++-binary (or (executable-find "search++") - (executable-find "search"))) -(defvar mh-swish++-directory ".swish++") - -;;;###mh-autoload -(defun mh-swish++-execute-search (folder-path search-regexp) - "Execute swish++ and read the results. - -In the examples below, replace /home/user/Mail with the path to your MH -directory. - -First create the directory /home/user/Mail/.swish++. Then create the file -/home/user/Mail/.swish++/swish++.conf with the following contents: - - IncludeMeta Bcc Cc Comments Content-Description From Keywords - IncludeMeta Newsgroups Resent-To Subject To - IncludeMeta Message-Id References In-Reply-To - IncludeFile Mail * - IndexFile /home/user/Mail/.swish++/swish++.index - -Use the following command line to generate the swish index. Run this -daily from cron: - - find /home/user/Mail -path /home/user/Mail/mhe-index -prune \\ - -o -path /home/user/Mail/.swish++ -prune \\ - -o -name \"[0-9]*\" -print \\ - | index -c /home/user/Mail/.swish++/swish++.conf /home/user/Mail - -You do not want to index the folders that hold the results of your searches -since they tend to be ephemeral and the original messages are indexed anyway. -The command above assumes that the results are found in sub-folders of -`mh-index-folder' which is +mhe-index by default. - -On some systems (Debian GNU/Linux, for example), use index++ instead of index. - -FOLDER-PATH is the directory in which SEARCH-REGEXP is used to search." - (set-buffer (get-buffer-create mh-index-temp-buffer)) - (erase-buffer) - (unless mh-swish++-binary - (error "Set mh-swish++-binary appropriately")) - (call-process mh-swish++-binary nil '(t nil) nil - "-m" "10000" - (format "-i%s%s/swish++.index" - mh-user-path mh-swish++-directory) - search-regexp) - (goto-char (point-min)) - (setq mh-swish-folder - (let ((last-char (substring folder-path (1- (length folder-path))))) - (if (equal last-char "/") - folder-path - (format "%s/" folder-path))))) - -(defalias 'mh-swish++-next-result 'mh-swish-next-result) - - - -;; Namazu interface - -(defvar mh-namazu-binary (executable-find "namazu")) -(defvar mh-namazu-directory ".namazu") -(defvar mh-namazu-folder nil) - -;;;###mh-autoload -(defun mh-namazu-execute-search (folder-path search-regexp) - "Execute namazu and read the results. - -In the examples below, replace /home/user/Mail with the path to your MH -directory. - -First create the directory /home/user/Mail/.namazu. Then create the file -/home/user/Mail/.namazu/mknmzrc with the following contents: - - package conf; # Don't remove this line! - $ADDRESS = 'user@localhost'; - $ALLOW_FILE = \"[0-9]*\"; - $EXCLUDE_PATH = \"^/home/user/Mail/(mhe-index|spam)\"; - -In the above example configuration, none of the mail files contained in the -directories /home/user/Mail/mhe-index and /home/user/Mail/spam are indexed. - -You do not want to index the folders that hold the results of your searches -since they tend to be ephemeral and the original messages are indexed anyway. -The configuration file above assumes that the results are found in sub-folders -of `mh-index-folder' which is +mhe-index by default. - -Use the following command line to generate the namazu index. Run this -daily from cron: - - mknmz -f /home/user/Mail/.namazu/mknmzrc -O /home/user/Mail/.namazu \\ - /home/user/Mail - -FOLDER-PATH is the directory in which SEARCH-REGEXP is used to search." - (let ((namazu-index-directory - (format "%s%s" mh-user-path mh-namazu-directory))) - (unless (file-exists-p namazu-index-directory) - (error "Namazu directory %s not present" namazu-index-directory)) - (unless (executable-find mh-namazu-binary) - (error "Set mh-namazu-binary appropriately")) - (set-buffer (get-buffer-create mh-index-temp-buffer)) - (erase-buffer) - (call-process mh-namazu-binary nil '(t nil) nil - "-alR" search-regexp namazu-index-directory) - (goto-char (point-min)) - (setq mh-namazu-folder - (let ((last (substring folder-path (1- (length folder-path))))) - (if (equal last "/") - folder-path - (format "%s/" folder-path)))))) - -(defun mh-namazu-next-result () - "Get the next result from namazu output." - (prog1 - (block nil - (when (eobp) (return nil)) - (let ((file-name (buffer-substring-no-properties - (point) (line-end-position)))) - (unless (equal (string-match mh-namazu-folder file-name) 0) - (return 'error)) - (unless (file-exists-p file-name) - (return 'error)) - (string-match mh-user-path file-name) - (let* ((folder/msg (substring file-name (match-end 0))) - (mark (mh-search-from-end ?/ folder/msg))) - (unless mark (return 'error)) - (list (format "+%s" (substring folder/msg 0 mark)) - (let ((n (ignore-errors (read-from-string - (substring folder/msg (1+ mark)))))) - (if (and (consp n) (numberp (car n))) - (car n) - (return 'error))) - nil)))) - (forward-line))) - - - -(defun mh-index-choose () - "Choose an indexing function. -The side-effects of this function are that the variables `mh-indexer', -`mh-index-execute-search-function', and `mh-index-next-result-function' are -set according to the first indexer in `mh-indexer-choices' present on the -system." - (block nil - ;; The following favors the user's preference; otherwise, the last - ;; automatically chosen indexer is used for efficiency rather than going - ;; through the list. - (let ((program-alist (cond (mh-index-program - (list - (assoc mh-index-program mh-indexer-choices))) - (mh-indexer - (list (assoc mh-indexer mh-indexer-choices))) - (t mh-indexer-choices)))) - (while program-alist - (let* ((current (pop program-alist)) - (executable (symbol-value (cadr current)))) - (when executable - (setq mh-indexer (car current)) - (setq mh-index-execute-search-function (caddr current)) - (setq mh-index-next-result-function (cadddr current)) - (return mh-indexer)))) - nil))) - - - -(provide 'mh-index) - -;;; Local Variables: -;;; indent-tabs-mode: nil -;;; sentence-end-double-space: nil -;;; End: - -;;; mh-index ends here
--- a/lisp/mail/mh-loaddefs.el Sun Jan 26 01:33:33 2003 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,880 +0,0 @@ -;;; mh-loaddefs.el --- automatically extracted autoloads -;; -;;; Commentary: -;;; Code: - -;;;### (autoloads (mh-letter-complete mh-open-line mh-fully-kill-draft -;;;;;; mh-yank-cur-msg mh-insert-letter mh-send-letter mh-check-whom -;;;;;; mh-insert-signature mh-to-fcc mh-to-field mh-fill-paragraph-function -;;;;;; mh-send-other-window mh-send mh-reply mh-redistribute mh-forward -;;;;;; mh-extract-rejected-mail mh-edit-again) "mh-comp" "mh-comp.el" -;;;;;; (15899 19356)) -;;; Generated autoloads from mh-comp.el - -(autoload (quote mh-edit-again) "mh-comp" "\ -Clean up a draft or a message MSG previously sent and make it resendable. -Default is the current message. -The variable `mh-new-draft-cleaned-headers' specifies the headers to remove. -See also documentation for `\\[mh-send]' function." t nil) - -(autoload (quote mh-extract-rejected-mail) "mh-comp" "\ -Extract message MSG returned by the mail system and make it resendable. -Default is the current message. The variable `mh-new-draft-cleaned-headers' -gives the headers to clean out of the original message. -See also documentation for `\\[mh-send]' function." t nil) - -(autoload (quote mh-forward) "mh-comp" "\ -Forward one or more messages to the recipients TO and CC. - -Use the optional MSG-OR-SEQ to specify a message or sequence to forward. - -Default is the displayed message. If optional prefix argument is given then -prompt for the message sequence. If variable `transient-mark-mode' is non-nil -and the mark is active, then the selected region is forwarded. -See also documentation for `\\[mh-send]' function." t nil) - -(autoload (quote mh-redistribute) "mh-comp" "\ -Redistribute displayed message to recipients TO and CC. -Use optional argument MSG to redistribute another message. -Depending on how your copy of MH was compiled, you may need to change the -setting of the variable `mh-redist-full-contents'. See its documentation." t nil) - -(autoload (quote mh-reply) "mh-comp" "\ -Reply to MESSAGE (default: current message). -If the optional argument REPLY-TO is not given, prompts for type of addresses -to reply to: - from sender only, - to sender and primary recipients, - cc/all sender and all recipients. -If optional prefix argument INCLUDEP provided, then include the message -in the reply using filter `mhl.reply' in your MH directory. -If the file named by `mh-repl-formfile' exists, it is used as a skeleton -for the reply. See also documentation for `\\[mh-send]' function." t nil) - -(autoload (quote mh-send) "mh-comp" "\ -Compose and send a letter. - -Do not call this function from outside MH-E; use \\[mh-smail] instead. - -The file named by `mh-comp-formfile' will be used as the form. -The letter is composed in `mh-letter-mode'; see its documentation for more -details. -If `mh-compose-letter-function' is defined, it is called on the draft and -passed three arguments: TO, CC, and SUBJECT." t nil) - -(autoload (quote mh-send-other-window) "mh-comp" "\ -Compose and send a letter in another window. - -Do not call this function from outside MH-E; use \\[mh-smail-other-window] -instead. - -The file named by `mh-comp-formfile' will be used as the form. -The letter is composed in `mh-letter-mode'; see its documentation for more -details. -If `mh-compose-letter-function' is defined, it is called on the draft and -passed three arguments: TO, CC, and SUBJECT." t nil) - -(autoload (quote mh-fill-paragraph-function) "mh-comp" "\ -Fill paragraph at or after point. -Prefix ARG means justify as well. This function enables `fill-paragraph' to -work better in MH-Letter mode." t nil) - -(autoload (quote mh-to-field) "mh-comp" "\ -Move point to the end of a specified header field. -The field is indicated by the previous keystroke (the last keystroke -of the command) according to the list in the variable `mh-to-field-choices'. -Create the field if it does not exist. Set the mark to point before moving." t nil) - -(autoload (quote mh-to-fcc) "mh-comp" "\ -Insert an Fcc: FOLDER field in the current message. -Prompt for the field name with a completion list of the current folders." t nil) - -(autoload (quote mh-insert-signature) "mh-comp" "\ -Insert the file named by `mh-signature-file-name' at point. -The value of `mh-letter-insert-signature-hook' is a list of functions to be -called, with no arguments, before the signature is actually inserted." t nil) - -(autoload (quote mh-check-whom) "mh-comp" "\ -Verify recipients of the current letter, showing expansion of any aliases." t nil) - -(autoload (quote mh-send-letter) "mh-comp" "\ -Send the draft letter in the current buffer. -If optional prefix argument ARG is provided, monitor delivery. -The value of `mh-before-send-letter-hook' is a list of functions to be called, -with no arguments, before doing anything. -Run `\\[mh-edit-mhn]' if variable `mh-mhn-compose-insert-flag' is set. -Run `\\[mh-mml-to-mime]' if variable `mh-mml-compose-insert-flag' is set. -Insert X-Mailer field if variable `mh-insert-x-mailer-flag' is set. -Insert X-Face field if the file specified by `mh-x-face-file' exists." t nil) - -(autoload (quote mh-insert-letter) "mh-comp" "\ -Insert a message into the current letter. -Removes the header fields according to the variable `mh-invisible-headers'. -Prefixes each non-blank line with `mh-ins-buf-prefix', unless -`mh-yank-from-start-of-msg' is set for supercite in which case supercite is -used to format the message. -Prompts for FOLDER and MESSAGE. If prefix argument VERBATIM provided, do -not indent and do not delete headers. Leaves the mark before the letter -and point after it." t nil) - -(autoload (quote mh-yank-cur-msg) "mh-comp" "\ -Insert the current message into the draft buffer. -Prefix each non-blank line in the message with the string in -`mh-ins-buf-prefix'. If a region is set in the message's buffer, then -only the region will be inserted. Otherwise, the entire message will -be inserted if `mh-yank-from-start-of-msg' is non-nil. If this variable -is nil, the portion of the message following the point will be yanked. -If `mh-delete-yanked-msg-window-flag' is non-nil, any window displaying the -yanked message will be deleted." t nil) - -(autoload (quote mh-fully-kill-draft) "mh-comp" "\ -Kill the draft message file and the draft message buffer. -Use \\[kill-buffer] if you don't want to delete the draft message file." t nil) - -(autoload (quote mh-open-line) "mh-comp" "\ -Insert a newline and leave point after it. -In addition, insert newline and quoting characters before text after point. -This is useful in breaking up paragraphs in replies." t nil) - -(autoload (quote mh-letter-complete) "mh-comp" "\ -Perform completion on header field or word preceding point. -Alias completion is done within the mail header on selected fields and -by the function designated by `mh-letter-complete-function' elsewhere, -passing the prefix ARG if any." t nil) - -;;;*** - -;;;### (autoloads (mh-tool-bar-folder-set mh-tool-bar-letter-set -;;;;;; mh-customize) "mh-customize" "mh-customize.el" (15899 29873)) -;;; Generated autoloads from mh-customize.el - -(autoload (quote mh-customize) "mh-customize" "\ -Customize MH-E variables." t nil) - -(autoload (quote mh-tool-bar-letter-set) "mh-customize" "\ -Construct toolbar for `mh-letter-mode'." nil nil) - -(autoload (quote mh-tool-bar-folder-set) "mh-customize" "\ -Construct toolbar for `mh-folder-mode'." nil nil) - -;;;*** - -;;;### (autoloads (mh-goto-cur-msg mh-update-sequences mh-folder-line-matches-show-buffer-p) -;;;;;; "mh-e" "mh-e.el" (15899 29921)) -;;; Generated autoloads from mh-e.el - -(autoload (quote mh-folder-line-matches-show-buffer-p) "mh-e" "\ -Return t if the message under point in folder-mode is in the show buffer. -Return nil in any other circumstance (no message under point, no show buffer, -the message in the show buffer doesn't match." nil nil) - -(autoload (quote mh-update-sequences) "mh-e" "\ -Update MH's Unseen-Sequence and current folder and message. -Flush MH-E's state out to MH. The message at the cursor becomes current." t nil) - -(autoload (quote mh-goto-cur-msg) "mh-e" "\ -Position the cursor at the current message. -When optional argument MINIMAL-CHANGES-FLAG is non-nil, the function doesn't -recenter the folder buffer." nil nil) - -;;;*** - -;;;### (autoloads (mh-prefix-help mh-help mh-store-buffer mh-store-msg -;;;;;; mh-undo-folder mh-sort-folder mh-print-msg mh-page-digest-backwards -;;;;;; mh-page-digest mh-pipe-msg mh-pack-folder mh-list-folders -;;;;;; mh-kill-folder mh-copy-msg mh-burst-digest) "mh-funcs" "mh-funcs.el" -;;;;;; (15886 19303)) -;;; Generated autoloads from mh-funcs.el - -(autoload (quote mh-burst-digest) "mh-funcs" "\ -Burst apart the current message, which should be a digest. -The message is replaced by its table of contents and the messages from the -digest are inserted into the folder after that message." t nil) - -(autoload (quote mh-copy-msg) "mh-funcs" "\ -Copy the specified MSG-OR-SEQ to another FOLDER without deleting them. -Default is the displayed message. If optional prefix argument is provided, -then prompt for the message sequence." t nil) - -(autoload (quote mh-kill-folder) "mh-funcs" "\ -Remove the current folder and all included messages. -Removes all of the messages (files) within the specified current folder, -and then removes the folder (directory) itself. -The value of `mh-folder-list-change-hook' is a list of functions to be called, -with no arguments, after the folders has been removed." t nil) - -(autoload (quote mh-list-folders) "mh-funcs" "\ -List mail folders." t nil) - -(autoload (quote mh-pack-folder) "mh-funcs" "\ -Renumber the messages of a folder to be 1..n. -First, offer to execute any outstanding commands for the current folder. If -optional prefix argument provided, prompt for the RANGE of messages to display -after packing. Otherwise, show the entire folder." t nil) - -(autoload (quote mh-pipe-msg) "mh-funcs" "\ -Pipe the current message through the given shell COMMAND. -If INCLUDE-HEADERS (prefix argument) is provided, send the entire message. -Otherwise just send the message's body without the headers." t nil) - -(autoload (quote mh-page-digest) "mh-funcs" "\ -Advance displayed message to next digested message." t nil) - -(autoload (quote mh-page-digest-backwards) "mh-funcs" "\ -Back up displayed message to previous digested message." t nil) - -(autoload (quote mh-print-msg) "mh-funcs" "\ -Print MSG-OR-SEQ (default: displayed message) on printer. -If optional prefix argument provided, then prompt for the message sequence. -The variable `mh-lpr-command-format' is used to generate the print command. -The messages are formatted by mhl. See the variable `mhl-formfile'." t nil) - -(autoload (quote mh-sort-folder) "mh-funcs" "\ -Sort the messages in the current folder by date. -Calls the MH program sortm to do the work. -The arguments in the list `mh-sortm-args' are passed to sortm if the optional -argument EXTRA-ARGS is given." t nil) - -(autoload (quote mh-undo-folder) "mh-funcs" "\ -Undo all pending deletes and refiles in current folder. -Argument IGNORE is deprecated." t nil) - -(autoload (quote mh-store-msg) "mh-funcs" "\ -Store the file(s) contained in the current message into DIRECTORY. -The message can contain a shar file or uuencoded file. -Default directory is the last directory used, or initially the value of -`mh-store-default-directory' or the current directory." t nil) - -(autoload (quote mh-store-buffer) "mh-funcs" "\ -Store the file(s) contained in the current buffer into DIRECTORY. -The buffer can contain a shar file or uuencoded file. -Default directory is the last directory used, or initially the value of -`mh-store-default-directory' or the current directory." t nil) - -(autoload (quote mh-help) "mh-funcs" "\ -Display cheat sheet for the MH-Folder commands in minibuffer." t nil) - -(autoload (quote mh-prefix-help) "mh-funcs" "\ -Display cheat sheet for the commands of the current prefix in minibuffer." t nil) - -;;;*** - -;;;### (autoloads (mh-insert-identity mh-identity-list-set mh-identity-make-menu) -;;;;;; "mh-identity" "mh-identity.el" (15852 60439)) -;;; Generated autoloads from mh-identity.el - -(autoload (quote mh-identity-make-menu) "mh-identity" "\ -Build (or rebuild) the Identity menu (e.g. after the list is modified)." nil nil) - -(autoload (quote mh-identity-list-set) "mh-identity" "\ -Update the `mh-identity-list' variable, and rebuild the menu. -Sets the default for SYMBOL (e.g. `mh-identity-list') to VALUE (as set in -customization). This is called after 'customize is used to alter -`mh-identity-list'." nil nil) - -(autoload (quote mh-insert-identity) "mh-identity" "\ -Insert proper fields for given IDENTITY. -Edit the `mh-identity-list' variable to define identity." t nil) - -;;;*** - -;;;### (autoloads (mh-namazu-execute-search mh-swish++-execute-search -;;;;;; mh-swish-execute-search mh-glimpse-execute-search mh-index-execute-commands -;;;;;; mh-index-visit-folder mh-index-delete-folder-headers mh-index-insert-folder-headers -;;;;;; mh-index-previous-folder mh-index-next-folder mh-index-search -;;;;;; mh-index-update-maps) "mh-index" "mh-index.el" (15899 19358)) -;;; Generated autoloads from mh-index.el - -(autoload (quote mh-index-update-maps) "mh-index" "\ -Annotate all as yet unannotated messages in FOLDER with their MD5 hash. -As a side effect msg -> checksum map is updated. Optional argument ORIGIN-MAP -is a hashtable which maps each message in the index folder to the original -folder and message from whence it was copied. If present the -checksum -> (origin-folder, origin-index) map is updated too." nil nil) - -(autoload (quote mh-index-search) "mh-index" "\ -Perform an indexed search in an MH mail folder. - -If REDO-SEARCH-FLAG is non-nil and the current folder buffer was generated by a -index search, then the search is repeated. Otherwise, FOLDER is searched with -SEARCH-REGEXP and the results are presented in an MH-E folder. If FOLDER is -\"+\" then mail in all folders are searched. - -Four indexing programs are supported; if none of these are present, then grep -is used. This function picks the first program that is available on your -system. If you would prefer to use a different program, set the customization -variable `mh-index-program' accordingly. - -The documentation for the following functions describes how to generate the -index for each program: - - - `mh-swish++-execute-search' - - `mh-swish-execute-search' - - `mh-namazu-execute-search' - - `mh-glimpse-execute-search' - -This and related functions use an X-MHE-Checksum header to cache the MD5 -checksum of a message. This means that already present X-MHE-Checksum headers -in the incoming email could result in messages not being found. The following -procmail recipe should avoid this: - - :0 wf - | formail -R \"X-MHE-Checksum\" \"Old-X-MHE-Checksum\" - -This has the effect of renaming already present X-MHE-Checksum headers." t nil) - -(autoload (quote mh-index-next-folder) "mh-index" "\ -Jump to the next folder marker. -The function is only applicable to folders displaying index search results. -With non-nil optional argument BACKWARD-FLAG, jump to the previous group of -results." t nil) - -(autoload (quote mh-index-previous-folder) "mh-index" "\ -Jump to the previous folder marker." t nil) - -(autoload (quote mh-index-insert-folder-headers) "mh-index" "\ -Annotate the search results with original folder names." nil nil) - -(autoload (quote mh-index-delete-folder-headers) "mh-index" "\ -Delete the folder headers." nil nil) - -(autoload (quote mh-index-visit-folder) "mh-index" "\ -Visit original folder from where the message at point was found." t nil) - -(autoload (quote mh-index-execute-commands) "mh-index" "\ -Delete/refile the actual messages. -The copies in the searched folder are then deleted/refiled to get the desired -result. Before deleting the messages we make sure that the message being -deleted is identical to the one that the user has marked in the index buffer." nil nil) - -(autoload (quote mh-glimpse-execute-search) "mh-index" "\ -Execute glimpse and read the results. - -In the examples below, replace /home/user/Mail with the path to your MH -directory. - -First create the directory /home/user/Mail/.glimpse. Then create the file -/home/user/Mail/.glimpse/.glimpse_exclude with the following contents: - - */.* - */#* - */,* - */*~ - ^/home/user/Mail/.glimpse - ^/home/user/Mail/mhe-index - -If there are any directories you would like to ignore, append lines like the -following to .glimpse_exclude: - - ^/home/user/Mail/scripts - -You do not want to index the folders that hold the results of your searches -since they tend to be ephemeral and the original messages are indexed anyway. -The configuration file above assumes that the results are found in sub-folders -of `mh-index-folder' which is +mhe-index by default. - -Use the following command line to generate the glimpse index. Run this -daily from cron: - - glimpseindex -H /home/user/Mail/.glimpse /home/user/Mail - -FOLDER-PATH is the directory in which SEARCH-REGEXP is used to search." nil nil) - -(autoload (quote mh-swish-execute-search) "mh-index" "\ -Execute swish-e and read the results. - -In the examples below, replace /home/user/Mail with the path to your MH -directory. - -First create the directory /home/user/Mail/.swish. Then create the file -/home/user/Mail/.swish/config with the following contents: - - IndexDir /home/user/Mail - IndexFile /home/user/Mail/.swish/index - IndexName \"Mail Index\" - IndexDescription \"Mail Index\" - IndexPointer \"http://nowhere\" - IndexAdmin \"nobody\" - #MetaNames automatic - IndexReport 3 - FollowSymLinks no - UseStemming no - IgnoreTotalWordCountWhenRanking yes - WordCharacters abcdefghijklmnopqrstuvwxyz0123456789- - BeginCharacters abcdefghijklmnopqrstuvwxyz - EndCharacters abcdefghijklmnopqrstuvwxyz0123456789 - IgnoreLimit 50 1000 - IndexComments 0 - FileRules pathname contains /home/user/Mail/.swish - FileRules pathname contains /home/user/Mail/mhe-index - FileRules filename is index - FileRules filename is ..* - FileRules filename is #.* - FileRules filename is ,.* - FileRules filename is .*~ - -If there are any directories you would like to ignore, append lines like the -following to config: - - FileRules pathname contains /home/user/Mail/scripts - -You do not want to index the folders that hold the results of your searches -since they tend to be ephemeral and the original messages are indexed anyway. -The configuration file above assumes that the results are found in sub-folders -of `mh-index-folder' which is +mhe-index by default. - -Use the following command line to generate the swish index. Run this -daily from cron: - - swish-e -c /home/user/Mail/.swish/config - -FOLDER-PATH is the directory in which SEARCH-REGEXP is used to search." nil nil) - -(autoload (quote mh-swish++-execute-search) "mh-index" "\ -Execute swish++ and read the results. - -In the examples below, replace /home/user/Mail with the path to your MH -directory. - -First create the directory /home/user/Mail/.swish++. Then create the file -/home/user/Mail/.swish++/swish++.conf with the following contents: - - IncludeMeta Bcc Cc Comments Content-Description From Keywords - IncludeMeta Newsgroups Resent-To Subject To - IncludeMeta Message-Id References In-Reply-To - IncludeFile Mail * - IndexFile /home/user/Mail/.swish++/swish++.index - -Use the following command line to generate the swish index. Run this -daily from cron: - - find /home/user/Mail -path /home/user/Mail/mhe-index -prune \\ - -o -path /home/user/Mail/.swish++ -prune \\ - -o -name \"[0-9]*\" -print \\ - | index -c /home/user/Mail/.swish++/swish++.conf /home/user/Mail - -You do not want to index the folders that hold the results of your searches -since they tend to be ephemeral and the original messages are indexed anyway. -The command above assumes that the results are found in sub-folders of -`mh-index-folder' which is +mhe-index by default. - -On some systems (Debian GNU/Linux, for example), use index++ instead of index. - -FOLDER-PATH is the directory in which SEARCH-REGEXP is used to search." nil nil) - -(autoload (quote mh-namazu-execute-search) "mh-index" "\ -Execute namazu and read the results. - -In the examples below, replace /home/user/Mail with the path to your MH -directory. - -First create the directory /home/user/Mail/.namazu. Then create the file -/home/user/Mail/.namazu/mknmzrc with the following contents: - - package conf; # Don't remove this line! - $ADDRESS = 'user@localhost'; - $ALLOW_FILE = \"[0-9]*\"; - $EXCLUDE_PATH = \"^/home/user/Mail/(mhe-index|spam)\"; - -In the above example configuration, none of the mail files contained in the -directories /home/user/Mail/mhe-index and /home/user/Mail/spam are indexed. - -You do not want to index the folders that hold the results of your searches -since they tend to be ephemeral and the original messages are indexed anyway. -The configuration file above assumes that the results are found in sub-folders -of `mh-index-folder' which is +mhe-index by default. - -Use the following command line to generate the namazu index. Run this -daily from cron: - - mknmz -f /home/user/Mail/.namazu/mknmzrc -O /home/user/Mail/.namazu \\ - /home/user/Mail - -FOLDER-PATH is the directory in which SEARCH-REGEXP is used to search." nil nil) - -;;;*** - -;;;### (autoloads (mh-mime-inline-part mh-mime-save-part mh-push-button -;;;;;; mh-press-button mh-mime-display mh-mime-save-parts mh-display-emphasis -;;;;;; mh-display-smileys mh-add-missing-mime-version-header mh-destroy-postponed-handles -;;;;;; mh-mime-cleanup mh-mml-secure-message-encrypt-pgpmime mh-mml-secure-message-sign-pgpmime -;;;;;; mh-mml-attach-file mh-mml-forward-message mh-mml-to-mime -;;;;;; mh-revert-mhn-edit mh-edit-mhn mh-mhn-compose-forw mh-mhn-compose-external-compressed-tar -;;;;;; mh-mhn-compose-anon-ftp mh-mhn-compose-insertion mh-compose-forward -;;;;;; mh-compose-insertion) "mh-mime" "mh-mime.el" (15858 6046)) -;;; Generated autoloads from mh-mime.el - -(autoload (quote mh-compose-insertion) "mh-mime" "\ -Add a directive to insert a MIME part from a file, using mhn or gnus. -If the variable `mh-compose-insertion' is set to 'mhn, then that will be used. -If it is set to 'gnus, then that will be used instead. -Optional argument INLINE means make it an inline attachment." t nil) - -(autoload (quote mh-compose-forward) "mh-mime" "\ -Add a MIME directive to forward a message, using mhn or gnus. -If the variable `mh-compose-insertion' is set to 'mhn, then that will be used. -If it is set to 'gnus, then that will be used instead. -Optional argument DESCRIPTION is a description of the attachment. -Optional argument FOLDER is the folder from which the forwarded message should -come. -Optional argument MESSAGE is the message to forward. -If any of the optional arguments are absent, they are prompted for." t nil) - -(autoload (quote mh-mhn-compose-insertion) "mh-mime" "\ -Add a directive to insert a MIME message part from a file. -This is the typical way to insert non-text parts in a message. - -Arguments are FILENAME, which tells where to find the file, TYPE, the MIME -content type, DESCRIPTION, a line of text for the Content-Description field. -ATTRIBUTES is a comma separated list of name=value pairs that is appended to -the Content-Type field of the attachment. - -See also \\[mh-edit-mhn]." t nil) - -(autoload (quote mh-mhn-compose-anon-ftp) "mh-mime" "\ -Add a directive for a MIME anonymous ftp external body part. -This directive tells MH to include a reference to a message/external-body part -retrievable by anonymous FTP. - -Arguments are HOST and FILENAME, which tell where to find the file, TYPE, the -MIME content type, and DESCRIPTION, a line of text for the Content-description -header. - -See also \\[mh-edit-mhn]." t nil) - -(autoload (quote mh-mhn-compose-external-compressed-tar) "mh-mime" "\ -Add a directive to include a MIME reference to a compressed tar file. -The file should be available via anonymous ftp. This directive tells MH to -include a reference to a message/external-body part. - -Arguments are HOST and FILENAME, which tell where to find the file, and -DESCRIPTION, a line of text for the Content-description header. - -See also \\[mh-edit-mhn]." t nil) - -(autoload (quote mh-mhn-compose-forw) "mh-mime" "\ -Add a forw directive to this message, to forward a message with MIME. -This directive tells MH to include the named messages in this one. - -Arguments are DESCRIPTION, a line of text for the Content-description header, -and FOLDER and MESSAGES, which name the message(s) to be forwarded. - -See also \\[mh-edit-mhn]." t nil) - -(autoload (quote mh-edit-mhn) "mh-mime" "\ -Format the current draft for MIME, expanding any mhn directives. - -Process the current draft with the mhn program, which, using directives -already inserted in the draft, fills in all the MIME components and header -fields. - -This step should be done last just before sending the message. - -The `\\[mh-revert-mhn-edit]' command undoes this command. The arguments in the -list `mh-mhn-args' are passed to mhn if this function is passed an optional -prefix argument EXTRA-ARGS. - -For assistance with creating mhn directives to insert various types of -components in a message, see \\[mh-mhn-compose-insertion] (generic insertion -from a file), \\[mh-mhn-compose-anon-ftp] (external reference to file via -anonymous ftp), \\[mh-mhn-compose-external-compressed-tar] (reference to -compressed tar file via anonymous ftp), and \\[mh-mhn-compose-forw] (forward -message). If these helper functions are used, `mh-edit-mhn' is run -automatically when the draft is sent. - -The value of `mh-edit-mhn-hook' is a list of functions to be called, with no -arguments, after performing the conversion. - -The mhn program is part of MH version 6.8 or later." t nil) - -(autoload (quote mh-revert-mhn-edit) "mh-mime" "\ -Undo the effect of \\[mh-edit-mhn] by reverting to the backup file. -Optional non-nil argument NOCONFIRM means don't ask for confirmation." t nil) - -(autoload (quote mh-mml-to-mime) "mh-mime" "\ -Compose MIME message from mml directives." t nil) - -(autoload (quote mh-mml-forward-message) "mh-mime" "\ -Forward a message as attachment. -The function will prompt the user for a DESCRIPTION, a FOLDER and MESSAGE -number." nil nil) - -(autoload (quote mh-mml-attach-file) "mh-mime" "\ -Attach a file to the outgoing MIME message. -The file is not inserted or encoded until you send the message with -`\\[mh-send-letter]'. -Message disposition is \"inline\" or \"attachment\" and is prompted for if -DISPOSITION is nil. - -This is basically `mml-attach-file' from gnus, modified such that a prefix -argument yields an `inline' disposition and Content-Type is determined -automatically." nil nil) - -(autoload (quote mh-mml-secure-message-sign-pgpmime) "mh-mime" "\ -Add directive to encrypt/sign the entire message." t nil) - -(autoload (quote mh-mml-secure-message-encrypt-pgpmime) "mh-mime" "\ -Add directive to encrypt and sign the entire message. -If called with a prefix argument DONTSIGN, only encrypt (do NOT sign)." t nil) - -(autoload (quote mh-mime-cleanup) "mh-mime" "\ -Free the decoded MIME parts." nil nil) - -(autoload (quote mh-destroy-postponed-handles) "mh-mime" "\ -Free MIME data for externally displayed mime parts." nil nil) - -(autoload (quote mh-add-missing-mime-version-header) "mh-mime" "\ -Some mail programs don't put a MIME-Version header. -I have seen this only in spam, so maybe we shouldn't fix this ;-)" nil nil) - -(autoload (quote mh-display-smileys) "mh-mime" "\ -Function to display smileys." nil nil) - -(autoload (quote mh-display-emphasis) "mh-mime" "\ -Function to display graphical emphasis." nil nil) - -(autoload (quote mh-mime-save-parts) "mh-mime" "\ -Store the MIME parts of the current message. -If ARG, prompt for directory, else use that specified by the variable -`mh-mime-save-parts-default-directory'. These directories may be superseded by -mh_profile directives, since this function calls on mhstore or mhn to do the -actual storing." t nil) - -(autoload (quote mh-mime-display) "mh-mime" "\ -Display (and possibly decode) MIME handles. -Optional argument, PRE-DISSECTED-HANDLES is a list of MIME handles. If -present they are displayed otherwise the buffer is parsed and then -displayed." nil nil) - -(autoload (quote mh-press-button) "mh-mime" "\ -Press MIME button. -If the MIME part is visible then it is removed. Otherwise the part is -displayed." t nil) - -(autoload (quote mh-push-button) "mh-mime" "\ -Click MIME button for EVENT. -If the MIME part is visible then it is removed. Otherwise the part is -displayed. This function is called when the mouse is used to click the MIME -button." t nil) - -(autoload (quote mh-mime-save-part) "mh-mime" "\ -Save MIME part at point." t nil) - -(autoload (quote mh-mime-inline-part) "mh-mime" "\ -Toggle display of the raw MIME part." t nil) - -;;;*** - -;;;### (autoloads (mh-do-pick-search mh-search-folder) "mh-pick" -;;;;;; "mh-pick.el" (15854 20166)) -;;; Generated autoloads from mh-pick.el - -(autoload (quote mh-search-folder) "mh-pick" "\ -Search FOLDER for messages matching a pattern. -This function uses the MH command `pick' to do the work. -Add the messages found to the sequence named `search'." t nil) - -(autoload (quote mh-do-pick-search) "mh-pick" "\ -Find messages that match the qualifications in the current pattern buffer. -Messages are searched for in the folder named in `mh-searching-folder'. -Add the messages found to the sequence named `search'." t nil) - -;;;*** - -;;;### (autoloads (mh-thread-refile mh-thread-delete mh-thread-ancestor -;;;;;; mh-thread-previous-sibling mh-thread-next-sibling mh-thread-forget-message -;;;;;; mh-toggle-threads mh-thread-add-spaces mh-thread-inc mh-delete-subject-or-thread -;;;;;; mh-delete-subject mh-narrow-to-subject mh-region-to-msg-list -;;;;;; mh-add-to-sequence mh-notate-seq mh-map-to-seq-msgs mh-rename-seq -;;;;;; mh-widen mh-put-msg-in-seq mh-narrow-to-seq mh-msg-is-in-seq -;;;;;; mh-list-sequences mh-delete-seq) "mh-seq" "mh-seq.el" (15899 -;;;;;; 19358)) -;;; Generated autoloads from mh-seq.el - -(autoload (quote mh-delete-seq) "mh-seq" "\ -Delete the SEQUENCE." t nil) - -(autoload (quote mh-list-sequences) "mh-seq" "\ -List the sequences defined in the folder being visited." t nil) - -(autoload (quote mh-msg-is-in-seq) "mh-seq" "\ -Display the sequences that contain MESSAGE (default: current message)." t nil) - -(autoload (quote mh-narrow-to-seq) "mh-seq" "\ -Restrict display of this folder to just messages in SEQUENCE. -Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command." t nil) - -(autoload (quote mh-put-msg-in-seq) "mh-seq" "\ -Add MSG-OR-SEQ (default: displayed message) to SEQUENCE. -If optional prefix argument provided, then prompt for the message sequence. -If variable `transient-mark-mode' is non-nil and the mark is active, then -the selected region is added to the sequence." t nil) - -(autoload (quote mh-widen) "mh-seq" "\ -Remove restrictions from current folder, thereby showing all messages." t nil) - -(autoload (quote mh-rename-seq) "mh-seq" "\ -Rename SEQUENCE to have NEW-NAME." t nil) - -(autoload (quote mh-map-to-seq-msgs) "mh-seq" "\ -Invoke the FUNC at each message in the SEQ. -SEQ can either be a list of messages or a MH sequence. The remaining ARGS are -passed as arguments to FUNC." nil nil) - -(autoload (quote mh-notate-seq) "mh-seq" "\ -Mark the scan listing. -All messages in SEQ are marked with NOTATION at OFFSET from the beginning of -the line." nil nil) - -(autoload (quote mh-add-to-sequence) "mh-seq" "\ -The sequence SEQ is augmented with the messages in MSGS." nil nil) - -(autoload (quote mh-region-to-msg-list) "mh-seq" "\ -Return a list of messages within the region between BEGIN and END." nil nil) - -(autoload (quote mh-narrow-to-subject) "mh-seq" "\ -Narrow to a sequence containing all following messages with same subject." t nil) - -(autoload (quote mh-delete-subject) "mh-seq" "\ -Mark all following messages with same subject to be deleted. -This puts the messages in a sequence named subject. You can undo the last -deletion marks using `mh-undo' with a prefix argument and then specifying the -subject sequence." t nil) - -(autoload (quote mh-delete-subject-or-thread) "mh-seq" "\ -Mark messages for deletion intelligently. -If the folder is threaded then `mh-thread-delete' is used to mark the current -message and all its descendants for deletion. Otherwise `mh-delete-subject' is -used to mark the current message and all messages following it with the same -subject for deletion." t nil) - -(autoload (quote mh-thread-inc) "mh-seq" "\ -Update thread tree for FOLDER. -All messages after START-POINT are added to the thread tree." nil nil) - -(autoload (quote mh-thread-add-spaces) "mh-seq" "\ -Add COUNT spaces to each scan line in `mh-thread-scan-line-map'." nil nil) - -(autoload (quote mh-toggle-threads) "mh-seq" "\ -Toggle threaded view of folder. -The conversion of normal view to threaded view is exact, that is the same -messages are displayed in the folder buffer before and after threading. However -the conversion from threaded view to normal view is inexact. So more messages -than were originally present may be shown as a result." t nil) - -(autoload (quote mh-thread-forget-message) "mh-seq" "\ -Forget the message INDEX from the threading tables." nil nil) - -(autoload (quote mh-thread-next-sibling) "mh-seq" "\ -Jump to next sibling. -With non-nil optional argument PREVIOUS-FLAG jump to the previous sibling." t nil) - -(autoload (quote mh-thread-previous-sibling) "mh-seq" "\ -Jump to previous sibling." t nil) - -(autoload (quote mh-thread-ancestor) "mh-seq" "\ -Jump to the ancestor of current message. -If optional argument THREAD-ROOT-FLAG is non-nil then jump to the root of the -thread tree the message belongs to." t nil) - -(autoload (quote mh-thread-delete) "mh-seq" "\ -Mark current message and all its children for subsequent deletion." t nil) - -(autoload (quote mh-thread-refile) "mh-seq" "\ -Mark current message and all its children for refiling to FOLDER." t nil) - -;;;*** - -;;;### (autoloads (mh-speed-add-folder mh-speed-invalidate-map mh-speed-flists -;;;;;; mh-speed-view mh-speed-toggle mh-folder-speedbar-buttons) -;;;;;; "mh-speed" "mh-speed.el" (15899 19358)) -;;; Generated autoloads from mh-speed.el - -(autoload (quote mh-folder-speedbar-buttons) "mh-speed" "\ -Interface function to create MH-E speedbar buffer. -BUFFER is the MH-E buffer for which the speedbar buffer is to be created." nil nil) - -(defalias (quote mh-show-speedbar-buttons) (quote mh-folder-speedbar-buttons)) - -(defalias (quote mh-letter-speedbar-buttons) (quote mh-folder-speedbar-buttons)) - -(autoload (quote mh-speed-toggle) "mh-speed" "\ -Toggle the display of child folders. -The otional ARGS are ignored and there for compatibilty with speedbar." t nil) - -(autoload (quote mh-speed-view) "mh-speed" "\ -View folder on current line. -Optional ARGS are ignored." t nil) - -(autoload (quote mh-speed-flists) "mh-speed" "\ -Execute flists -recurse and update message counts. -If FORCE is non-nil the timer is reset." t nil) - -(autoload (quote mh-speed-invalidate-map) "mh-speed" "\ -Remove FOLDER from various optimization caches." t nil) - -(autoload (quote mh-speed-add-folder) "mh-speed" "\ -Add FOLDER since it is being created. -The function invalidates the latest ancestor that is present." nil nil) - -;;;*** - -;;;### (autoloads (mh-get-msg-num mh-goto-address-find-address-at-point) -;;;;;; "mh-utils" "mh-utils.el" (15899 28827)) -;;; Generated autoloads from mh-utils.el - -(autoload (quote mh-goto-address-find-address-at-point) "mh-utils" "\ -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." nil nil) - -(autoload (quote mh-get-msg-num) "mh-utils" "\ -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." nil nil) - -;;;*** - -;;;### (autoloads (mh-alias-add-address-under-point mh-alias-grab-from-field -;;;;;; mh-alias-add-alias mh-alias-from-has-no-alias-p mh-alias-letter-expand-alias -;;;;;; mh-alias-minibuffer-confirm-address mh-read-address mh-alias-reload) -;;;;;; "mh-alias" "mh-alias.el" (15899 29102)) -;;; Generated autoloads from mh-alias.el - -(autoload (quote mh-alias-reload) "mh-alias" "\ -Load MH aliases into `mh-alias-alist'." t nil) - -(autoload (quote mh-read-address) "mh-alias" "\ -Read an address from the minibuffer with PROMPT." nil nil) - -(autoload (quote mh-alias-minibuffer-confirm-address) "mh-alias" "\ -Display the alias expansion if `mh-alias-flash-on-comma' is non-nil." t nil) - -(autoload (quote mh-alias-letter-expand-alias) "mh-alias" "\ -Expand mail alias before point." nil nil) - -(autoload (quote mh-alias-from-has-no-alias-p) "mh-alias" "\ -Return t is From has no current alias set." nil nil) - -(autoload (quote mh-alias-add-alias) "mh-alias" "\ -*Add ALIAS for ADDRESS in personal alias file. -Prompts for confirmation if the address already has an alias. -If the alias is already is use, `mh-alias-add-alias-to-file' will prompt." t nil) - -(autoload (quote mh-alias-grab-from-field) "mh-alias" "\ -*Add ALIAS for ADDRESS in personal alias file. -Prompts for confirmation if the alias is already in use or if the address -already has an alias." t nil) - -(autoload (quote mh-alias-add-address-under-point) "mh-alias" "\ -Insert an alias for email address under point." t nil) - -;;;*** - -(provide 'mh-loaddefs) -;;; Local Variables: -;;; version-control: never -;;; no-byte-compile: t -;;; no-update-autoloads: t -;;; End: -;;; mh-loaddefs.el ends here
--- a/lisp/mail/mh-mime.el Sun Jan 26 01:33:33 2003 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1276 +0,0 @@ -;;; mh-mime.el --- MH-E support for composing MIME messages - -;; Copyright (C) 1993, 1995, 2001, 2002 Free Software Foundation, Inc. - -;; Author: Bill Wohler <wohler@newt.com> -;; Maintainer: Bill Wohler <wohler@newt.com> -;; Keywords: mail -;; See: mh-e.el - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Internal support for MH-E package. -;; Support for generating an mhn composition file. -;; MIME is supported only by MH 6.8 or later. - -;;; Change Log: - -;; $Id: mh-mime.el,v 1.98 2002/12/06 03:33:47 satyaki Exp $ - -;;; Code: - -(require 'cl) -(require 'mh-comp) -(require 'mh-utils) -(load "mm-decode" t t) ; Non-fatal dependency -(load "mm-uu" t t) ; Non-fatal dependency -(load "mailcap" t t) ; Non-fatal dependency -(load "smiley" t t) ; Non-fatal dependency -(require 'gnus-util) - -(autoload 'gnus-article-goto-header "gnus-art") -(autoload 'article-emphasize "gnus-art") -(autoload 'gnus-get-buffer-create "gnus") -(autoload 'gnus-eval-format "gnus-spec") -(autoload 'widget-convert-button "wid-edit") -(autoload 'message-options-set-recipient "message") -(autoload 'mml-secure-message-sign-pgpmime "mml-sec") -(autoload 'mml-secure-message-encrypt-pgpmime "mml-sec") -(autoload 'mml-minibuffer-read-file "mml") -(autoload 'mml-minibuffer-read-description "mml") -(autoload 'mml-insert-empty-tag "mml") -(autoload 'mml-to-mime "mml") -(autoload 'mml-attach-file "mml") - -;;;###mh-autoload -(defun mh-compose-insertion (&optional inline) - "Add a directive to insert a MIME part from a file, using mhn or gnus. -If the variable `mh-compose-insertion' is set to 'mhn, then that will be used. -If it is set to 'gnus, then that will be used instead. -Optional argument INLINE means make it an inline attachment." - (interactive "P") - (if (equal mh-compose-insertion 'gnus) - (if inline - (mh-mml-attach-file "inline") - (mh-mml-attach-file)) - (call-interactively 'mh-mhn-compose-insertion))) - -;;;###mh-autoload -(defun mh-compose-forward (&optional description folder message) - "Add a MIME directive to forward a message, using mhn or gnus. -If the variable `mh-compose-insertion' is set to 'mhn, then that will be used. -If it is set to 'gnus, then that will be used instead. -Optional argument DESCRIPTION is a description of the attachment. -Optional argument FOLDER is the folder from which the forwarded message should -come. -Optional argument MESSAGE is the message to forward. -If any of the optional arguments are absent, they are prompted for." - (interactive (list - (read-string "Forw Content-description: ") - (mh-prompt-for-folder "Message from" mh-sent-from-folder nil) - (read-string (format "Messages%s: " - (if mh-sent-from-msg - (format " [%d]" mh-sent-from-msg) - ""))))) - (if (equal mh-compose-insertion 'gnus) - (mh-mml-forward-message description folder message) - (mh-mhn-compose-forw description folder message))) - -;; To do: -;; paragraph code should not fill # lines if MIME enabled. -;; implement mh-auto-edit-mhn (if non-nil, \\[mh-send-letter] -;; invokes mh-edit-mhn automatically before sending.) -;; actually, instead of mh-auto-edit-mhn, -;; should read automhnproc from profile -;; MIME option to mh-forward -;; command to move to content-description insertion point - -(defvar mh-mhn-args nil - "Extra arguments to have \\[mh-edit-mhn] pass to the \"mhn\" command. -The arguments are passed to mhn if \\[mh-edit-mhn] is given a -prefix argument. Normally default arguments to mhn are specified in the -MH profile.") - -(defvar mh-media-type-regexp - (concat (regexp-opt '("text" "image" "audio" "video" "application" - "multipart" "message") t) - "/[-.+a-zA-Z0-9]+") - "Regexp matching valid media types used in MIME attachment compositions.") - -;; Just defvar the variable to avoid compiler warning... This doesn't bind -;; the variable, so things should work exactly as before. -(defvar mh-have-file-command) - -(defun mh-have-file-command () - "Return t if 'file' command is on the system. -'file -i' is used to get MIME type of composition insertion." - (when (not (boundp 'mh-have-file-command)) - (load "executable" t t) ; executable-find not autoloaded in emacs20 - (setq mh-have-file-command - (and (fboundp 'executable-find) - (executable-find "file") ; file command exists - ; and accepts -i and -b args. - (zerop (call-process "file" nil nil nil "-i" "-b" - (expand-file-name "inc" mh-progs)))))) - mh-have-file-command) - -(defvar mh-file-mime-type-substitutions - '(("application/msword" "\.xls" "application/ms-excel") - ("application/msword" "\.ppt" "application/ms-powerpoint")) - "Substitutions to make for Content-Type returned from file command. -The first element is the Content-Type returned by the file command. -The second element is a regexp matching the file name, usually the extension. -The third element is the Content-Type to replace with.") - -(defun mh-file-mime-type-substitute (content-type filename) - "Return possibly changed CONTENT-TYPE on the FILENAME. -Substitutions are made from the `mh-file-mime-type-substitutions' variable." - (let ((subst mh-file-mime-type-substitutions) - (type) (match) (answer content-type) - (case-fold-search t)) - (while subst - (setq type (car (car subst)) - match (elt (car subst) 1)) - (if (and (string-equal content-type type) - (string-match match filename)) - (setq answer (elt (car subst) 2) - subst nil) - (setq subst (cdr subst)))) - answer)) - -(defun mh-file-mime-type (filename) - "Return MIME type of FILENAME from file command. -Returns nil if file command not on system." - (cond - ((not (mh-have-file-command)) - nil) ;No file command, exit now. - ((not (and (file-exists-p filename)(file-readable-p filename))) - nil) - (t - (save-excursion - (let ((tmp-buffer (get-buffer-create mh-temp-buffer))) - (set-buffer tmp-buffer) - (unwind-protect - (progn - (call-process "file" nil '(t nil) nil "-b" "-i" - (expand-file-name filename)) - (goto-char (point-min)) - (if (not (re-search-forward mh-media-type-regexp nil t)) - nil - (mh-file-mime-type-substitute (match-string 0) filename))) - (kill-buffer tmp-buffer))))))) - -;;; This is needed for Emacs20 which doesn't have mailcap-mime-types. -(defvar mh-mime-content-types - '(("application/mac-binhex40") ("application/msword") - ("application/octet-stream") ("application/pdf") ("application/pgp-keys") - ("application/pgp-signature") ("application/pkcs7-signature") - ("application/postscript") ("application/rtf") - ("application/vnd.ms-excel") ("application/vnd.ms-powerpoint") - ("application/vnd.ms-project") ("application/vnd.ms-tnef") - ("application/wordperfect5.1") ("application/wordperfect6.0") - ("application/zip") - - ("audio/basic") ("audio/mpeg") - - ("image/gif") ("image/jpeg") ("image/png") - - ("message/delivery-status") - ("message/external-body") ("message/partial") ("message/rfc822") - - ("text/enriched") ("text/html") ("text/plain") ("text/rfc822-headers") - ("text/richtext") ("text/xml") - - ("video/mpeg") ("video/quicktime")) - "Legal MIME content types. -See documentation for \\[mh-edit-mhn].") - -;;;###mh-autoload -(defun mh-mhn-compose-insertion (filename type description attributes) - "Add a directive to insert a MIME message part from a file. -This is the typical way to insert non-text parts in a message. - -Arguments are FILENAME, which tells where to find the file, TYPE, the MIME -content type, DESCRIPTION, a line of text for the Content-Description field. -ATTRIBUTES is a comma separated list of name=value pairs that is appended to -the Content-Type field of the attachment. - -See also \\[mh-edit-mhn]." - (interactive (let ((filename (read-file-name "Insert contents of: "))) - (list - filename - (or (mh-file-mime-type filename) - (completing-read "Content-Type: " - (if (fboundp 'mailcap-mime-types) - (mapcar 'list (mailcap-mime-types)) - mh-mime-content-types))) - (read-string "Content-Description: ") - (read-string "Content-Attributes: " - (concat "name=\"" - (file-name-nondirectory filename) - "\""))))) - (mh-mhn-compose-type filename type description attributes )) - -(defun mh-mhn-compose-type (filename type - &optional description attributes comment) - "Insert a mhn directive to insert a file. - -The file specified by FILENAME is encoded as TYPE. An optional DESCRIPTION is -used as the Content-Description field, optional set of ATTRIBUTES and an -optional COMMENT can also be included." - (setq mh-mhn-compose-insert-flag t) - (beginning-of-line) - (insert "#" type) - (and attributes - (insert "; " attributes)) - (and comment - (insert " (" comment ")")) - (insert " [") - (and description - (insert description)) - (insert "] " (expand-file-name filename)) - (insert "\n")) - - -;;;###mh-autoload -(defun mh-mhn-compose-anon-ftp (host filename type description) - "Add a directive for a MIME anonymous ftp external body part. -This directive tells MH to include a reference to a message/external-body part -retrievable by anonymous FTP. - -Arguments are HOST and FILENAME, which tell where to find the file, TYPE, the -MIME content type, and DESCRIPTION, a line of text for the Content-description -header. - -See also \\[mh-edit-mhn]." - (interactive (list - (read-string "Remote host: ") - (read-string "Remote filename: ") - (completing-read "External Content-Type: " - (if (fboundp 'mailcap-mime-types) - (mapcar 'list (mailcap-mime-types)) - mh-mime-content-types)) - (read-string "External Content-Description: "))) - (mh-mhn-compose-external-type "anon-ftp" host filename - type description)) - -;;;###mh-autoload -(defun mh-mhn-compose-external-compressed-tar (host filename description) - "Add a directive to include a MIME reference to a compressed tar file. -The file should be available via anonymous ftp. This directive tells MH to -include a reference to a message/external-body part. - -Arguments are HOST and FILENAME, which tell where to find the file, and -DESCRIPTION, a line of text for the Content-description header. - -See also \\[mh-edit-mhn]." - (interactive (list - (read-string "Remote host: ") - (read-string "Remote filename: ") - (read-string "Tar file Content-description: "))) - (mh-mhn-compose-external-type "anon-ftp" host filename - "application/octet-stream" - description - "type=tar; conversions=x-compress" - "mode=image")) - - -(defun mh-mhn-compose-external-type (access-type host filename type - &optional description - attributes extra-params - comment) - "Add a directive to include a MIME reference to a remote file. -The file should be available via anonymous ftp. This directive tells MH to -include a reference to a message/external-body part. - -Arguments are ACCESS-TYPE, HOST and FILENAME, which tell where to find the -file and TYPE which is the MIME Content-Type. Optional arguments include -DESCRIPTION, a line of text for the Content-description header, ATTRIBUTES, -EXTRA-PARAMS, and COMMENT. - -See also \\[mh-edit-mhn]." - (setq mh-mhn-compose-insert-flag t) - (beginning-of-line) - (insert "#@" type) - (and attributes - (insert "; " attributes)) - (and comment - (insert " (" comment ") ")) - (insert " [") - (and description - (insert description)) - (insert "] ") - (insert "access-type=" access-type "; ") - (insert "site=" host) - (insert "; name=" (file-name-nondirectory filename)) - (insert "; directory=\"" (file-name-directory filename) "\"") - (and extra-params - (insert "; " extra-params)) - (insert "\n")) - -;;;###mh-autoload -(defun mh-mhn-compose-forw (&optional description folder messages) - "Add a forw directive to this message, to forward a message with MIME. -This directive tells MH to include the named messages in this one. - -Arguments are DESCRIPTION, a line of text for the Content-description header, -and FOLDER and MESSAGES, which name the message(s) to be forwarded. - -See also \\[mh-edit-mhn]." - (interactive (list - (read-string "Forw Content-description: ") - (mh-prompt-for-folder "Message from" mh-sent-from-folder nil) - (read-string (format "Messages%s: " - (if mh-sent-from-msg - (format " [%d]" mh-sent-from-msg) - ""))))) - (setq mh-mhn-compose-insert-flag t) - (beginning-of-line) - (insert "#forw [") - (and description - (not (string= description "")) - (insert description)) - (insert "]") - (and folder - (not (string= folder "")) - (insert " " folder)) - (if (and messages - (not (string= messages ""))) - (let ((start (point))) - (insert " " messages) - (subst-char-in-region start (point) ?, ? )) - (if mh-sent-from-msg - (insert " " (int-to-string mh-sent-from-msg)))) - (insert "\n")) - -;;;###mh-autoload -(defun mh-edit-mhn (&optional extra-args) - "Format the current draft for MIME, expanding any mhn directives. - -Process the current draft with the mhn program, which, using directives -already inserted in the draft, fills in all the MIME components and header -fields. - -This step should be done last just before sending the message. - -The `\\[mh-revert-mhn-edit]' command undoes this command. The arguments in the -list `mh-mhn-args' are passed to mhn if this function is passed an optional -prefix argument EXTRA-ARGS. - -For assistance with creating mhn directives to insert various types of -components in a message, see \\[mh-mhn-compose-insertion] (generic insertion -from a file), \\[mh-mhn-compose-anon-ftp] (external reference to file via -anonymous ftp), \\[mh-mhn-compose-external-compressed-tar] \ \(reference to -compressed tar file via anonymous ftp), and \\[mh-mhn-compose-forw] (forward -message). If these helper functions are used, `mh-edit-mhn' is run -automatically when the draft is sent. - -The value of `mh-edit-mhn-hook' is a list of functions to be called, with no -arguments, after performing the conversion. - -The mhn program is part of MH version 6.8 or later." - (interactive "*P") - (save-buffer) - (message "mhn editing...") - (cond - (mh-nmh-flag - (mh-exec-cmd-error nil - "mhbuild" (if extra-args mh-mhn-args) buffer-file-name)) - (t - (mh-exec-cmd-error (format "mhdraft=%s" buffer-file-name) - "mhn" (if extra-args mh-mhn-args) buffer-file-name))) - (setq mh-mhn-compose-insert-flag nil) - (revert-buffer t t) - (message "mhn editing...done") - (run-hooks 'mh-edit-mhn-hook)) - -;;;###mh-autoload -(defun mh-revert-mhn-edit (noconfirm) - "Undo the effect of \\[mh-edit-mhn] by reverting to the backup file. -Optional non-nil argument NOCONFIRM means don't ask for confirmation." - (interactive "*P") - (if (null buffer-file-name) - (error "Buffer does not seem to be associated with any file")) - (let ((backup-strings '("," "#")) - backup-file) - (while (and backup-strings - (not (file-exists-p - (setq backup-file - (concat (file-name-directory buffer-file-name) - (car backup-strings) - (file-name-nondirectory buffer-file-name) - ".orig"))))) - (setq backup-strings (cdr backup-strings))) - (or backup-strings - (error "Backup file for %s no longer exists!" buffer-file-name)) - (or noconfirm - (yes-or-no-p (format "Revert buffer from file %s? " - backup-file)) - (error "Revert not confirmed")) - (let ((buffer-read-only nil)) - (erase-buffer) - (insert-file-contents backup-file)) - (after-find-file nil))) - - - -;;; MIME composition functions - -;;;###mh-autoload -(defun mh-mml-to-mime () - "Compose MIME message from mml directives." - (interactive) - (when mh-gnus-pgp-support-flag ;; This is only needed for PGP - (message-options-set-recipient)) - (mml-to-mime) - (setq mh-mml-compose-insert-flag nil)) - -;;;###mh-autoload -(defun mh-mml-forward-message (description folder message) - "Forward a message as attachment. -The function will prompt the user for a DESCRIPTION, a FOLDER and MESSAGE -number." - (let ((msg (if (equal message "") - mh-sent-from-msg - (car (read-from-string message))))) - (cond ((integerp msg) - (if (string= "" description) - ;; Rationale: mml-attach-file constructs a malformed composition - ;; if the description string is empty. This fixes SF #625168. - (mml-attach-file (format "%s%s/%d" - mh-user-path (substring folder 1) msg) - "message/rfc822") - (mml-attach-file (format "%s%s/%d" - mh-user-path (substring folder 1) msg) - "message/rfc822" - description)) - (setq mh-mml-compose-insert-flag t)) - (t (error "The message number, %s is not a integer!" msg))))) - -;;;###mh-autoload -(defun mh-mml-attach-file (&optional disposition) - "Attach a file to the outgoing MIME message. -The file is not inserted or encoded until you send the message with -`\\[mh-send-letter]'. -Message disposition is \"inline\" or \"attachment\" and is prompted for if -DISPOSITION is nil. - -This is basically `mml-attach-file' from gnus, modified such that a prefix -argument yields an `inline' disposition and Content-Type is determined -automatically." - (let* ((file (mml-minibuffer-read-file "Attach file: ")) - (type (or (mh-file-mime-type file) - (completing-read "Content-Type: " - (if (fboundp 'mailcap-mime-types) - (mapcar 'list (mailcap-mime-types)) - mh-mime-content-types)))) - (description (mml-minibuffer-read-description)) - (dispos (or disposition - (completing-read "Disposition: [attachment] " - '(("attachment")("inline")) - nil t nil nil - "attachment")))) - (mml-insert-empty-tag 'part 'type type 'filename file - 'disposition dispos 'description description) - (setq mh-mml-compose-insert-flag t))) - -;;;###mh-autoload -(defun mh-mml-secure-message-sign-pgpmime () - "Add directive to encrypt/sign the entire message." - (interactive) - (if (not mh-gnus-pgp-support-flag) - (error "Sorry. Your version of gnus does not support PGP/GPG") - (mml-secure-message-sign-pgpmime) - (setq mh-mml-compose-insert-flag t))) - -;;;###mh-autoload -(defun mh-mml-secure-message-encrypt-pgpmime (&optional dontsign) - "Add directive to encrypt and sign the entire message. -If called with a prefix argument DONTSIGN, only encrypt (do NOT sign)." - (interactive "P") - (if (not mh-gnus-pgp-support-flag) - (error "Sorry. Your version of gnus does not support PGP/GPG") - (mml-secure-message-encrypt-pgpmime dontsign) - (setq mh-mml-compose-insert-flag t))) - - - -;;; MIME decoding - -(defmacro mh-defun-compat (function arg-list &rest body) - "This is a macro to define functions which are not defined. -It is used for Gnus utility functions which were added recently. If FUNCTION -is not defined then it is defined to have argument list, ARG-LIST and body, -BODY." - (let ((defined-p (fboundp function))) - (unless defined-p - `(defun ,function ,arg-list ,@body)))) -(put 'mh-defun-compat 'lisp-indent-function 'defun) - -;; Copy of original function from gnus-util.el -(mh-defun-compat gnus-local-map-property (map) - "Return a list suitable for a text property list specifying keymap MAP." - (cond (mh-xemacs-flag (list 'keymap map)) - ((>= emacs-major-version 21) (list 'keymap map)) - (t (list 'local-map map)))) - -;; Copy of original function from mm-decode.el -(mh-defun-compat mm-merge-handles (handles1 handles2) - (append (if (listp (car handles1)) handles1 (list handles1)) - (if (listp (car handles2)) handles2 (list handles2)))) - -;; Copy of function from mm-decode.el -(mh-defun-compat mm-set-handle-multipart-parameter (handle parameter value) - ;; HANDLE could be a CTL. - (if handle - (put-text-property 0 (length (car handle)) parameter value - (car handle)))) - -;; Copy of original macro is in mm-decode.el -(mh-defun-compat mm-handle-multipart-ctl-parameter (handle parameter) - (get-text-property 0 parameter (car handle))) - -;; Copy of original function in mm-decode.el -(mh-defun-compat mm-readable-p (handle) - "Say whether the content of HANDLE is readable." - (and (< (with-current-buffer (mm-handle-buffer handle) - (buffer-size)) 10000) - (mm-with-unibyte-buffer - (mm-insert-part handle) - (and (eq (mm-body-7-or-8) '7bit) - (not (mm-long-lines-p 76)))))) - -;; Copy of original function in mm-bodies.el -(mh-defun-compat mm-long-lines-p (length) - "Say whether any of the lines in the buffer is longer than LINES." - (save-excursion - (goto-char (point-min)) - (end-of-line) - (while (and (not (eobp)) - (not (> (current-column) length))) - (forward-line 1) - (end-of-line)) - (and (> (current-column) length) - (current-column)))) - -(mh-defun-compat mm-keep-viewer-alive-p (handle) - ;; Released Gnus doesn't keep handles associated with externally displayed - ;; MIME parts. So this will always return nil. - nil) - -(mh-defun-compat mm-destroy-parts (list) - "Older emacs don't have this function." - nil) - -;;; This is mm-save-part from gnus 5.10 since that function in emacs21.2 is -;;; buggy (the args to read-file-name are incorrect). When all supported -;;; versions of Emacs come with at least Gnus 5.10, we can delete this -;;; function and rename calls to mh-mm-save-part to mm-save-part. -(defun mh-mm-save-part (handle) - "Write HANDLE to a file." - (let ((name (mail-content-type-get (mm-handle-type handle) 'name)) - (filename (mail-content-type-get - (mm-handle-disposition handle) 'filename)) - file) - (when filename - (setq filename (file-name-nondirectory filename))) - (setq file (read-file-name "Save MIME part to: " - (or mm-default-directory - default-directory) - nil nil (or filename name ""))) - (setq mm-default-directory (file-name-directory file)) - (and (or (not (file-exists-p file)) - (yes-or-no-p (format "File %s already exists; overwrite? " - file))) - (mm-save-part-to-file handle file)))) - - - -;;; MIME cleanup - -;;;###mh-autoload -(defun mh-mime-cleanup () - "Free the decoded MIME parts." - (let ((mime-data (gethash (current-buffer) mh-globals-hash))) - ;; This is for Emacs, what about XEmacs? - (cond ((fboundp 'remove-images) - (remove-images (point-min) (point-max)))) - (when mime-data - (mm-destroy-parts (mh-mime-handles mime-data)) - (remhash (current-buffer) mh-globals-hash)))) - -;;;###mh-autoload -(defun mh-destroy-postponed-handles () - "Free MIME data for externally displayed mime parts." - (let ((mime-data (mh-buffer-data))) - (when mime-data - (mm-destroy-parts (mh-mime-handles mime-data))) - (remhash (current-buffer) mh-globals-hash))) - -(defun mh-handle-set-external-undisplayer (folder handle function) - "Replacement for `mm-handle-set-external-undisplayer'. -This is only called in recent versions of Gnus. The MIME handles are stored -in data structures corresponding to MH-E folder buffer FOLDER instead of in -Gnus (as in the original). The MIME part, HANDLE is associated with the -undisplayer FUNCTION." - (if (mm-keep-viewer-alive-p handle) - (let ((new-handle (copy-sequence handle))) - (mm-handle-set-undisplayer new-handle function) - (mm-handle-set-undisplayer handle nil) - (save-excursion - (set-buffer folder) - (push new-handle (mh-mime-handles (mh-buffer-data))))) - (mm-handle-set-undisplayer handle function))) - - - -;;; MIME transformations -(eval-when-compile (require 'font-lock)) - -;;;###mh-autoload -(defun mh-add-missing-mime-version-header () - "Some mail programs don't put a MIME-Version header. -I have seen this only in spam, so maybe we shouldn't fix this ;-)" - (save-excursion - (goto-char (point-min)) - (when (and (message-fetch-field "content-type") - (not (message-fetch-field "mime-version"))) - (when (search-forward "\n\n" nil t) - (forward-line -1) - (insert "MIME-Version: 1.0\n"))))) - -;;;###mh-autoload -(defun mh-display-smileys () - "Function to display smileys." - (when (and mh-graphical-smileys-flag - (fboundp 'smiley-region) - (boundp 'font-lock-maximum-size) - (>= (/ font-lock-maximum-size 8) (buffer-size))) - (smiley-region (point-min) (point-max)))) - -;;;###mh-autoload -(defun mh-display-emphasis () - "Function to display graphical emphasis." - (when (and mh-graphical-emphasis-flag - (boundp 'font-lock-maximum-size) - (>= (/ font-lock-maximum-size 8) (buffer-size))) - (flet ((article-goto-body ())) ; shadow this function to do nothing - (save-excursion - (goto-char (point-min)) - (article-emphasize))))) - -;; Copied from gnus-art.el (should be checked for other cool things that can -;; be added to the buttons) -(defvar mh-mime-button-commands - '((mh-press-button "\r" "Toggle Display"))) -(defvar mh-mime-button-map - (let ((map (make-sparse-keymap))) - (unless (>= (string-to-number emacs-version) 21) - ;; XEmacs doesn't care. - (set-keymap-parent map mh-show-mode-map)) - (define-key map [mouse-2] 'mh-push-button) - (dolist (c mh-mime-button-commands) - (define-key map (cadr c) (car c))) - map)) -(defvar mh-mime-button-line-format-alist - '((?T long-type ?s) - (?d description ?s) - (?p index ?s) - (?e dots ?s))) -(defvar mh-mime-button-line-format "%{%([%p. %d%T]%)%}%e\n") -(defvar mh-mime-security-button-pressed nil) -(defvar mh-mime-security-button-line-format "%{%([[%t:%i]%D]%)%}\n") -(defvar mh-mime-security-button-end-line-format "%{%([[End of %t]%D]%)%}\n") -(defvar mh-mime-security-button-line-format-alist - '((?t type ?s) - (?i info ?s) - (?d details ?s) - (?D pressed-details ?s))) -(defvar mh-mime-security-button-map - (let ((map (make-sparse-keymap))) - (unless (>= (string-to-number emacs-version) 21) - (set-keymap-parent map mh-show-mode-map)) - (define-key map "\r" 'mh-press-button) - (define-key map [mouse-2] 'mh-push-button) - map)) - -(defvar mh-mime-save-parts-directory nil - "Default to use for `mh-mime-save-parts-default-directory'. -Set from last use.") - -;;;###mh-autoload -(defun mh-mime-save-parts (arg) - "Store the MIME parts of the current message. -If ARG, prompt for directory, else use that specified by the variable -`mh-mime-save-parts-default-directory'. These directories may be superseded by -mh_profile directives, since this function calls on mhstore or mhn to do the -actual storing." - (interactive "P") - (let ((msg (if (eq major-mode 'mh-show-mode) - (mh-show-buffer-message-number) - (mh-get-msg-num t))) - (folder (if (eq major-mode 'mh-show-mode) - mh-show-folder-buffer - mh-current-folder)) - (command (if mh-nmh-flag "mhstore" "mhn")) - (directory - (cond - ((and (or arg - (equal nil mh-mime-save-parts-default-directory) - (equal t mh-mime-save-parts-default-directory)) - (not mh-mime-save-parts-directory)) - (read-file-name "Store in what directory? " nil nil t nil)) - ((and (or arg - (equal t mh-mime-save-parts-default-directory)) - mh-mime-save-parts-directory) - (read-file-name (format - "Store in what directory? [%s] " - mh-mime-save-parts-directory) - "" mh-mime-save-parts-directory t "")) - ((stringp mh-mime-save-parts-default-directory) - mh-mime-save-parts-default-directory) - (t - mh-mime-save-parts-directory)))) - (if (and (equal directory "") mh-mime-save-parts-directory) - (setq directory mh-mime-save-parts-directory)) - (if (not (file-directory-p directory)) - (message "No directory specified.") - (if (equal nil mh-mime-save-parts-default-directory) - (setq mh-mime-save-parts-directory directory)) - (save-excursion - (set-buffer (get-buffer-create " *mh-store*")) - (cd directory) - (setq mh-mime-save-parts-directory directory) - (erase-buffer) - (apply 'call-process - (expand-file-name command mh-progs) nil t nil - (mh-list-to-string (list folder msg "-auto"))) - (if (> (buffer-size) 0) - (save-window-excursion - (switch-to-buffer-other-window " *mh-store*") - (sit-for 3))))))) - -;; Avoid errors if gnus-sum isn't loaded yet... -(defvar gnus-newsgroup-charset nil) -(defvar gnus-newsgroup-name nil) - -;;;###mh-autoload -(defun mh-mime-display (&optional pre-dissected-handles) - "Display (and possibly decode) MIME handles. -Optional argument, PRE-DISSECTED-HANDLES is a list of MIME handles. If -present they are displayed otherwise the buffer is parsed and then -displayed." - (let ((handles ()) - (folder mh-show-folder-buffer)) - (flet ((mm-handle-set-external-undisplayer - (handle function) - (mh-handle-set-external-undisplayer folder handle function))) - ;; If needed dissect the current buffer - (if pre-dissected-handles - (setq handles pre-dissected-handles) - (setq handles (or (mm-dissect-buffer nil) (mm-uu-dissect))) - (setf (mh-mime-handles (mh-buffer-data)) - (mm-merge-handles handles (mh-mime-handles (mh-buffer-data))))) - - (when (and handles (or (not (stringp (car handles))) (cdr handles))) - ;; Goto start of message body - (goto-char (point-min)) - (or (search-forward "\n\n" nil t) (goto-char (point-max))) - - ;; Delete the body - (delete-region (point) (point-max)) - - ;; Display the MIME handles - (mh-mime-display-part handles))))) - -(defun mh-mime-display-part (handle) - "Decides the viewer to call based on the type of HANDLE." - (cond ((null handle) nil) - ((not (stringp (car handle))) - (mh-mime-display-single handle)) - ((equal (car handle) "multipart/alternative") - (mh-mime-display-alternative (cdr handle))) - ((and mh-gnus-pgp-support-flag - (or (equal (car handle) "multipart/signed") - (equal (car handle) "multipart/encrypted"))) - (mh-mime-display-security handle)) - (t (mh-mime-display-mixed (cdr handle))))) - -(defun mh-mime-display-alternative (handles) - "Choose among the alternatives, HANDLES the part that will be displayed. -If no part is preferred then all the parts are displayed." - (let ((preferred (mm-preferred-alternative handles))) - (cond ((and preferred (stringp (car preferred))) - (mh-mime-display-part preferred)) - (preferred - (save-restriction - (narrow-to-region (point) (if (eobp) (point) (1+ (point)))) - (mh-mime-display-single preferred) - (goto-char (point-max)))) - (t (mh-mime-display-mixed handles))))) - -(defun mh-mime-display-mixed (handles) - "Display the list of MIME parts, HANDLES recursively." - (mapcar #'mh-mime-display-part handles)) - -(defun mh-mime-part-index (handle) - "Generate the button number for MIME part, HANDLE. -Notice that a hash table is used to display the same number when buttons need -to be displayed multiple times (for instance when nested messages are -opened)." - (or (gethash handle (mh-mime-part-index-hash (mh-buffer-data))) - (setf (gethash handle (mh-mime-part-index-hash (mh-buffer-data))) - (incf (mh-mime-parts-count (mh-buffer-data)))))) - -;;; Avoid compiler warnings for XEmacs functions... -(eval-when (compile) - (loop for function in '(glyph-width window-pixel-width - glyph-height window-pixel-height) - do (or (fboundp function) (defalias function 'ignore)))) - -(defun mh-small-image-p (handle) - "Decide whether HANDLE is a \"small\" image that can be displayed inline. -This is only useful if a Content-Disposition header is not present." - (let ((media-test (caddr (assoc (car (mm-handle-type handle)) - mh-mm-inline-media-tests))) - (mm-inline-large-images t)) - (and media-test - (equal (mm-handle-media-supertype handle) "image") - (funcall media-test handle) ; Since mm-inline-large-images is T, - ; this only tells us if the image is - ; something that emacs can display - (let* ((image (mm-get-image handle))) - (cond ((fboundp 'glyph-width) - ;; XEmacs -- totally untested, copied from gnus - (and (< (glyph-width image) - (or mh-max-inline-image-width - (window-pixel-width))) - (< (glyph-height image) - (or mh-max-inline-image-height - (window-pixel-height))))) - ((fboundp 'image-size) - ;; Emacs21 -- copied from gnus - (let ((size (image-size image))) - (and (< (cdr size) - (or mh-max-inline-image-height - (1- (window-height)))) - (< (car size) - (or mh-max-inline-image-width (window-width)))))) - (t - ;; Can't show image inline - nil)))))) - -(defun mh-inline-vcard-p (handle) - "Decide if HANDLE is a vcard that must be displayed inline." - (let ((type (mm-handle-type handle))) - (and (consp type) - (equal (car type) "text/x-vcard") - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (not (re-search-forward "^-- $" nil t))))))) - -(defun mh-mime-display-single (handle) - "Display a leaf node, HANDLE in the MIME tree." - (let* ((type (mm-handle-media-type handle)) - (small-image-flag (mh-small-image-p handle)) - (attachmentp (equal (car (mm-handle-disposition handle)) - "attachment")) - (inlinep (and (equal (car (mm-handle-disposition handle)) "inline") - (mm-inlinable-p handle) - (mm-inlined-p handle))) - (displayp (or inlinep ; show if inline OR - (mh-inline-vcard-p handle); inline vcard OR - (and (not attachmentp) ; if not an attachment - (or small-image-flag ; and small image - ; and user wants inline - (and (not (equal - (mm-handle-media-supertype handle) - "image")) - (mm-inlinable-p handle) - (mm-inlined-p handle))))))) - (save-restriction - (narrow-to-region (point) (if (eobp) (point) (1+ (point)))) - (cond ((and mh-gnus-pgp-support-flag - (equal type "application/pgp-signature")) - nil) ; skip signatures as they are already handled... - ((not displayp) - (insert "\n") - (mh-insert-mime-button handle (mh-mime-part-index handle) nil)) - ((and displayp (not mh-display-buttons-for-inline-parts-flag)) - (or (mm-display-part handle) (mm-display-part handle))) - ((and displayp mh-display-buttons-for-inline-parts-flag) - (insert "\n") - (mh-insert-mime-button handle (mh-mime-part-index handle) nil) - (forward-line -1) - (mh-mm-display-part handle))) - (goto-char (point-max))))) - -(defun mh-insert-mime-button (handle index displayed) - "Insert MIME button for HANDLE. -INDEX is the part number that will be DISPLAYED. It is also used by commands -like \"K v\" which operate on individual MIME parts." - ;; The button could be displayed by a previous decode. In that case - ;; undisplay it if we need a hidden button. - (when (and (mm-handle-displayed-p handle) (not displayed)) - (mm-display-part handle)) - (let ((name (or (mail-content-type-get (mm-handle-type handle) 'name) - (mail-content-type-get (mm-handle-disposition handle) - 'filename) - (mail-content-type-get (mm-handle-type handle) 'url) - "")) - (type (mm-handle-media-type handle)) - (description (mail-decode-encoded-word-string - (or (mm-handle-description handle) ""))) - (dots (if (or displayed (mm-handle-displayed-p handle)) " " "...")) - long-type begin end) - (if (string-match ".*/" name) (setq name (substring name (match-end 0)))) - (setq long-type (concat type (and (not (equal name "")) - (concat "; " name)))) - (unless (equal description "") - (setq long-type (concat " --- " long-type))) - (unless (bolp) (insert "\n")) - (setq begin (point)) - (gnus-eval-format - mh-mime-button-line-format mh-mime-button-line-format-alist - `(,@(gnus-local-map-property mh-mime-button-map) - mh-callback mh-mm-display-part - mh-part ,index - mh-data ,handle)) - (setq end (point)) - (widget-convert-button - 'link begin end - :mime-handle handle - :action 'mh-widget-press-button - :button-keymap mh-mime-button-map - :help-echo - "Mouse-2 click or press RET (in show buffer) to toggle display"))) - -;; There is a bug in Gnus inline image display due to which an extra line -;; gets inserted every time it is viewed. To work around that problem we are -;; using an extra property 'mh-region to remember the region that is added -;; when the button is clicked. The region is then deleted to make sure that -;; no extra lines get inserted. -(defun mh-mm-display-part (handle) - "Toggle display of button for MIME part, HANDLE." - (beginning-of-line) - (let ((id (get-text-property (point) 'mh-part)) - (point (point)) - (window (selected-window)) - (mail-parse-charset 'nil) - (mail-parse-ignored-charsets nil) - region buffer-read-only) - (save-excursion - (unwind-protect - (let ((win (get-buffer-window (current-buffer) t))) - (when win - (select-window win)) - (goto-char point) - - (if (mm-handle-displayed-p handle) - ;; This will remove the part. - (progn - ;; Delete the button and displayed part (if any) - (let ((region (get-text-property point 'mh-region))) - (when region - (when (fboundp 'remove-images) - (remove-images (car region) (cdr region)))) - (mm-display-part handle) - (when region - (delete-region (car region) (cdr region)))) - ;; Delete button (if it still remains). This happens for - ;; externally displayed parts where the previous step does - ;; nothing. - (unless (eolp) - (delete-region (point) (progn (forward-line) (point))))) - (save-restriction - (delete-region (point) (progn (forward-line 1) (point))) - (narrow-to-region (point) (point)) - ;; Maybe we need another unwind-protect here. - (when (equal (mm-handle-media-supertype handle) "image") - (insert "\n")) - (when (and (not (eq (ignore-errors (mm-display-part handle)) - 'inline)) - (equal (mm-handle-media-supertype handle) - "image")) - (goto-char (point-min)) - (delete-char 1)) - (when (equal (mm-handle-media-supertype handle) "text") - (when (eq mh-highlight-citation-p 'gnus) - (mh-gnus-article-highlight-citation)) - (mh-display-smileys) - (mh-display-emphasis)) - (setq region (cons (progn (goto-char (point-min)) - (point-marker)) - (progn (goto-char (point-max)) - (point-marker))))))) - (when (window-live-p window) - (select-window window)) - (goto-char point) - (beginning-of-line) - (mh-insert-mime-button handle id (mm-handle-displayed-p handle)) - (goto-char point) - (when region - (add-text-properties (line-beginning-position) (line-end-position) - `(mh-region ,region))))))) - -;;;###mh-autoload -(defun mh-press-button () - "Press MIME button. -If the MIME part is visible then it is removed. Otherwise the part is -displayed." - (interactive) - (let ((mm-inline-media-tests mh-mm-inline-media-tests) - (data (get-text-property (point) 'mh-data)) - (function (get-text-property (point) 'mh-callback)) - (buffer-read-only nil) - (folder mh-show-folder-buffer)) - (flet ((mm-handle-set-external-undisplayer - (handle function) - (mh-handle-set-external-undisplayer folder handle function))) - (when (and function (eolp)) - (backward-char)) - (unwind-protect (and function (funcall function data)) - (set-buffer-modified-p nil))))) - -;;;###mh-autoload -(defun mh-push-button (event) - "Click MIME button for EVENT. -If the MIME part is visible then it is removed. Otherwise the part is -displayed. This function is called when the mouse is used to click the MIME -button." - (interactive "e") - (set-buffer (window-buffer (posn-window (event-start event)))) - (select-window (posn-window (event-start event))) - (let* ((pos (posn-point (event-start event))) - (folder mh-show-folder-buffer) - (mm-inline-media-tests mh-mm-inline-media-tests) - (data (get-text-property pos 'mh-data)) - (function (get-text-property pos 'mh-callback)) - (buffer-read-only nil)) - (flet ((mm-handle-set-external-undisplayer - (handle function) - (mh-handle-set-external-undisplayer folder handle function))) - (goto-char pos) - (unwind-protect (and function (funcall function data)) - (set-buffer-modified-p nil))))) - -;;;###mh-autoload -(defun mh-mime-save-part () - "Save MIME part at point." - (interactive) - (let ((data (get-text-property (point) 'mh-data))) - (when data - (let ((mm-default-directory mh-mime-save-parts-directory)) - (mh-mm-save-part data) - (setq mh-mime-save-parts-directory mm-default-directory))))) - -;;;###mh-autoload -(defun mh-mime-inline-part () - "Toggle display of the raw MIME part." - (interactive) - (let* ((buffer-read-only nil) - (data (get-text-property (point) 'mh-data)) - (inserted-flag (get-text-property (point) 'mh-mime-inserted)) - (displayed-flag (mm-handle-displayed-p data)) - (point (point)) - start end) - (cond ((and data (not inserted-flag) (not displayed-flag)) - (let ((contents (mm-get-part data))) - (add-text-properties (line-beginning-position) (line-end-position) - '(mh-mime-inserted t)) - (setq start (point-marker)) - (forward-line 1) - (mm-insert-inline data contents) - (setq end (point-marker)) - (add-text-properties - start (progn (goto-char start) (line-end-position)) - `(mh-region (,start . ,end))))) - ((and data (or inserted-flag displayed-flag)) - (mh-press-button) - (message "MIME part already inserted"))) - (goto-char point) - (set-buffer-modified-p nil))) - -(defun mh-widget-press-button (widget el) - "Callback for widget, WIDGET. -Parameter EL is unused." - (goto-char (widget-get widget :from)) - (mh-press-button)) - -(defun mh-mime-display-security (handle) - "Display PGP encrypted/signed message, HANDLE." - (insert "\n") - (save-restriction - (narrow-to-region (point) (point)) - (mh-insert-mime-security-button handle) - (mh-mime-display-mixed (cdr handle)) - (insert "\n") - (let ((mh-mime-security-button-line-format - mh-mime-security-button-end-line-format)) - (mh-insert-mime-security-button handle)) - (mm-set-handle-multipart-parameter - handle 'mh-region - (cons (set-marker (make-marker) (point-min)) - (set-marker (make-marker) (point-max)))))) - -;;; I rewrote the security part because Gnus doesn't seem to ever minimize -;;; the button. That is once the mime-security button is pressed there seems -;;; to be no way of getting rid of the inserted text. -(defun mh-mime-security-show-details (handle) - "Toggle display of detailed security info for HANDLE." - (let ((details (mm-handle-multipart-ctl-parameter handle 'gnus-details))) - (when details - (let ((mh-mime-security-button-pressed - (not (get-text-property (point) 'mh-button-pressed))) - (mh-mime-security-button-line-format - (get-text-property (point) 'mh-line-format))) - (forward-char -1) - (while (eq (get-text-property (point) 'mh-line-format) - mh-mime-security-button-line-format) - (forward-char -1)) - (forward-char) - (save-restriction - (narrow-to-region (point) (point)) - (mh-insert-mime-security-button handle)) - (delete-region - (point) - (or (text-property-not-all - (point) (point-max) - 'mh-line-format mh-mime-security-button-line-format) - (point-max))) - (forward-line -1))))) - -(defun mh-mime-security-press-button (handle) - "Callback from security button for part HANDLE." - (when (mm-handle-multipart-ctl-parameter handle 'gnus-info) - (mh-mime-security-show-details handle))) - -;; These variables should already be initialized in mm-decode.el if we have a -;; recent enough Gnus. The defvars are here to avoid compiler warnings. -(defvar mm-verify-function-alist nil) -(defvar mm-decrypt-function-alist nil) - -(defvar pressed-details) - -(defun mh-insert-mime-security-button (handle) - "Display buttons for PGP message, HANDLE." - (let* ((protocol (mm-handle-multipart-ctl-parameter handle 'protocol)) - (crypto-type (or (nth 2 (assoc protocol mm-verify-function-alist)) - (nth 2 (assoc protocol mm-decrypt-function-alist)) - "Unknown")) - (type (concat crypto-type - (if (equal (car handle) "multipart/signed") - " Signed" " Encrypted") - " Part")) - (info (or (mm-handle-multipart-ctl-parameter handle 'gnus-info) - "Undecided")) - (details (mm-handle-multipart-ctl-parameter handle 'gnus-details)) - pressed-details begin end) - (setq details (if details (concat "\n" details) "")) - (setq pressed-details (if mh-mime-security-button-pressed details "")) - (unless (bolp) (insert "\n")) - (setq begin (point)) - (gnus-eval-format - mh-mime-security-button-line-format - mh-mime-security-button-line-format-alist - `(,@(gnus-local-map-property mh-mime-security-button-map) - mh-button-pressed ,mh-mime-security-button-pressed - mh-callback mh-mime-security-press-button - mh-line-format ,mh-mime-security-button-line-format - mh-data ,handle)) - (setq end (point)) - (widget-convert-button 'link begin end - :mime-handle handle - :action 'mh-widget-press-button - :button-keymap mh-mime-security-button-map - :help-echo "Mouse-2 click or press RET (in show buffer) to see security details.") - (when (equal info "Failed") - (let* ((type (if (equal (car handle) "multipart/signed") - "verification" "decryption")) - (warning (if (equal type "decryption") - "(passphrase may be incorrect)" ""))) - (message "%s %s failed %s" crypto-type type warning))))) - -(defun mh-mm-inline-message (handle) - "Display message, HANDLE. -The function decodes the message and displays it. It avoids decoding the same -message multiple times." - (let ((b (point)) - (charset (mail-content-type-get (mm-handle-type handle) 'charset)) - (clean-message-header mh-clean-message-header-flag) - (invisible-headers mh-invisible-headers) - (visible-headers mh-visible-headers)) - (when (and charset (stringp charset)) - (setq charset (intern (downcase charset))) - (when (eq charset 'us-ascii) - (setq charset nil))) - (save-excursion - (save-restriction - (narrow-to-region b b) - (mm-insert-part handle) - (mh-mime-display - (or (gethash handle (mh-mime-handles-cache (mh-buffer-data))) - (setf (gethash handle (mh-mime-handles-cache (mh-buffer-data))) - (let ((handles (or (mm-dissect-buffer nil) - (mm-uu-dissect)))) - (setf (mh-mime-handles (mh-buffer-data)) - (mm-merge-handles - handles (mh-mime-handles (mh-buffer-data)))) - handles)))) - - (goto-char (point-min)) - (cond (clean-message-header - (mh-clean-msg-header (point-min) - invisible-headers - visible-headers) - (goto-char (point-min))) - (t - (mh-start-of-uncleaned-message))) - (mh-show-xface) - (mh-show-addr) - ;; The other highlighting types don't need anything special - (when (eq mh-highlight-citation-p 'gnus) - (mh-gnus-article-highlight-citation)) - (goto-char (point-min)) - (insert "\n------- Forwarded Message\n\n") - (mh-display-smileys) - (mh-display-emphasis) - (mm-handle-set-undisplayer - handle - `(lambda () - (let (buffer-read-only) - (if (fboundp 'remove-specifier) - ;; This is only valid on XEmacs. - (mapcar (lambda (prop) - (remove-specifier - (face-property 'default prop) (current-buffer))) - '(background background-pixmap foreground))) - (delete-region ,(point-min-marker) ,(point-max-marker))))))))) - -(provide 'mh-mime) - -;;; Local Variables: -;;; indent-tabs-mode: nil -;;; sentence-end-double-space: nil -;;; End: - -;;; mh-mime.el ends here
--- a/lisp/mail/mh-pick.el Sun Jan 26 01:33:33 2003 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,239 +0,0 @@ -;;; mh-pick.el --- make a search pattern and search for a message in MH-E - -;; Copyright (C) 1993, 1995, 2001 Free Software Foundation, Inc. - -;; Author: Bill Wohler <wohler@newt.com> -;; Maintainer: Bill Wohler <wohler@newt.com> -;; Keywords: mail -;; See: mh-e.el - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Internal support for MH-E package. - -;;; Change Log: - -;; $Id: mh-pick.el,v 1.25 2002/12/04 18:51:50 wohler Exp $ - -;;; Code: - -(require 'mh-e) -(require 'easymenu) -(require 'gnus-util) - -;;; Internal variables: - -(defvar mh-pick-mode-map (make-sparse-keymap) - "Keymap for searching folder.") - -(defvar mh-searching-folder nil) ;Folder this pick is searching. - -;;;###mh-autoload -(defun mh-search-folder (folder) - "Search FOLDER for messages matching a pattern. -This function uses the MH command `pick' to do the work. -Add the messages found to the sequence named `search'." - (interactive (list (mh-prompt-for-folder "Search" - mh-current-folder - t))) - (switch-to-buffer-other-window "pick-pattern") - (if (or (zerop (buffer-size)) - (not (y-or-n-p "Reuse pattern? "))) - (mh-make-pick-template) - (message "")) - (setq mh-searching-folder folder) - (message "%s" (substitute-command-keys - (concat "Type \\[mh-do-pick-search] to search messages, " - "\\[mh-help] for help.")))) - -(defun mh-make-pick-template () - "Initialize the current buffer with a template for a pick pattern." - (erase-buffer) - (insert "From: \n" - "To: \n" - "Cc: \n" - "Date: \n" - "Subject: \n" - "---------\n") - (mh-pick-mode) - (goto-char (point-min)) - (end-of-line)) - -;;; Menu extracted from mh-menubar.el V1.1 (31 July 2001) -(easy-menu-define - mh-pick-menu mh-pick-mode-map "Menu for MH-E pick-mode" - '("Pick" - ["Execute the Search" mh-do-pick-search t])) - - -;;; Help Messages -;;; Group messages logically, more or less. -(defvar mh-pick-mode-help-messages - '((nil - "Search messages: \\[mh-do-pick-search]\n" - "Move to a field by typing C-c C-f C-<field>\n" - "where <field> is the first letter of the desired field.")) - "Key binding cheat sheet. - -This is an associative array which is used to show the most common commands. -The key is a prefix char. The value is one or more strings which are -concatenated together and displayed in the minibuffer if ? is pressed after -the prefix character. The special key nil is used to display the -non-prefixed commands. - -The substitutions described in `substitute-command-keys' are performed as -well.") - -(put 'mh-pick-mode 'mode-class 'special) - -(define-derived-mode mh-pick-mode fundamental-mode "MH-Pick" - "Mode for creating search templates in MH-E.\\<mh-pick-mode-map> - -After each field name, enter the pattern to search for. If a field's -value does not matter for the search, leave it empty. To search the -entire message, supply the pattern in the \"body\" of the template. -Each non-empty field must be matched for a message to be selected. -To effect a logical \"or\", use \\[mh-search-folder] multiple times. -When you have finished, type \\[mh-do-pick-search] to do the search. - -The value of `mh-pick-mode-hook' is a list of functions to be called, -with no arguments, upon entry to this mode. - -\\{mh-pick-mode-map}" - - (make-local-variable 'mh-searching-folder) - (easy-menu-add mh-pick-menu) - (make-local-variable 'mh-help-messages) - (setq mh-help-messages mh-pick-mode-help-messages) - (run-hooks 'mh-pick-mode-hook)) - -;;;###mh-autoload -(defun mh-do-pick-search () - "Find messages that match the qualifications in the current pattern buffer. -Messages are searched for in the folder named in `mh-searching-folder'. -Add the messages found to the sequence named `search'." - (interactive) - (let ((pattern-buffer (buffer-name)) - (searching-buffer mh-searching-folder) - range - msgs - (pattern nil) - (new-buffer nil)) - (save-excursion - (cond ((get-buffer searching-buffer) - (set-buffer searching-buffer) - (setq range (list (format "%d-%d" - mh-first-msg-num mh-last-msg-num)))) - (t - (mh-make-folder searching-buffer) - (setq range '("all")) - (setq new-buffer t)))) - (message "Searching...") - (goto-char (point-min)) - (while (and range - (setq pattern (mh-next-pick-field pattern-buffer))) - (setq msgs (mh-seq-from-command searching-buffer - 'search - (mh-list-to-string - (list "pick" pattern searching-buffer - "-list" - (mh-coalesce-msg-list range))))) - (setq range msgs)) ;restrict the pick range for next pass - (message "Searching...done") - (if new-buffer - (mh-scan-folder searching-buffer msgs) - (switch-to-buffer searching-buffer)) - (mh-add-msgs-to-seq msgs 'search) - (delete-other-windows))) - -(defun mh-seq-from-command (folder seq command) - "In FOLDER, make a sequence named SEQ by executing COMMAND. -COMMAND is a list. The first element is a program name -and the subsequent elements are its arguments, all strings." - (let ((msg) - (msgs ()) - (case-fold-search t)) - (save-excursion - (save-window-excursion - (if (eq 0 (apply 'mh-exec-cmd-quiet nil command)) - ;; "pick" outputs one number per line - (while (setq msg (car (mh-read-msg-list))) - (setq msgs (cons msg msgs)) - (forward-line 1)))) - (set-buffer folder) - (setq msgs (nreverse msgs)) ;put in ascending order - msgs))) - -(defun mh-next-pick-field (buffer) - "Return the next piece of a pick argument extracted from BUFFER. -Return a list like (\"--fieldname\" \"pattern\") or (\"-search\" \"bodypat\") -or nil if no pieces remain." - (set-buffer buffer) - (let ((case-fold-search t)) - (cond ((eobp) - nil) - ((re-search-forward "^\\([a-z][^: \t\n]*\\):[ \t]*\\([a-z0-9].*\\)$" - nil t) - (let* ((component - (format "--%s" - (downcase (buffer-substring (match-beginning 1) - (match-end 1))))) - (pat (buffer-substring (match-beginning 2) (match-end 2)))) - (forward-line 1) - (list component pat))) - ((re-search-forward "^-*$" nil t) - (forward-char 1) - (let ((body (buffer-substring (point) (point-max)))) - (if (and (> (length body) 0) (not (equal body "\n"))) - (list "-search" body) - nil))) - (t - nil)))) - - - -;;; Build the pick-mode keymap: -;;; If this changes, modify mh-pick-mode-help-messages accordingly, above. -(gnus-define-keys mh-pick-mode-map - "\C-c?" mh-help - "\C-c\C-c" mh-do-pick-search - "\C-c\C-f\C-b" mh-to-field - "\C-c\C-f\C-c" mh-to-field - "\C-c\C-f\C-d" mh-to-field - "\C-c\C-f\C-f" mh-to-field - "\C-c\C-f\C-r" mh-to-field - "\C-c\C-f\C-s" mh-to-field - "\C-c\C-f\C-t" mh-to-field - "\C-c\C-fb" mh-to-field - "\C-c\C-fc" mh-to-field - "\C-c\C-fd" mh-to-field - "\C-c\C-ff" mh-to-field - "\C-c\C-fr" mh-to-field - "\C-c\C-fs" mh-to-field - "\C-c\C-ft" mh-to-field) - -(provide 'mh-pick) - -;;; Local Variables: -;;; indent-tabs-mode: nil -;;; sentence-end-double-space: nil -;;; End: - -;;; mh-pick.el ends here
--- a/lisp/mail/mh-seq.el Sun Jan 26 01:33:33 2003 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1277 +0,0 @@ -;;; mh-seq.el --- MH-E sequences support - -;; Copyright (C) 1993, 1995, 2001, 2002 Free Software Foundation, Inc. - -;; Author: Bill Wohler <wohler@newt.com> -;; Maintainer: Bill Wohler <wohler@newt.com> -;; Keywords: mail -;; See: mh-e.el - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: -;; -;; This tries to implement the algorithm described at: -;; http://www.jwz.org/doc/threading.html -;; It is also a start to implementing the IMAP Threading extension RFC. The -;; implementation lacks the reference and subject canonicalization of the -;; RFC. -;; -;; In the presentation buffer, children messages are shown indented with -;; either [ ] or < > around them. Square brackets ([ ]) denote that the -;; algorithm can point out some headers which when taken together implies -;; that the unindented message is an ancestor of the indented message. If -;; no such proof exists then angles (< >) are used. -;; -;; Some issues and problems are as follows: -;; -;; (1) Scan truncates the fields at length 512. So longer references: -;; headers get mutilated. The same kind of MH format string works when -;; composing messages. Is there a way to avoid this? My scan command -;; is as follows: -;; scan +folder -width 10000 \ -;; -format "%(msg)\n%{message-id}\n%{references}\n%{subject}\n" -;; I would really appreciate it if someone would help me with this. -;; -;; (2) Implement heuristics to recognize message-id's in In-Reply-To: -;; header. Right now it just assumes that the last text between angles -;; (< and >) is the message-id. There is the chance that this will -;; incorrectly use an email address like a message-id. -;; -;; (3) Error checking of found message-id's should be done. -;; -;; (4) Since this breaks the assumption that message indices increase as -;; one goes down the buffer, the binary search based mh-goto-msg -;; doesn't work. I have a simpler replacement which may be less -;; efficient. -;; -;; (5) Better canonicalizing for message-id and subject strings. -;; - -;; Internal support for MH-E package. - -;;; Change Log: - -;; $Id: mh-seq.el,v 1.84 2003/01/07 21:15:33 satyaki Exp $ - -;;; Code: - -(require 'cl) -(require 'mh-e) - -;; Shush the byte-compiler -(defvar tool-bar-mode) - -;;; Data structures (used in message threading)... -(defstruct (mh-thread-message (:conc-name mh-message-) - (:constructor mh-thread-make-message)) - (id nil) - (references ()) - (subject "") - (subject-re-p nil)) - -(defstruct (mh-thread-container (:conc-name mh-container-) - (:constructor mh-thread-make-container)) - message parent children - (real-child-p t)) - - -;;; Internal variables: -(defvar mh-last-seq-used nil - "Name of seq to which a msg was last added.") - -(defvar mh-non-seq-mode-line-annotation nil - "Saved value of `mh-mode-line-annotation' when narrowed to a seq.") - -;;; Maps and hashes... -(defvar mh-thread-id-hash nil - "Hashtable used to canonicalize message-id strings.") -(defvar mh-thread-subject-hash nil - "Hashtable used to canonicalize subject strings.") -(defvar mh-thread-id-table nil - "Thread ID table maps from message-id's to message containers.") -(defvar mh-thread-id-index-map nil - "Table to lookup message index number from message-id.") -(defvar mh-thread-index-id-map nil - "Table to lookup message-id from message index.") -(defvar mh-thread-scan-line-map nil - "Map of message index to various parts of the scan line.") -(defvar mh-thread-old-scan-line-map nil - "Old map of message index to various parts of the scan line. -This is the original map that is stored when the folder is narrowed.") -(defvar mh-thread-subject-container-hash nil - "Hashtable used to group messages by subject.") -(defvar mh-thread-duplicates nil - "Hashtable used to remember multiple messages with the same message-id.") -(defvar mh-thread-history () - "Variable to remember the transformations to the thread tree. -When new messages are added, these transformations are rewound, then the -links are added from the newly seen messages. Finally the transformations are -redone to get the new thread tree. This makes incremental threading easier.") -(defvar mh-thread-body-width nil - "Width of scan substring that contains subject and body of message.") - -(make-variable-buffer-local 'mh-thread-id-hash) -(make-variable-buffer-local 'mh-thread-subject-hash) -(make-variable-buffer-local 'mh-thread-id-table) -(make-variable-buffer-local 'mh-thread-id-index-map) -(make-variable-buffer-local 'mh-thread-index-id-map) -(make-variable-buffer-local 'mh-thread-scan-line-map) -(make-variable-buffer-local 'mh-thread-old-scan-line-map) -(make-variable-buffer-local 'mh-thread-subject-container-hash) -(make-variable-buffer-local 'mh-thread-duplicates) -(make-variable-buffer-local 'mh-thread-history) - -;;;###mh-autoload -(defun mh-delete-seq (sequence) - "Delete the SEQUENCE." - (interactive (list (mh-read-seq-default "Delete" t))) - (mh-map-to-seq-msgs 'mh-notate-if-in-one-seq sequence ? (1+ mh-cmd-note) - sequence) - (mh-undefine-sequence sequence '("all")) - (mh-delete-seq-locally sequence)) - -;; Avoid compiler warnings -(defvar view-exit-action) - -;;;###mh-autoload -(defun mh-list-sequences () - "List the sequences defined in the folder being visited." - (interactive) - (let ((folder mh-current-folder) - (temp-buffer mh-temp-sequences-buffer) - (seq-list mh-seq-list) - (max-len 0)) - (with-output-to-temp-buffer temp-buffer - (save-excursion - (set-buffer temp-buffer) - (erase-buffer) - (message "Listing sequences ...") - (insert "Sequences in folder " folder ":\n") - (let ((seq-list seq-list)) - (while seq-list - (setq max-len - (max (length (symbol-name (mh-seq-name (pop seq-list)))) - max-len))) - (setq max-len (+ 2 max-len))) - (while seq-list - (let ((name (mh-seq-name (car seq-list))) - (sorted-seq-msgs - (mh-coalesce-msg-list - (sort (copy-sequence (mh-seq-msgs (car seq-list))) '<))) - name-spec) - (insert (setq name-spec (format (format "%%%ss:" max-len) name))) - (while sorted-seq-msgs - (let ((next-element (format " %s" (pop sorted-seq-msgs)))) - (when (>= (+ (current-column) (length next-element)) - (window-width)) - (insert "\n") - (insert (format (format "%%%ss" (length name-spec)) ""))) - (insert next-element))) - (insert "\n")) - (setq seq-list (cdr seq-list))) - (goto-char (point-min)) - (view-mode 1) - (setq view-exit-action 'kill-buffer) - (message "Listing sequences...done"))))) - -;;;###mh-autoload -(defun mh-msg-is-in-seq (message) - "Display the sequences that contain MESSAGE (default: current message)." - (interactive (list (mh-get-msg-num t))) - (let* ((dest-folder (loop for seq in mh-refile-list - when (member message (cdr seq)) return (car seq))) - (deleted-flag (unless dest-folder (member message mh-delete-list)))) - (message "Message %d%s is in sequences: %s" - message - (cond (dest-folder (format " (to be refiled to %s)" dest-folder)) - (deleted-flag (format " (to be deleted)")) - (t "")) - (mapconcat 'concat - (mh-list-to-string (mh-seq-containing-msg message t)) - " ")))) - -;;;###mh-autoload -(defun mh-narrow-to-seq (sequence) - "Restrict display of this folder to just messages in SEQUENCE. -Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command." - (interactive (list (mh-read-seq "Narrow to" t))) - (with-mh-folder-updating (t) - (cond ((mh-seq-to-msgs sequence) - (mh-widen) - (mh-remove-all-notation) - (let ((eob (point-max)) - (msg-at-cursor (mh-get-msg-num nil))) - (setq mh-thread-old-scan-line-map mh-thread-scan-line-map) - (setq mh-thread-scan-line-map (make-hash-table :test #'eql)) - (mh-copy-seq-to-eob sequence) - (narrow-to-region eob (point-max)) - (mh-notate-user-sequences) - (mh-notate-deleted-and-refiled) - (mh-notate-seq 'cur mh-note-cur mh-cmd-note) - (when msg-at-cursor (mh-goto-msg msg-at-cursor t t)) - (make-variable-buffer-local 'mh-non-seq-mode-line-annotation) - (setq mh-non-seq-mode-line-annotation mh-mode-line-annotation) - (setq mh-mode-line-annotation (symbol-name sequence)) - (mh-make-folder-mode-line) - (mh-recenter nil) - (if (and (boundp 'tool-bar-mode) tool-bar-mode) - (set (make-local-variable 'tool-bar-map) - mh-folder-seq-tool-bar-map)) - (setq mh-narrowed-to-seq sequence) - (push 'widen mh-view-ops))) - (t - (error "No messages in sequence `%s'" (symbol-name sequence)))))) - -;;;###mh-autoload -(defun mh-put-msg-in-seq (msg-or-seq sequence) - "Add MSG-OR-SEQ (default: displayed message) to SEQUENCE. -If optional prefix argument provided, then prompt for the message sequence. -If variable `transient-mark-mode' is non-nil and the mark is active, then -the selected region is added to the sequence." - (interactive (list (cond - ((mh-mark-active-p t) - (mh-region-to-msg-list (region-beginning) (region-end))) - (current-prefix-arg - (mh-read-seq-default "Add messages from" t)) - (t - (mh-get-msg-num t))) - (mh-read-seq-default "Add to" nil))) - (if (not (mh-internal-seq sequence)) - (setq mh-last-seq-used sequence)) - (mh-add-msgs-to-seq (cond ((numberp msg-or-seq) (list msg-or-seq)) - ((listp msg-or-seq) msg-or-seq) - (t (mh-seq-to-msgs msg-or-seq))) - sequence)) - -(defun mh-valid-view-change-operation-p (op) - "Check if the view change operation can be performed. -OP is one of 'widen and 'unthread." - (cond ((eq (car mh-view-ops) op) - (pop mh-view-ops)) - (t nil))) - -;;;###mh-autoload -(defun mh-widen () - "Remove restrictions from current folder, thereby showing all messages." - (interactive) - (let ((msg (mh-get-msg-num nil))) - (when mh-narrowed-to-seq - (cond ((mh-valid-view-change-operation-p 'widen) nil) - ((memq 'widen mh-view-ops) - (while (not (eq (car mh-view-ops) 'widen)) - (setq mh-view-ops (cdr mh-view-ops))) - (pop mh-view-ops)) - (t (error "Widening is not applicable"))) - (when (memq 'unthread mh-view-ops) - (setq mh-thread-scan-line-map mh-thread-old-scan-line-map)) - (with-mh-folder-updating (t) - (delete-region (point-min) (point-max)) - (widen) - (setq mh-mode-line-annotation mh-non-seq-mode-line-annotation) - (mh-make-folder-mode-line)) - (if msg - (mh-goto-msg msg t t)) - (mh-notate-deleted-and-refiled) - (mh-notate-user-sequences) - (mh-notate-seq 'cur mh-note-cur mh-cmd-note) - (mh-recenter nil))) - (if (and (boundp 'tool-bar-mode) tool-bar-mode) - (set (make-local-variable 'tool-bar-map) mh-folder-tool-bar-map)) - (setq mh-narrowed-to-seq nil)) - -;; FIXME? We may want to clear all notations and add one for current-message -;; and process user sequences. -(defun mh-notate-deleted-and-refiled () - "Notate messages marked for deletion or refiling. -Messages to be deleted are given by `mh-delete-list' while messages to be -refiled are present in `mh-refile-list'." - (mh-mapc #'(lambda (msg) (mh-notate msg mh-note-deleted mh-cmd-note)) - mh-delete-list) - (mh-mapc #'(lambda (dest-msg-list) - ;; foreach folder name, get the keyed sequence from mh-seq-list - (let ((msg-list (cdr dest-msg-list))) - (mh-mapc #'(lambda (msg) - (mh-notate msg mh-note-refiled mh-cmd-note)) - msg-list))) - mh-refile-list)) - - - -;;; Commands to manipulate sequences. Sequences are stored in an alist -;;; of the form: -;;; ((seq-name msgs ...) (seq-name msgs ...) ...) - -(defun mh-read-seq-default (prompt not-empty) - "Read and return sequence name with default narrowed or previous sequence. -PROMPT is the prompt to use when reading. If NOT-EMPTY is non-nil then a -non-empty sequence is read." - (mh-read-seq prompt not-empty - (or mh-narrowed-to-seq - mh-last-seq-used - (car (mh-seq-containing-msg (mh-get-msg-num nil) nil))))) - -(defun mh-read-seq (prompt not-empty &optional default) - "Read and return a sequence name. -Prompt with PROMPT, raise an error if the sequence is empty and the NOT-EMPTY -flag is non-nil, and supply an optional DEFAULT sequence. A reply of '%' -defaults to the first sequence containing the current message." - (let* ((input (completing-read (format "%s %s %s" prompt "sequence:" - (if default - (format "[%s] " default) - "")) - (mh-seq-names mh-seq-list))) - (seq (cond ((equal input "%") - (car (mh-seq-containing-msg (mh-get-msg-num t) nil))) - ((equal input "") default) - (t (intern input)))) - (msgs (mh-seq-to-msgs seq))) - (if (and (null msgs) not-empty) - (error "No messages in sequence `%s'" seq)) - seq)) - -(defun mh-seq-names (seq-list) - "Return an alist containing the names of the SEQ-LIST." - (mapcar (lambda (entry) (list (symbol-name (mh-seq-name entry)))) - seq-list)) - -;;;###mh-autoload -(defun mh-rename-seq (sequence new-name) - "Rename SEQUENCE to have NEW-NAME." - (interactive (list (mh-read-seq "Old" t) - (intern (read-string "New sequence name: ")))) - (let ((old-seq (mh-find-seq sequence))) - (or old-seq - (error "Sequence %s does not exist" sequence)) - ;; create new sequence first, since it might raise an error. - (mh-define-sequence new-name (mh-seq-msgs old-seq)) - (mh-undefine-sequence sequence (mh-seq-msgs old-seq)) - (rplaca old-seq new-name))) - -;;;###mh-autoload -(defun mh-map-to-seq-msgs (func seq &rest args) - "Invoke the FUNC at each message in the SEQ. -SEQ can either be a list of messages or a MH sequence. The remaining ARGS are -passed as arguments to FUNC." - (save-excursion - (let ((msgs (if (listp seq) seq (mh-seq-to-msgs seq)))) - (while msgs - (if (mh-goto-msg (car msgs) t t) - (apply func (car msgs) args)) - (setq msgs (cdr msgs)))))) - -;;;###mh-autoload -(defun mh-notate-seq (seq notation offset) - "Mark the scan listing. -All messages in SEQ are marked with NOTATION at OFFSET from the beginning of -the line." - (mh-map-to-seq-msgs 'mh-notate seq notation offset)) - -;;;###mh-autoload -(defun mh-add-to-sequence (seq msgs) - "The sequence SEQ is augmented with the messages in MSGS." - ;; Add to a SEQUENCE each message the list of MSGS. - (if (not (mh-folder-name-p seq)) - (if msgs - (apply 'mh-exec-cmd "mark" mh-current-folder "-add" - "-sequence" (symbol-name seq) - (mh-coalesce-msg-list msgs))))) - -;; This has a tricky bug. mh-map-to-seq-msgs uses mh-goto-msg, which assumes -;; that the folder buffer is sorted. However in this case that assumption -;; doesn't hold. So we will do this the dumb way. -;(defun mh-copy-seq-to-point (seq location) -; ;; Copy the scan listing of the messages in SEQUENCE to after the point -; ;; LOCATION in the current buffer. -; (mh-map-to-seq-msgs 'mh-copy-line-to-point seq location)) - -(defun mh-copy-seq-to-eob (seq) - "Copy SEQ to the end of the buffer." - ;; It is quite involved to write something which will work at any place in - ;; the buffer, so we will write something which works only at the end of - ;; the buffer. If we ever need to insert sequences in the middle of the - ;; buffer, this will need to be fixed. - (save-excursion - (let* ((msgs (mh-seq-to-msgs seq)) - (coalesced-msgs (mh-coalesce-msg-list msgs))) - (goto-char (point-max)) - (save-restriction - (narrow-to-region (point) (point)) - (mh-regenerate-headers coalesced-msgs t) - (cond ((memq 'unthread mh-view-ops) - ;; Populate restricted scan-line map - (goto-char (point-min)) - (while (not (eobp)) - (let ((msg (mh-get-msg-num nil))) - (when (numberp msg) - (setf (gethash msg mh-thread-scan-line-map) - (mh-thread-parse-scan-line)))) - (forward-line)) - ;; Remove scan lines and read results from pre-computed tree - (delete-region (point-min) (point-max)) - (let ((thread-tree (mh-thread-generate mh-current-folder ())) - (mh-thread-body-width - (- (window-width) mh-cmd-note - (1- mh-scan-field-subject-start-offset))) - (mh-thread-last-ancestor nil)) - (mh-thread-generate-scan-lines thread-tree -2))) - (mh-index-data - (mh-index-insert-folder-headers))))))) - -(defun mh-copy-line-to-point (msg location) - "Copy current message line to a specific location. -The argument MSG is not used. The message in the current line is copied to -LOCATION." - ;; msg is not used? - ;; Copy the current line to the LOCATION in the current buffer. - (beginning-of-line) - (save-excursion - (let ((beginning-of-line (point)) - end) - (forward-line 1) - (setq end (point)) - (goto-char location) - (insert-buffer-substring (current-buffer) beginning-of-line end)))) - -;;;###mh-autoload -(defun mh-region-to-msg-list (begin end) - "Return a list of messages within the region between BEGIN and END." - (save-excursion - ;; If end is end of buffer back up one position - (setq end (if (equal end (point-max)) (1- end) end)) - (goto-char begin) - (let ((result ())) - (while (<= (point) end) - (let ((index (mh-get-msg-num nil))) - (when (numberp index) (push index result))) - (forward-line 1)) - result))) - - - -;;; Commands to handle new 'subject sequence. -;;; Or "Poor man's threading" by psg. - -(defun mh-subject-to-sequence (all) - "Put all following messages with same subject in sequence 'subject. -If arg ALL is t, move to beginning of folder buffer to collect all messages. -If arg ALL is nil, collect only messages fron current one on forward. - -Return number of messages put in the sequence: - - nil -> there was no subject line. - 0 -> there were no later messages with the same subject (sequence not made) - >1 -> the total number of messages including current one." - (if (not (eq major-mode 'mh-folder-mode)) - (error "Not in a folder buffer")) - (save-excursion - (beginning-of-line) - (if (or (not (looking-at mh-scan-subject-regexp)) - (not (match-string 3)) - (string-equal "" (match-string 3))) - (progn (message "No subject line.") - nil) - (let ((subject (match-string-no-properties 3)) - (list)) - (if (> (length subject) 41) - (setq subject (substring subject 0 41))) - (save-excursion - (if all - (goto-char (point-min))) - (while (re-search-forward mh-scan-subject-regexp nil t) - (let ((this-subject (match-string-no-properties 3))) - (if (> (length this-subject) 41) - (setq this-subject (substring this-subject 0 41))) - (if (string-equal this-subject subject) - (setq list (cons (mh-get-msg-num t) list)))))) - (cond - (list - ;; If we created a new sequence, add the initial message to it too. - (if (not (member (mh-get-msg-num t) list)) - (setq list (cons (mh-get-msg-num t) list))) - (if (member '("subject") (mh-seq-names mh-seq-list)) - (mh-delete-seq 'subject)) - ;; sort the result into a sequence - (let ((sorted-list (sort (copy-sequence list) 'mh-lessp))) - (while sorted-list - (mh-add-msgs-to-seq (car sorted-list) 'subject nil) - (setq sorted-list (cdr sorted-list))) - (safe-length list))) - (t - 0)))))) - -;;;###mh-autoload -(defun mh-narrow-to-subject () - "Narrow to a sequence containing all following messages with same subject." - (interactive) - (let ((num (mh-get-msg-num nil)) - (count (mh-subject-to-sequence t))) - (cond - ((not count) ; No subject line, delete msg anyway - nil) - ((= 0 count) ; No other msgs, delete msg anyway. - (message "No other messages with same Subject following this one.") - nil) - (t ; We have a subject sequence. - (message "Found %d messages for subject sequence." count) - (mh-narrow-to-seq 'subject) - (if (numberp num) - (mh-goto-msg num t t)))))) - -;;;###mh-autoload -(defun mh-delete-subject () - "Mark all following messages with same subject to be deleted. -This puts the messages in a sequence named subject. You can undo the last -deletion marks using `mh-undo' with a prefix argument and then specifying the -subject sequence." - (interactive) - (let ((count (mh-subject-to-sequence nil))) - (cond - ((not count) ; No subject line, delete msg anyway - (mh-delete-msg (mh-get-msg-num t))) - ((= 0 count) ; No other msgs, delete msg anyway. - (message "No other messages with same Subject following this one.") - (mh-delete-msg (mh-get-msg-num t))) - (t ; We have a subject sequence. - (message "Marked %d messages for deletion" count) - (mh-delete-msg 'subject))))) - -;;;###mh-autoload -(defun mh-delete-subject-or-thread () - "Mark messages for deletion intelligently. -If the folder is threaded then `mh-thread-delete' is used to mark the current -message and all its descendants for deletion. Otherwise `mh-delete-subject' is -used to mark the current message and all messages following it with the same -subject for deletion." - (interactive) - (if (memq 'unthread mh-view-ops) - (mh-thread-delete) - (mh-delete-subject))) - -;;; Message threading: - -(defun mh-thread-initialize () - "Make hash tables, otherwise clear them." - (cond - (mh-thread-id-hash - (clrhash mh-thread-id-hash) - (clrhash mh-thread-subject-hash) - (clrhash mh-thread-id-table) - (clrhash mh-thread-id-index-map) - (clrhash mh-thread-index-id-map) - (clrhash mh-thread-scan-line-map) - (clrhash mh-thread-subject-container-hash) - (clrhash mh-thread-duplicates) - (setq mh-thread-history ())) - (t (setq mh-thread-id-hash (make-hash-table :test #'equal)) - (setq mh-thread-subject-hash (make-hash-table :test #'equal)) - (setq mh-thread-id-table (make-hash-table :test #'eq)) - (setq mh-thread-id-index-map (make-hash-table :test #'eq)) - (setq mh-thread-index-id-map (make-hash-table :test #'eql)) - (setq mh-thread-scan-line-map (make-hash-table :test #'eql)) - (setq mh-thread-subject-container-hash (make-hash-table :test #'eq)) - (setq mh-thread-duplicates (make-hash-table :test #'eq)) - (setq mh-thread-history ())))) - -(defsubst mh-thread-id-container (id) - "Given ID, return the corresponding container in `mh-thread-id-table'. -If no container exists then a suitable container is created and the id-table -is updated." - (when (not id) - (error "1")) - (or (gethash id mh-thread-id-table) - (setf (gethash id mh-thread-id-table) - (let ((message (mh-thread-make-message :id id))) - (mh-thread-make-container :message message))))) - -(defsubst mh-thread-remove-parent-link (child) - "Remove parent link of CHILD if it exists." - (let* ((child-container (if (mh-thread-container-p child) - child (mh-thread-id-container child))) - (parent-container (mh-container-parent child-container))) - (when parent-container - (setf (mh-container-children parent-container) - (loop for elem in (mh-container-children parent-container) - unless (eq child-container elem) collect elem)) - (setf (mh-container-parent child-container) nil)))) - -(defsubst mh-thread-add-link (parent child &optional at-end-p) - "Add links so that PARENT becomes a parent of CHILD. -Doesn't make any changes if CHILD is already an ancestor of PARENT. If -optional argument AT-END-P is non-nil, the CHILD is added to the end of the -children list of PARENT." - (let ((parent-container (cond ((null parent) nil) - ((mh-thread-container-p parent) parent) - (t (mh-thread-id-container parent)))) - (child-container (if (mh-thread-container-p child) - child (mh-thread-id-container child)))) - (when (and parent-container - (not (mh-thread-ancestor-p child-container parent-container)) - (not (mh-thread-ancestor-p parent-container child-container))) - (mh-thread-remove-parent-link child-container) - (cond ((not at-end-p) - (push child-container (mh-container-children parent-container))) - ((null (mh-container-children parent-container)) - (push child-container (mh-container-children parent-container))) - (t (let ((last-child (mh-container-children parent-container))) - (while (cdr last-child) - (setq last-child (cdr last-child))) - (setcdr last-child (cons child-container nil))))) - (setf (mh-container-parent child-container) parent-container)) - (unless parent-container - (mh-thread-remove-parent-link child-container)))) - -(defun mh-thread-ancestor-p (ancestor successor) - "Return t if ANCESTOR is really an ancestor of SUCCESSOR and nil otherwise. -In the limit, the function returns t if ANCESTOR and SUCCESSOR are the same -containers." - (block nil - (while successor - (when (eq ancestor successor) (return t)) - (setq successor (mh-container-parent successor))) - nil)) - -(defsubst mh-thread-get-message-container (message) - "Return container which has MESSAGE in it. -If there is no container present then a new container is allocated." - (let* ((id (mh-message-id message)) - (container (gethash id mh-thread-id-table))) - (cond (container (setf (mh-container-message container) message) - container) - (t (setf (gethash id mh-thread-id-table) - (mh-thread-make-container :message message)))))) - -(defsubst mh-thread-get-message (id subject-re-p subject refs) - "Return appropriate message. -Otherwise update message already present to have the proper ID, SUBJECT-RE-P, -SUBJECT and REFS fields." - (let* ((container (gethash id mh-thread-id-table)) - (message (if container (mh-container-message container) nil))) - (cond (message - (setf (mh-message-subject-re-p message) subject-re-p) - (setf (mh-message-subject message) subject) - (setf (mh-message-id message) id) - (setf (mh-message-references message) refs) - message) - (container - (setf (mh-container-message container) - (mh-thread-make-message :subject subject - :subject-re-p subject-re-p - :id id :references refs))) - (t (let ((message (mh-thread-make-message - :subject subject - :subject-re-p subject-re-p - :id id :references refs))) - (prog1 message - (mh-thread-get-message-container message))))))) - -(defsubst mh-thread-canonicalize-id (id) - "Produce canonical string representation for ID. -This allows cheap string comparison with EQ." - (or (and (equal id "") (copy-sequence "")) - (gethash id mh-thread-id-hash) - (setf (gethash id mh-thread-id-hash) id))) - -(defsubst mh-thread-prune-subject (subject) - "Prune leading Re:'s, Fwd:'s etc. and trailing (fwd)'s from SUBJECT. -If the result after pruning is not the empty string then it is canonicalized -so that subjects can be tested for equality with eq. This is done so that all -the messages without a subject are not put into a single thread." - (let ((case-fold-search t) - (subject-pruned-flag nil)) - ;; Prune subject leader - (while (or (string-match "^[ \t]*\\(re\\|fwd?\\)\\(\\[[0-9]*\\]\\)?:[ \t]*" - subject) - (string-match "^[ \t]*\\[[^\\]][ \t]*" subject)) - (setq subject-pruned-flag t) - (setq subject (substring subject (match-end 0)))) - ;; Prune subject trailer - (while (or (string-match "(fwd)$" subject) - (string-match "[ \t]+$" subject)) - (setq subject-pruned-flag t) - (setq subject (substring subject 0 (match-beginning 0)))) - ;; Canonicalize subject only if it is non-empty - (cond ((equal subject "") (values subject subject-pruned-flag)) - (t (values - (or (gethash subject mh-thread-subject-hash) - (setf (gethash subject mh-thread-subject-hash) subject)) - subject-pruned-flag))))) - -(defun mh-thread-container-subject (container) - "Return the subject of CONTAINER. -If CONTAINER is empty return the subject info of one of its children." - (cond ((and (mh-container-message container) - (mh-message-id (mh-container-message container))) - (mh-message-subject (mh-container-message container))) - (t (block nil - (dolist (kid (mh-container-children container)) - (when (and (mh-container-message kid) - (mh-message-id (mh-container-message kid))) - (let ((kid-message (mh-container-message kid))) - (return (mh-message-subject kid-message))))) - (error "This can't happen!"))))) - -(defun mh-thread-rewind-pruning () - "Restore the thread tree to its state before pruning." - (while mh-thread-history - (let ((action (pop mh-thread-history))) - (cond ((eq (car action) 'DROP) - (mh-thread-remove-parent-link (cadr action)) - (mh-thread-add-link (caddr action) (cadr action))) - ((eq (car action) 'PROMOTE) - (let ((node (cadr action)) - (parent (caddr action)) - (children (cdddr action))) - (dolist (child children) - (mh-thread-remove-parent-link child) - (mh-thread-add-link node child)) - (mh-thread-add-link parent node))) - ((eq (car action) 'SUBJECT) - (let ((node (cadr action))) - (mh-thread-remove-parent-link node) - (setf (mh-container-real-child-p node) t))))))) - -(defun mh-thread-prune-containers (roots) - "Prune empty containers in the containers ROOTS." - (let ((dfs-ordered-nodes ()) - (work-list roots)) - (while work-list - (let ((node (pop work-list))) - (dolist (child (mh-container-children node)) - (push child work-list)) - (push node dfs-ordered-nodes))) - (while dfs-ordered-nodes - (let ((node (pop dfs-ordered-nodes))) - (cond ((gethash (mh-message-id (mh-container-message node)) - mh-thread-id-index-map) - ;; Keep it - (setf (mh-container-children node) - (mh-thread-sort-containers (mh-container-children node)))) - ((and (mh-container-children node) - (or (null (cdr (mh-container-children node))) - (mh-container-parent node))) - ;; Promote kids - (let ((children ())) - (dolist (kid (mh-container-children node)) - (mh-thread-remove-parent-link kid) - (mh-thread-add-link (mh-container-parent node) kid) - (push kid children)) - (push `(PROMOTE ,node ,(mh-container-parent node) ,@children) - mh-thread-history) - (mh-thread-remove-parent-link node))) - ((mh-container-children node) - ;; Promote the first orphan to parent and add the other kids as - ;; his children - (setf (mh-container-children node) - (mh-thread-sort-containers (mh-container-children node))) - (let ((new-parent (car (mh-container-children node))) - (other-kids (cdr (mh-container-children node)))) - (mh-thread-remove-parent-link new-parent) - (dolist (kid other-kids) - (mh-thread-remove-parent-link kid) - (setf (mh-container-real-child-p kid) nil) - (mh-thread-add-link new-parent kid t)) - (push `(PROMOTE ,node ,(mh-container-parent node) - ,new-parent ,@other-kids) - mh-thread-history) - (mh-thread-remove-parent-link node))) - (t - ;; Drop it - (push `(DROP ,node ,(mh-container-parent node)) - mh-thread-history) - (mh-thread-remove-parent-link node))))) - (let ((results ())) - (maphash #'(lambda (k v) - (declare (ignore k)) - (when (and (null (mh-container-parent v)) - (gethash (mh-message-id (mh-container-message v)) - mh-thread-id-index-map)) - (push v results))) - mh-thread-id-table) - (mh-thread-sort-containers results)))) - -(defun mh-thread-sort-containers (containers) - "Sort a list of message CONTAINERS to be in ascending order wrt index." - (sort containers - #'(lambda (x y) - (when (and (mh-container-message x) (mh-container-message y)) - (let* ((id-x (mh-message-id (mh-container-message x))) - (id-y (mh-message-id (mh-container-message y))) - (index-x (gethash id-x mh-thread-id-index-map)) - (index-y (gethash id-y mh-thread-id-index-map))) - (and (integerp index-x) (integerp index-y) - (< index-x index-y))))))) - -(defsubst mh-thread-group-by-subject (roots) - "Group the set of message containers, ROOTS based on subject. -Bug: Check for and make sure that something without Re: is made the parent in -preference to something that has it." - (clrhash mh-thread-subject-container-hash) - (let ((results ())) - (dolist (root roots) - (let* ((subject (mh-thread-container-subject root)) - (parent (gethash subject mh-thread-subject-container-hash))) - (cond (parent (mh-thread-remove-parent-link root) - (mh-thread-add-link parent root t) - (setf (mh-container-real-child-p root) nil) - (push `(SUBJECT ,root) mh-thread-history)) - (t - (setf (gethash subject mh-thread-subject-container-hash) root) - (push root results))))) - (nreverse results))) - -(defsubst mh-thread-process-in-reply-to (reply-to-header) - "Extract message id's from REPLY-TO-HEADER. -Ideally this should have some regexp which will try to guess if a string -between < and > is a message id and not an email address. For now it will -take the last string inside angles." - (let ((end (mh-search-from-end ?> reply-to-header))) - (when (numberp end) - (let ((begin (mh-search-from-end ?< (substring reply-to-header 0 end)))) - (when (numberp begin) - (list (substring reply-to-header begin (1+ end)))))))) - -(defun mh-thread-set-tables (folder) - "Use the tables of FOLDER in current buffer." - (flet ((mh-get-table (symbol) - (save-excursion - (set-buffer folder) - (symbol-value symbol)))) - (setq mh-thread-id-hash (mh-get-table 'mh-thread-id-hash)) - (setq mh-thread-subject-hash (mh-get-table 'mh-thread-subject-hash)) - (setq mh-thread-id-table (mh-get-table 'mh-thread-id-table)) - (setq mh-thread-id-index-map (mh-get-table 'mh-thread-id-index-map)) - (setq mh-thread-index-id-map (mh-get-table 'mh-thread-index-id-map)) - (setq mh-thread-scan-line-map (mh-get-table 'mh-thread-scan-line-map)) - (setq mh-thread-subject-container-hash - (mh-get-table 'mh-thread-subject-container-hash)) - (setq mh-thread-duplicates (mh-get-table 'mh-thread-duplicates)) - (setq mh-thread-history (mh-get-table 'mh-thread-history)))) - -(defsubst mh-thread-update-id-index-maps (id index) - "Message with id, ID is the message in INDEX. -The function also checks for duplicate messages (that is multiple messages -with the same ID). These messages are put in the `mh-thread-duplicates' hash -table." - (let ((old-index (gethash id mh-thread-id-index-map))) - (when old-index (push old-index (gethash id mh-thread-duplicates))) - (setf (gethash id mh-thread-id-index-map) index) - (setf (gethash index mh-thread-index-id-map) id))) - - - -;;; Generate Threads... - -(defun mh-thread-generate (folder msg-list) - "Scan FOLDER to get info for threading. -Only information about messages in MSG-LIST are added to the tree." - (save-excursion - (set-buffer (get-buffer-create "*mh-thread*")) - (mh-thread-set-tables folder) - (erase-buffer) - (when msg-list - (apply - #'call-process (expand-file-name mh-scan-prog mh-progs) nil '(t nil) nil - "-width" "10000" "-format" - "%(msg)\n%{message-id}\n%{references}\n%{in-reply-to}\n%{subject}\n" - folder (mapcar #'(lambda (x) (format "%s" x)) msg-list))) - (goto-char (point-min)) - (let ((roots ()) - (case-fold-search t)) - (block nil - (while (not (eobp)) - (block process-message - (let* ((index-line - (prog1 (buffer-substring (point) (line-end-position)) - (forward-line))) - (index (car (read-from-string index-line))) - (id (prog1 (buffer-substring (point) (line-end-position)) - (forward-line))) - (refs (prog1 (buffer-substring (point) (line-end-position)) - (forward-line))) - (in-reply-to (prog1 (buffer-substring (point) - (line-end-position)) - (forward-line))) - (subject (prog1 - (buffer-substring (point) (line-end-position)) - (forward-line))) - (subject-re-p nil)) - (unless (gethash index mh-thread-scan-line-map) - (return-from process-message)) - (unless (integerp index) (return)) ;Error message here - (multiple-value-setq (subject subject-re-p) - (mh-thread-prune-subject subject)) - (setq in-reply-to (mh-thread-process-in-reply-to in-reply-to)) - (setq refs (append (split-string refs) in-reply-to)) - (setq id (mh-thread-canonicalize-id id)) - (mh-thread-update-id-index-maps id index) - (setq refs (mapcar #'mh-thread-canonicalize-id refs)) - (mh-thread-get-message id subject-re-p subject refs) - (do ((ancestors refs (cdr ancestors))) - ((null (cdr ancestors)) - (when (car ancestors) - (mh-thread-remove-parent-link id) - (mh-thread-add-link (car ancestors) id))) - (mh-thread-add-link (car ancestors) (cadr ancestors))))))) - (maphash #'(lambda (k v) - (declare (ignore k)) - (when (null (mh-container-parent v)) - (push v roots))) - mh-thread-id-table) - (setq roots (mh-thread-prune-containers roots)) - (prog1 (setq roots (mh-thread-group-by-subject roots)) - (let ((history mh-thread-history)) - (set-buffer folder) - (setq mh-thread-history history)))))) - -;;;###mh-autoload -(defun mh-thread-inc (folder start-point) - "Update thread tree for FOLDER. -All messages after START-POINT are added to the thread tree." - (mh-thread-rewind-pruning) - (goto-char start-point) - (let ((msg-list ())) - (while (not (eobp)) - (let ((index (mh-get-msg-num nil))) - (when (numberp index) - (push index msg-list) - (setf (gethash index mh-thread-scan-line-map) - (mh-thread-parse-scan-line))) - (forward-line))) - (let ((thread-tree (mh-thread-generate folder msg-list)) - (buffer-read-only nil) - (old-buffer-modified-flag (buffer-modified-p))) - (delete-region (point-min) (point-max)) - (let ((mh-thread-body-width (- (window-width) mh-cmd-note - (1- mh-scan-field-subject-start-offset))) - (mh-thread-last-ancestor nil)) - (mh-thread-generate-scan-lines thread-tree -2)) - (mh-notate-user-sequences) - (mh-notate-deleted-and-refiled) - (mh-notate-seq 'cur mh-note-cur mh-cmd-note) - (set-buffer-modified-p old-buffer-modified-flag)))) - -(defvar mh-thread-last-ancestor) - -(defun mh-thread-generate-scan-lines (tree level) - "Generate scan lines. -TREE is the hierarchical tree of messages, SCAN-LINE-MAP maps message indices -to the corresponding scan lines and LEVEL used to determine indentation of -the message." - (cond ((null tree) nil) - ((mh-thread-container-p tree) - (let* ((message (mh-container-message tree)) - (id (mh-message-id message)) - (index (gethash id mh-thread-id-index-map)) - (duplicates (gethash id mh-thread-duplicates)) - (new-level (+ level 2)) - (dupl-flag t) - (force-angle-flag nil) - (increment-level-flag nil)) - (dolist (scan-line (mapcar (lambda (x) - (gethash x mh-thread-scan-line-map)) - (reverse (cons index duplicates)))) - (when scan-line - (when (and dupl-flag (equal level 0) - (mh-thread-ancestor-p mh-thread-last-ancestor tree)) - (setq level (+ level 2) - new-level (+ new-level 2) - force-angle-flag t)) - (when (equal level 0) - (setq mh-thread-last-ancestor tree) - (while (mh-container-parent mh-thread-last-ancestor) - (setq mh-thread-last-ancestor - (mh-container-parent mh-thread-last-ancestor)))) - (insert (car scan-line) - (format (format "%%%ss" - (if dupl-flag level new-level)) "") - (if (and (mh-container-real-child-p tree) dupl-flag - (not force-angle-flag)) - "[" "<") - (cadr scan-line) - (if (and (mh-container-real-child-p tree) dupl-flag - (not force-angle-flag)) - "]" ">") - (truncate-string-to-width - (caddr scan-line) (- mh-thread-body-width - (if dupl-flag level new-level))) - "\n") - (setq increment-level-flag t) - (setq dupl-flag nil))) - (unless increment-level-flag (setq new-level level)) - (dolist (child (mh-container-children tree)) - (mh-thread-generate-scan-lines child new-level)))) - (t (let ((nlevel (+ level 2))) - (dolist (ch tree) - (mh-thread-generate-scan-lines ch nlevel)))))) - -;; Another and may be better approach would be to generate all the info from -;; the scan which generates the threading info. For now this will have to do. -(defun mh-thread-parse-scan-line (&optional string) - "Parse a scan line. -If optional argument STRING is given then that is assumed to be the scan line. -Otherwise uses the line at point as the scan line to parse." - (let* ((string (or string - (buffer-substring-no-properties (line-beginning-position) - (line-end-position)))) - (first-string (substring string 0 (+ mh-cmd-note 8)))) - (setf (elt first-string mh-cmd-note) ? ) - (when (equal (elt first-string (1+ mh-cmd-note)) (elt mh-note-seq 0)) - (setf (elt first-string (1+ mh-cmd-note)) ? )) - (list first-string - (substring string - (+ mh-cmd-note mh-scan-field-from-start-offset) - (+ mh-cmd-note mh-scan-field-from-end-offset -2)) - (substring string (+ mh-cmd-note mh-scan-field-from-end-offset)) - string))) - -;;;###mh-autoload -(defun mh-thread-add-spaces (count) - "Add COUNT spaces to each scan line in `mh-thread-scan-line-map'." - (let ((spaces (format (format "%%%ss" count) ""))) - (while (not (eobp)) - (let* ((msg-num (mh-get-msg-num nil)) - (old-line (nth 3 (gethash msg-num mh-thread-scan-line-map)))) - (when (numberp msg-num) - (setf (gethash msg-num mh-thread-scan-line-map) - (mh-thread-parse-scan-line (format "%s%s" spaces old-line))))) - (forward-line 1)))) - -(defun mh-thread-folder () - "Generate thread view of folder." - (message "Threading %s..." (buffer-name)) - (mh-thread-initialize) - (goto-char (point-min)) - (while (not (eobp)) - (let ((index (mh-get-msg-num nil))) - (when (numberp index) - (setf (gethash index mh-thread-scan-line-map) - (mh-thread-parse-scan-line)))) - (forward-line)) - (let* ((range (format "%s-%s" mh-first-msg-num mh-last-msg-num)) - (thread-tree (mh-thread-generate (buffer-name) (list range)))) - (delete-region (point-min) (point-max)) - (let ((mh-thread-body-width (- (window-width) mh-cmd-note - (1- mh-scan-field-subject-start-offset))) - (mh-thread-last-ancestor nil)) - (mh-thread-generate-scan-lines thread-tree -2)) - (mh-notate-user-sequences) - (mh-notate-deleted-and-refiled) - (mh-notate-seq 'cur mh-note-cur mh-cmd-note) - (message "Threading %s...done" (buffer-name)))) - -;;;###mh-autoload -(defun mh-toggle-threads () - "Toggle threaded view of folder. -The conversion of normal view to threaded view is exact, that is the same -messages are displayed in the folder buffer before and after threading. However -the conversion from threaded view to normal view is inexact. So more messages -than were originally present may be shown as a result." - (interactive) - (let ((msg-at-point (mh-get-msg-num nil)) - (old-buffer-modified-flag (buffer-modified-p)) - (buffer-read-only nil)) - (cond ((and (memq 'unthread mh-view-ops) mh-narrowed-to-seq) - (unless (mh-valid-view-change-operation-p 'unthread) - (error "Can't unthread folder")) - (mh-scan-folder mh-current-folder - (format "%s" mh-narrowed-to-seq) - t) - (when mh-index-data - (mh-index-insert-folder-headers))) - ((memq 'unthread mh-view-ops) - (unless (mh-valid-view-change-operation-p 'unthread) - (error "Can't unthread folder")) - (mh-scan-folder mh-current-folder - (format "%s-%s" mh-first-msg-num mh-last-msg-num) - t) - (when mh-index-data - (mh-index-insert-folder-headers))) - (t (mh-thread-folder) - (push 'unthread mh-view-ops))) - (when msg-at-point (mh-goto-msg msg-at-point t t)) - (set-buffer-modified-p old-buffer-modified-flag) - (mh-recenter nil))) - -;;;###mh-autoload -(defun mh-thread-forget-message (index) - "Forget the message INDEX from the threading tables." - (let* ((id (gethash index mh-thread-index-id-map)) - (id-index (gethash id mh-thread-id-index-map)) - (duplicates (gethash id mh-thread-duplicates))) - (remhash index mh-thread-index-id-map) - (cond ((and (eql index id-index) (null duplicates)) - (remhash id mh-thread-id-index-map)) - ((eql index id-index) - (setf (gethash id mh-thread-id-index-map) (car duplicates)) - (setf (gethash (car duplicates) mh-thread-index-id-map) id) - (setf (gethash id mh-thread-duplicates) (cdr duplicates))) - (t - (setf (gethash id mh-thread-duplicates) - (remove index duplicates)))))) - - - -;;; Operations on threads - -(defun mh-thread-current-indentation-level () - "Find the number of spaces by which current message is indented." - (save-excursion - (let ((address-start-offset (+ mh-cmd-note mh-scan-date-flag-width - mh-scan-date-width 1)) - (level 0)) - (beginning-of-line) - (forward-char address-start-offset) - (while (char-equal (char-after) ? ) - (incf level) - (forward-char)) - level))) - -;;;###mh-autoload -(defun mh-thread-next-sibling (&optional previous-flag) - "Jump to next sibling. -With non-nil optional argument PREVIOUS-FLAG jump to the previous sibling." - (interactive) - (cond ((not (memq 'unthread mh-view-ops)) - (error "Folder isn't threaded")) - ((eobp) - (error "No message at point"))) - (beginning-of-line) - (let ((point (point)) - (done nil) - (my-level (mh-thread-current-indentation-level))) - (while (and (not done) - (equal (forward-line (if previous-flag -1 1)) 0) - (not (eobp))) - (let ((level (mh-thread-current-indentation-level))) - (cond ((equal level my-level) - (setq done 'success)) - ((< level my-level) - (message "No %s sibling" (if previous-flag "previous" "next")) - (setq done 'failure))))) - (cond ((eq done 'success) (mh-maybe-show)) - ((eq done 'failure) (goto-char point)) - (t (message "No %s sibling" (if previous-flag "previous" "next")) - (goto-char point))))) - -;;;###mh-autoload -(defun mh-thread-previous-sibling () - "Jump to previous sibling." - (interactive) - (mh-thread-next-sibling t)) - -(defun mh-thread-immediate-ancestor () - "Jump to immediate ancestor in thread tree." - (beginning-of-line) - (let ((point (point)) - (ancestor-level (- (mh-thread-current-indentation-level) 2)) - (done nil)) - (if (< ancestor-level 0) - nil - (while (and (not done) (equal (forward-line -1) 0)) - (when (equal ancestor-level (mh-thread-current-indentation-level)) - (setq done t))) - (unless done - (goto-char point)) - done))) - -;;;###mh-autoload -(defun mh-thread-ancestor (&optional thread-root-flag) - "Jump to the ancestor of current message. -If optional argument THREAD-ROOT-FLAG is non-nil then jump to the root of the -thread tree the message belongs to." - (interactive "P") - (beginning-of-line) - (cond ((not (memq 'unthread mh-view-ops)) - (error "Folder isn't threaded")) - ((eobp) - (error "No message at point"))) - (let ((current-level (mh-thread-current-indentation-level))) - (cond (thread-root-flag - (while (mh-thread-immediate-ancestor)) - (mh-maybe-show)) - ((equal current-level 1) - (message "Message has no ancestor")) - (t (mh-thread-immediate-ancestor) - (mh-maybe-show))))) - -(defun mh-thread-find-children () - "Return a region containing the current message and its children. -The result is returned as a list of two elements. The first is the point at the -start of the region and the second is the point at the end." - (beginning-of-line) - (if (eobp) - nil - (let ((address-start-offset (+ mh-cmd-note mh-scan-date-flag-width - mh-scan-date-width 1)) - (level (mh-thread-current-indentation-level)) - spaces begin) - (setq begin (point)) - (setq spaces (format (format "%%%ss" (1+ level)) "")) - (forward-line) - (block nil - (while (not (eobp)) - (forward-char address-start-offset) - (unless (equal (string-match spaces (buffer-substring-no-properties - (point) (line-end-position))) - 0) - (beginning-of-line) - (backward-char) - (return)) - (forward-line))) - (list begin (point))))) - -;;;###mh-autoload -(defun mh-thread-delete () - "Mark current message and all its children for subsequent deletion." - (interactive) - (cond ((not (memq 'unthread mh-view-ops)) - (error "Folder isn't threaded")) - ((eobp) - (error "No message at point")) - (t (mh-delete-msg - (apply #'mh-region-to-msg-list (mh-thread-find-children)))))) - -;; This doesn't handle mh-default-folder-for-message-function. We should -;; refactor that code so that we don't copy it. -;;;###mh-autoload -(defun mh-thread-refile (folder) - "Mark current message and all its children for refiling to FOLDER." - (interactive (list - (intern (mh-prompt-for-folder - "Destination" - (cond ((eq 'refile (car mh-last-destination-folder)) - (symbol-name (cdr mh-last-destination-folder))) - (t "")) - t)))) - (cond ((not (memq 'unthread mh-view-ops)) - (error "Folder isn't threaded")) - ((eobp) - (error "No message at point")) - (t (mh-refile-msg - (apply #'mh-region-to-msg-list (mh-thread-find-children)) - folder)))) - -(provide 'mh-seq) - -;;; Local Variables: -;;; indent-tabs-mode: nil -;;; sentence-end-double-space: nil -;;; End: - -;;; mh-seq.el ends here
--- a/lisp/mail/mh-speed.el Sun Jan 26 01:33:33 2003 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,573 +0,0 @@ -;;; mh-speed.el --- Speedbar interface for MH-E. - -;; Copyright (C) 2002 Free Software Foundation, Inc. - -;; Author: Satyaki Das <satyaki@theforce.stanford.edu> -;; Maintainer: Bill Wohler <wohler@newt.com> -;; Keywords: mail -;; See: mh-e.el - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: -;; Future versions should only use flists. - -;; Speedbar support for MH-E package. - -;;; Change Log: - -;; $Id: mh-speed.el,v 1.34 2003/01/07 21:15:20 satyaki Exp $ - -;;; Code: - -;; Requires -(require 'cl) -(require 'mh-e) -(require 'speedbar) - -;; Global variables -(defvar mh-speed-refresh-flag nil) -(defvar mh-speed-last-selected-folder nil) -(defvar mh-speed-folder-map (make-hash-table :test #'equal)) -(defvar mh-speed-folders-cache (make-hash-table :test #'equal)) -(defvar mh-speed-flists-cache (make-hash-table :test #'equal)) -(defvar mh-speed-flists-process nil) -(defvar mh-speed-flists-timer nil) -(defvar mh-speed-partial-line "") - -;; Add our stealth update function -(unless (member 'mh-speed-stealth-update - (cdr (assoc "files" speedbar-stealthy-function-list))) - ;; Is changing constant lists in elisp safe? - (setq speedbar-stealthy-function-list - (copy-tree speedbar-stealthy-function-list)) - (push 'mh-speed-stealth-update - (cdr (assoc "files" speedbar-stealthy-function-list)))) - -;; Functions called by speedbar to initialize display... -;;;###mh-autoload -(defun mh-folder-speedbar-buttons (buffer) - "Interface function to create MH-E speedbar buffer. -BUFFER is the MH-E buffer for which the speedbar buffer is to be created." - (unless (get-text-property (point-min) 'mh-level) - (erase-buffer) - (clrhash mh-speed-folder-map) - (speedbar-make-tag-line 'bracket ?+ 'mh-speed-toggle nil " " 'ignore nil - 'mh-speedbar-folder-face 0) - (forward-line -1) - (setf (gethash nil mh-speed-folder-map) - (set-marker (make-marker) (1+ (line-beginning-position)))) - (add-text-properties - (line-beginning-position) (1+ (line-beginning-position)) - `(mh-folder nil mh-expanded nil mh-children-p t mh-level 0)) - (mh-speed-stealth-update t) - (when mh-speed-run-flists-flag - (mh-speed-flists nil)))) - -;;;###mh-autoload -(defalias 'mh-show-speedbar-buttons 'mh-folder-speedbar-buttons) -;;;###mh-autoload -(defalias 'mh-letter-speedbar-buttons 'mh-folder-speedbar-buttons) - -;; Keymaps for speedbar... -(defvar mh-folder-speedbar-key-map (speedbar-make-specialized-keymap) - "Specialized speedbar keymap for MH-E buffers.") -(gnus-define-keys mh-folder-speedbar-key-map - "+" mh-speed-expand-folder - "-" mh-speed-contract-folder - "\r" mh-speed-view - "f" mh-speed-flists - "i" mh-speed-invalidate-map) - -(defvar mh-show-speedbar-key-map mh-folder-speedbar-key-map) -(defvar mh-letter-speedbar-key-map mh-folder-speedbar-key-map) - -;; Menus for speedbar... -(defvar mh-folder-speedbar-menu-items - '(["Visit Folder" mh-speed-view - (save-excursion - (set-buffer speedbar-buffer) - (get-text-property (line-beginning-position) 'mh-folder))] - ["Expand nested folders" mh-speed-expand-folder - (and (get-text-property (line-beginning-position) 'mh-children-p) - (not (get-text-property (line-beginning-position) 'mh-expanded)))] - ["Contract nested folders" mh-speed-contract-folder - (and (get-text-property (line-beginning-position) 'mh-children-p) - (get-text-property (line-beginning-position) 'mh-expanded))] - ["Run Flists" mh-speed-flists t] - ["Invalidate cached folders" mh-speed-invalidate-map t]) - "Extra menu items for speedbar.") - -(defvar mh-show-speedbar-menu-items mh-folder-speedbar-menu-items) -(defvar mh-letter-speedbar-menu-items mh-folder-speedbar-menu-items) - -(defmacro mh-speed-select-attached-frame () - "Compatibility macro to handle speedbar versions 0.11a and 0.14beta4." - (cond ((fboundp 'dframe-select-attached-frame) - '(dframe-select-attached-frame speedbar-frame)) - ((boundp 'speedbar-attached-frame) - '(select-frame speedbar-attached-frame)) - (t (error "Installed speedbar version not supported by MH-E")))) - -(defun mh-speed-update-current-folder (force) - "Update speedbar highlighting of the current folder. -The function tries to be smart so that work done is minimized. The currently -highlighted folder is cached and no highlighting happens unless it changes. -Also highlighting is suspended while the speedbar frame is selected. -Otherwise you get the disconcerting behavior of folders popping open on their -own when you are trying to navigate around in the speedbar buffer. - -The update is always carried out if FORCE is non-nil." - (let* ((lastf (selected-frame)) - (newcf (save-excursion - (mh-speed-select-attached-frame) - (prog1 (mh-speed-extract-folder-name (buffer-name)) - (select-frame lastf)))) - (lastb (current-buffer)) - (case-fold-search t)) - (when (or force - (and mh-speed-refresh-flag (not (eq lastf speedbar-frame))) - (and (stringp newcf) - (equal (substring newcf 0 1) "+") - (not (equal newcf mh-speed-last-selected-folder)))) - (setq mh-speed-refresh-flag nil) - (select-frame speedbar-frame) - (set-buffer speedbar-buffer) - - ;; Remove highlight from previous match... - (mh-speed-highlight mh-speed-last-selected-folder - 'mh-speedbar-folder-face) - - ;; If we found a match highlight it... - (when (mh-speed-goto-folder newcf) - (mh-speed-highlight newcf 'mh-speedbar-selected-folder-face)) - - (setq mh-speed-last-selected-folder newcf) - (speedbar-position-cursor-on-line) - (set-window-point (frame-first-window speedbar-frame) (point)) - (set-buffer lastb) - (select-frame lastf)) - (when (eq lastf speedbar-frame) - (setq mh-speed-refresh-flag t)))) - -(defun mh-speed-normal-face (face) - "Return normal face for given FACE." - (cond ((eq face 'mh-speedbar-folder-with-unseen-messages-face) - 'mh-speedbar-folder-face) - ((eq face 'mh-speedbar-selected-folder-with-unseen-messages-face) - 'mh-speedbar-selected-folder-face) - (t face))) - -(defun mh-speed-bold-face (face) - "Return bold face for given FACE." - (cond ((eq face 'mh-speedbar-folder-face) - 'mh-speedbar-folder-with-unseen-messages-face) - ((eq face 'mh-speedbar-selected-folder-face) - 'mh-speedbar-selected-folder-with-unseen-messages-face) - (t face))) - -(defun mh-speed-highlight (folder face) - "Set FOLDER to FACE." - (save-excursion - (speedbar-with-writable - (goto-char (gethash folder mh-speed-folder-map (point))) - (beginning-of-line) - (if (re-search-forward "([1-9][0-9]*/[0-9]+)" (line-end-position) t) - (setq face (mh-speed-bold-face face)) - (setq face (mh-speed-normal-face face))) - (beginning-of-line) - (when (re-search-forward "\\[.\\] " (line-end-position) t) - (put-text-property (point) (line-end-position) 'face face))))) - -(defun mh-speed-stealth-update (&optional force) - "Do stealth update. -With non-nil FORCE, the update is always carried out." - (cond ((save-excursion (set-buffer speedbar-buffer) - (get-text-property (point-min) 'mh-level)) - ;; Execute this hook and *don't* run anything else - (mh-speed-update-current-folder force) - nil) - ;; Otherwise on to your regular programming - (t t))) - -(defun mh-speed-goto-folder (folder) - "Move point to line containing FOLDER. -The function will expand out parent folders of FOLDER if needed." - (let ((prefix folder) - (suffix-list ()) - (last-slash t)) - (while (and (not (gethash prefix mh-speed-folder-map)) last-slash) - (setq last-slash (mh-search-from-end ?/ prefix)) - (when (integerp last-slash) - (push (substring prefix (1+ last-slash)) suffix-list) - (setq prefix (substring prefix 0 last-slash)))) - (let ((prefix-position (gethash prefix mh-speed-folder-map))) - (if prefix-position - (goto-char prefix-position) - (goto-char (point-min)) - (mh-speed-toggle) - (unless (get-text-property (point) 'mh-expanded) - (mh-speed-toggle)) - (goto-char (gethash prefix mh-speed-folder-map)))) - (while suffix-list - ;; We always need atleast one toggle. We need two if the directory list - ;; is stale since a folder was added. - (when (equal prefix (get-text-property (line-beginning-position) - 'mh-folder)) - (mh-speed-toggle) - (unless (get-text-property (point) 'mh-expanded) - (mh-speed-toggle))) - (setq prefix (format "%s/%s" prefix (pop suffix-list))) - (goto-char (gethash prefix mh-speed-folder-map (point)))) - (beginning-of-line) - (equal folder (get-text-property (point) 'mh-folder)))) - -(defun mh-speed-extract-folder-name (buffer) - "Given an MH-E BUFFER find the folder that should be highlighted. -Do the right thing for the different kinds of buffers that MH-E uses." - (save-excursion - (set-buffer buffer) - (cond ((eq major-mode 'mh-folder-mode) - mh-current-folder) - ((eq major-mode 'mh-show-mode) - (set-buffer mh-show-folder-buffer) - mh-current-folder) - ((eq major-mode 'mh-letter-mode) - (when (string-match mh-user-path buffer-file-name) - (let* ((rel-path (substring buffer-file-name (match-end 0))) - (directory-end (mh-search-from-end ?/ rel-path))) - (when directory-end - (format "+%s" (substring rel-path 0 directory-end))))))))) - -(defun mh-speed-add-buttons (folder level) - "Add speedbar button for FOLDER which is at indented by LEVEL amount." - (let ((folder-list (mh-speed-folders folder))) - (mapc - (lambda (f) - (let* ((folder-name (format "%s%s%s" (or folder "+") - (if folder "/" "") (car f))) - (counts (gethash folder-name mh-speed-flists-cache))) - (speedbar-with-writable - (speedbar-make-tag-line - 'bracket (if (cdr f) ?+ ? ) - 'mh-speed-toggle nil - (format "%s%s" - (car f) - (if counts - (format " (%s/%s)" (car counts) (cdr counts)) - "")) - 'mh-speed-view nil - (if (and counts (> (car counts) 0)) - 'mh-speedbar-folder-with-unseen-messages-face - 'mh-speedbar-folder-face) - level) - (save-excursion - (forward-line -1) - (setf (gethash folder-name mh-speed-folder-map) - (set-marker (make-marker) (1+ (line-beginning-position)))) - (add-text-properties - (line-beginning-position) (1+ (line-beginning-position)) - `(mh-folder ,folder-name - mh-expanded nil - mh-children-p ,(not (not (cdr f))) - ,@(if counts `(mh-count - (,(car counts) . ,(cdr counts))) ()) - mh-level ,level)))))) - folder-list))) - -;;;###mh-autoload -(defun mh-speed-toggle (&rest args) - "Toggle the display of child folders. -The otional ARGS are ignored and there for compatibilty with speedbar." - (interactive) - (declare (ignore args)) - (beginning-of-line) - (let ((parent (get-text-property (point) 'mh-folder)) - (kids-p (get-text-property (point) 'mh-children-p)) - (expanded (get-text-property (point) 'mh-expanded)) - (level (get-text-property (point) 'mh-level)) - (point (point)) - start-region) - (speedbar-with-writable - (cond ((not kids-p) nil) - (expanded - (forward-line) - (setq start-region (point)) - (while (and (get-text-property (point) 'mh-level) - (> (get-text-property (point) 'mh-level) level)) - (remhash (get-text-property (point) 'mh-folder) - mh-speed-folder-map) - (forward-line)) - (delete-region start-region (point)) - (forward-line -1) - (speedbar-change-expand-button-char ?+) - (add-text-properties - (line-beginning-position) (1+ (line-beginning-position)) - '(mh-expanded nil))) - (t - (forward-line) - (mh-speed-add-buttons parent (1+ level)) - (goto-char point) - (speedbar-change-expand-button-char ?-) - (add-text-properties - (line-beginning-position) (1+ (line-beginning-position)) - `(mh-expanded t))))))) - -(defalias 'mh-speed-expand-folder 'mh-speed-toggle) -(defalias 'mh-speed-contract-folder 'mh-speed-toggle) - -;;;###mh-autoload -(defun mh-speed-view (&rest args) - "View folder on current line. -Optional ARGS are ignored." - (interactive) - (declare (ignore args)) - (let* ((folder (get-text-property (line-beginning-position) 'mh-folder)) - (range (and (stringp folder) (mh-read-msg-range folder)))) - (when (stringp folder) - (speedbar-with-attached-buffer - (mh-visit-folder folder range) - (delete-other-windows))))) - -(defun mh-speed-folders (folder) - "Find the subfolders of FOLDER. -The function avoids running folders unnecessarily by caching the results of -the actual folders call." - (let ((match (gethash folder mh-speed-folders-cache 'no-result))) - (cond ((eq match 'no-result) - (setf (gethash folder mh-speed-folders-cache) - (mh-speed-folders-actual folder))) - (t match)))) - -(defun mh-speed-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." - (let* ((folder (cond ((and (stringp folder) - (equal (substring folder 0 1) "+")) - folder) - (t nil))) - (arg-list `(,(expand-file-name "folders" mh-progs) - nil (t nil) nil "-noheader" "-norecurse" - ,@(if (stringp folder) (list folder) ()))) - (results ())) - (with-temp-buffer - (apply #'call-process arg-list) - (goto-char (point-min)) - (while (not (and (eolp) (bolp))) - (goto-char (line-end-position)) - (let ((has-pos (search-backward " has " (line-beginning-position) t))) - (when (integerp has-pos) - (while (or (equal (char-after has-pos) ? ) - (equal (char-after has-pos) ?+)) - (decf has-pos)) - (incf has-pos) - (let ((name (buffer-substring (line-beginning-position) has-pos))) - (let ((first-char (substring name 0 1))) - (unless (or (string-equal first-char ".") - (string-equal first-char "#") - (string-equal first-char ",")) - (push - (cons name - (search-forward "(others)" (line-end-position) t)) - results))))) - (forward-line 1)))) - (setq results (nreverse results)) - (when (stringp folder) - (setq results (cdr results)) - (let ((folder-name-len (length (format "%s/" (substring folder 1))))) - (setq results (mapcar (lambda (f) - (cons (substring (car f) folder-name-len) - (cdr f))) - results)))) - results)) - -;;;###mh-autoload -(defun mh-speed-flists (force) - "Execute flists -recurse and update message counts. -If FORCE is non-nil the timer is reset." - (interactive (list t)) - (when force - (when (timerp mh-speed-flists-timer) - (cancel-timer mh-speed-flists-timer)) - (setq mh-speed-flists-timer nil) - (when (and (processp mh-speed-flists-process) - (not (eq (process-status mh-speed-flists-process) 'exit))) - (kill-process mh-speed-flists-process) - (setq mh-speed-flists-process nil))) - (unless mh-speed-flists-timer - (setq mh-speed-flists-timer - (run-at-time - nil mh-speed-flists-interval - (lambda () - (unless (and (processp mh-speed-flists-process) - (not (eq (process-status mh-speed-flists-process) - 'exit))) - (setq mh-speed-flists-process - (start-process (expand-file-name "flists" mh-progs) nil - "flists" "-recurse" - "-sequence" (symbol-name mh-unseen-seq))) - (set-process-filter mh-speed-flists-process - 'mh-speed-parse-flists-output))))))) - -;; Copied from mh-make-folder-list-filter... -(defun mh-speed-parse-flists-output (process output) - "Parse the incremental results from flists. -PROCESS is the flists process and OUTPUT is the results that must be handled -next." - (let ((prevailing-match-data (match-data)) - (position 0) - line-end line folder unseen total) - (unwind-protect - (while (setq line-end (string-match "\n" output position)) - (setq line (format "%s%s" - mh-speed-partial-line - (substring output position line-end)) - mh-speed-partial-line "") - (multiple-value-setq (folder unseen total) - (mh-parse-flist-output-line line)) - (when (and folder unseen total) - (setf (gethash folder mh-speed-flists-cache) (cons unseen total)) - (save-excursion - (when (buffer-live-p (get-buffer speedbar-buffer)) - (set-buffer speedbar-buffer) - (speedbar-with-writable - (when (get-text-property (point-min) 'mh-level) - (let ((pos (gethash folder mh-speed-folder-map)) - face) - (when pos - (goto-char pos) - (goto-char (line-beginning-position)) - (cond - ((null (get-text-property (point) 'mh-count)) - (goto-char (line-end-position)) - (setq face (get-text-property (1- (point)) 'face)) - (insert (format " (%s/%s)" unseen total)) - (mh-speed-highlight 'unknown face) - (goto-char (line-beginning-position)) - (add-text-properties (point) (1+ (point)) - `(mh-count (,unseen . ,total)))) - ((not (equal (get-text-property (point) 'mh-count) - (cons unseen total))) - (goto-char (line-end-position)) - (setq face (get-text-property (1- (point)) 'face)) - (re-search-backward " " (line-beginning-position) t) - (delete-region (point) (line-end-position)) - (insert (format " (%s/%s)" unseen total)) - (mh-speed-highlight 'unknown face) - (goto-char (line-beginning-position)) - (add-text-properties - (point) (1+ (point)) - `(mh-count (,unseen . ,total)))))))))))) - (setq position (1+ line-end))) - (set-match-data prevailing-match-data)) - (setq mh-speed-partial-line (substring output position)))) - -;;;###mh-autoload -(defun mh-speed-invalidate-map (folder) - "Remove FOLDER from various optimization caches." - (interactive (list "")) - (save-excursion - (set-buffer speedbar-buffer) - (let* ((speedbar-update-flag nil) - (last-slash (mh-search-from-end ?/ folder)) - (parent (if last-slash (substring folder 0 last-slash) nil)) - (parent-position (gethash parent mh-speed-folder-map)) - (parent-change nil)) - (remhash parent mh-speed-folders-cache) - (remhash folder mh-speed-folders-cache) - (when parent-position - (let ((parent-kids (mh-speed-folders parent))) - (cond ((null parent-kids) - (setq parent-change ?+)) - ((and (null (cdr parent-kids)) - (equal (if last-slash - (substring folder (1+ last-slash)) - (substring folder 1)) - (caar parent-kids))) - (setq parent-change ? )))) - (goto-char parent-position) - (when (equal (get-text-property (line-beginning-position) 'mh-folder) - parent) - (when (get-text-property (line-beginning-position) 'mh-expanded) - (mh-speed-toggle)) - (when parent-change - (speedbar-with-writable - (mh-speedbar-change-expand-button-char parent-change) - (add-text-properties - (line-beginning-position) (1+ (line-beginning-position)) - `(mh-children-p ,(equal parent-change ?+))))) - (mh-speed-highlight mh-speed-last-selected-folder - 'mh-speedbar-folder-face) - (setq mh-speed-last-selected-folder nil) - (setq mh-speed-refresh-flag t))) - (when (equal folder "") - (clrhash mh-speed-folders-cache))))) - -;;;###mh-autoload -(defun mh-speed-add-folder (folder) - "Add FOLDER since it is being created. -The function invalidates the latest ancestor that is present." - (save-excursion - (set-buffer speedbar-buffer) - (let ((speedbar-update-flag nil) - (last-slash (mh-search-from-end ?/ folder)) - (ancestor folder) - (ancestor-pos nil)) - (block while-loop - (while last-slash - (setq ancestor (substring ancestor 0 last-slash)) - (setq ancestor-pos (gethash ancestor mh-speed-folder-map)) - (when ancestor-pos - (return-from while-loop)) - (setq last-slash (mh-search-from-end ?/ ancestor)))) - (unless ancestor-pos (setq ancestor nil)) - (goto-char (or ancestor-pos (gethash nil mh-speed-folder-map))) - (speedbar-with-writable - (mh-speedbar-change-expand-button-char ?+) - (add-text-properties - (line-beginning-position) (1+ (line-beginning-position)) - `(mh-children-p t))) - (when (get-text-property (line-beginning-position) 'mh-expanded) - (mh-speed-toggle)) - (remhash ancestor mh-speed-folders-cache) - (setq mh-speed-refresh-flag t)))) - -;; Make it slightly more general to allow for [ ] buttons to be changed to -;; [+]. -(defun mh-speedbar-change-expand-button-char (char) - "Change the expansion button character to CHAR for the current line." - (save-excursion - (beginning-of-line) - (if (re-search-forward "\\[.\\]" (line-end-position) t) - (speedbar-with-writable - (backward-char 2) - (delete-char 1) - (insert-char char 1 t) - (put-text-property (point) (1- (point)) 'invisible nil) - ;; make sure we fix the image on the text here. - (speedbar-insert-image-button-maybe (- (point) 2) 3))))) - -(provide 'mh-speed) - -;;; Local Variables: -;;; indent-tabs-mode: nil -;;; sentence-end-double-space: nil -;;; End: - -;;; mh-speed.el ends here
--- a/lisp/mail/mh-utils.el Sun Jan 26 01:33:33 2003 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1879 +0,0 @@ -;;; mh-utils.el --- MH-E code needed for both sending and reading - -;; Copyright (C) 1993, 1995, 1997, 2000, 2001, 2002 Free Software Foundation, Inc. - -;; Author: Bill Wohler <wohler@newt.com> -;; Maintainer: Bill Wohler <wohler@newt.com> -;; Keywords: mail -;; See: mh-e.el - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; Internal support for MH-E package. - -;;; Change Log: - -;; $Id: mh-utils.el,v 1.193 2003/01/08 00:27:31 satyaki 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.") - -(require 'cl) -(require 'gnus-util) -(require 'font-lock) -(require 'mh-loaddefs) -(require 'mh-customize) - -(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 - -;; Shush the byte-compiler -(defvar font-lock-auto-fontify) -(defvar font-lock-defaults) -(defvar mark-active) -(defvar tool-bar-mode) - -;;; Autoloads -(autoload 'gnus-article-highlight-citation "gnus-cite") -(autoload 'mail-header-end "sendmail") -(autoload 'Info-goto-node "info") -(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." - (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 - -(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: " - -(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 \\( \\)") - -(defvar mh-scan-msg-overflow-regexp "^\\?[0-9]" - "Regexp to find a scan line in which the message number overflowed. -The message's number is left truncated in this case.") - -(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 \\( \\).") - -(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.") - -(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.") - -(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.") - -(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) - -(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. - -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'.") - -;; 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)) - (handles ()) ; List of MIME handles - (handles-cache (make-hash-table)) ; Cache to avoid multiple decodes of - ; nested messages - (parts-count 0) ; The button number is generated from - ; this number - (part-index-hash (make-hash-table))) ; Avoid incrementing the part number - ; for nested messages -;;; This has to be a macro, since we do: (setf (mh-buffer-data) ...) -(defmacro mh-buffer-data () - "Convenience macro to get the MIME data structures of the current buffer." - `(gethash (current-buffer) mh-globals-hash)) - -(defvar mh-globals-hash (make-hash-table) - "Keeps track of MIME data on a per buffer basis.") - -(defvar mh-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 - (lambda (handle) - (mm-valid-and-fit-image-p 'jpeg handle))) - ("image/png" - mm-inline-image - (lambda (handle) - (mm-valid-and-fit-image-p 'png handle))) - ("image/gif" - mm-inline-image - (lambda (handle) - (mm-valid-and-fit-image-p 'gif handle))) - ("image/tiff" - mm-inline-image - (lambda (handle) - (mm-valid-and-fit-image-p 'tiff handle)) ) - ("image/xbm" - mm-inline-image - (lambda (handle) - (mm-valid-and-fit-image-p 'xbm handle))) - ("image/x-xbitmap" - mm-inline-image - (lambda (handle) - (mm-valid-and-fit-image-p 'xbm handle))) - ("image/xpm" - mm-inline-image - (lambda (handle) - (mm-valid-and-fit-image-p 'xpm handle))) - ("image/x-pixmap" - mm-inline-image - (lambda (handle) - (mm-valid-and-fit-image-p 'xpm handle))) - ("image/bmp" - mm-inline-image - (lambda (handle) - (mm-valid-and-fit-image-p 'bmp handle))) - ("image/x-portable-bitmap" - mm-inline-image - (lambda (handle) - (mm-valid-and-fit-image-p 'pbm handle))) - ("text/plain" mm-inline-text identity) - ("text/enriched" mm-inline-text identity) - ("text/richtext" mm-inline-text identity) - ("text/x-patch" mm-display-patch-inline - (lambda (handle) - (locate-library "diff-mode"))) - ("application/emacs-lisp" mm-display-elisp-inline identity) - ("application/x-emacs-lisp" mm-display-elisp-inline identity) - ("text/html" - ,(if (fboundp 'mm-inline-text-html) 'mm-inline-text-html 'mm-inline-text) - (lambda (handle) - (or (and (boundp 'mm-inline-text-html-renderer) - mm-inline-text-html-renderer) - (and (boundp 'mm-text-html-renderer) mm-text-html-renderer)))) - ("text/x-vcard" - mm-inline-text-vcard - (lambda (handle) - (or (featurep 'vcard) - (locate-library "vcard")))) - ("message/delivery-status" mm-inline-text identity) - ("message/rfc822" mh-mm-inline-message identity) - ;;("message/partial" mm-inline-partial identity) - ;;("message/external-body" mm-inline-external-body identity) - ("text/.*" mm-inline-text identity) - ("audio/wav" mm-inline-audio - (lambda (handle) - (and (or (featurep 'nas-sound) (featurep 'native-sound)) - (device-sound-enabled-p)))) - ("audio/au" - mm-inline-audio - (lambda (handle) - (and (or (featurep 'nas-sound) (featurep 'native-sound)) - (device-sound-enabled-p)))) - ("application/pgp-signature" ignore identity) - ("application/x-pkcs7-signature" ignore identity) - ("application/pkcs7-signature" ignore identity) - ("application/x-pkcs7-mime" ignore identity) - ("application/pkcs7-mime" ignore identity) - ("multipart/alternative" ignore identity) - ("multipart/mixed" ignore identity) - ("multipart/related" ignore identity) - ;; Disable audio and image - ("audio/.*" ignore ignore) - ("image/.*" ignore ignore) - ;; Default to displaying as text - (".*" mm-inline-text mm-readable-p)) - "Alist of media types/tests saying whether types can be displayed inline.") - -;; 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 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." - (re-search-backward "[^-_A-z0-9.@]" (line-beginning-position) 'lim) - (if (or (looking-at mh-address-mail-regexp) ; already at start - (and (re-search-forward mh-address-mail-regexp - (line-end-position) 'lim) - (goto-char (match-beginning 0)))) - (match-string-no-properties 0))) - -(defun mh-in-header-p () - "Return non-nil if the point is in the header of a draft message." - (< (point) (mail-header-end))) - -(defun mh-header-field-beginning () - "Move to the beginning of the current header field. -Handles RFC 822 continuation lines." - (beginning-of-line) - (while (looking-at "^[ \t]") - (forward-line -1))) - -(defun mh-header-field-end () - "Move to the end of the current header field. -Handles RFC 822 continuation lines." - (forward-line 1) - (while (looking-at "^[ \t]") - (forward-line 1)) - (backward-char 1)) ;to end of previous line - -(defun mh-letter-header-font-lock (limit) - "Return the entire mail header to font-lock. -Argument LIMIT limits search." - (if (= (point) limit) - nil - (let* ((mail-header-end (save-match-data (mail-header-end))) - (lesser-limit (if (< mail-header-end limit) mail-header-end limit))) - (when (mh-in-header-p) - (set-match-data (list 1 lesser-limit)) - (goto-char lesser-limit) - t)))) - -(defun mh-header-field-font-lock (field limit) - "Return the value of a header field FIELD to font-lock. -Argument LIMIT limits search." - (if (= (point) limit) - nil - (let* ((mail-header-end (mail-header-end)) - (lesser-limit (if (< mail-header-end limit) mail-header-end limit)) - (case-fold-search t)) - (when (and (< (point) mail-header-end) ;Only within header - (re-search-forward (format "^%s" field) lesser-limit t)) - (let ((match-one-b (match-beginning 0)) - (match-one-e (match-end 0))) - (mh-header-field-end) - (if (> (point) limit) ;Don't search for end beyond limit - (goto-char limit)) - (set-match-data (list match-one-b match-one-e - (1+ match-one-e) (point))) - t))))) - -(defun mh-header-to-font-lock (limit) - "Return the value of a header field To to font-lock. -Argument LIMIT limits search." - (mh-header-field-font-lock "To:" limit)) - -(defun mh-header-cc-font-lock (limit) - "Return the value of a header field cc to font-lock. -Argument LIMIT limits search." - (mh-header-field-font-lock "cc:" limit)) - -(defun mh-header-subject-font-lock (limit) - "Return the value of a header field Subject to font-lock. -Argument LIMIT limits search." - (mh-header-field-font-lock "Subject:" limit)) - -(eval-and-compile - ;; Otherwise byte-compilation fails on `mh-show-font-lock-keywords-with-cite' - (defvar mh-show-font-lock-keywords - '(("^\\(From:\\|Sender:\\)\\(.*\\)" (1 'default) (2 mh-show-from-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)) - ("^\\(Reply-To:\\|Return-Path:\\)\\(.*\\)$" - (1 'default) (2 mh-show-from-face)) - (mh-header-subject-font-lock (0 'default) (1 mh-show-subject-face)) - ("^\\(Apparently-To:\\|Newsgroups:\\)\\(.*\\)" - (1 'default) (2 mh-show-cc-face)) - ("^\\(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.")) - -(defvar mh-show-font-lock-keywords-with-cite - (eval-when-compile - (let* ((cite-chars "[>|}]") - (cite-prefix "A-Za-z") - (cite-suffix (concat cite-prefix "0-9_.@-`'\""))) - (append - mh-show-font-lock-keywords - (list - ;; Use MATCH-ANCHORED to effectively anchor the regexp left side. - `(,cite-chars - (,(concat "\\=[ \t]*" - "\\(\\([" cite-prefix "]+[" cite-suffix "]*\\)?" - "\\(" cite-chars "[ \t]*\\)\\)+" - "\\(.*\\)") - (beginning-of-line) (end-of-line) - (2 font-lock-constant-face nil t) - (4 font-lock-comment-face nil t))))))) - "Additional expressions to highlight in MH-show mode.") - -(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))) - (cond - ((and (< beg header-end)(< end header-end)) - (font-lock-default-fontify-region beg end loudly)) - ((and (< beg header-end)(>= end header-end)) - (font-lock-default-fontify-region beg header-end loudly)) - (t - nil)))) - -;; Needed to help shush the byte-compiler. -(if mh-xemacs-flag - (progn - (eval-and-compile - (require 'gnus) - (require 'gnus-art) - (require 'gnus-cite)))) - -(defun mh-gnus-article-highlight-citation () - "Highlight cited text in current buffer using gnus." - (interactive) - ;; Requiring gnus-cite should have been sufficient. However for Emacs21.1, - ;; recursive-load-depth-limit is only 10, so an error occurs. Also it may be - ;; better to have an autoload at top-level (though that won't work because - ;; of recursive-load-depth-limit). That gets rid of a compiler warning as - ;; well. - (unless mh-xemacs-flag - (require 'gnus-art) - (require 'gnus-cite)) - ;; Don't allow Gnus to create buttons while highlighting, maybe this is bad - ;; style? - (flet ((gnus-article-add-button (&rest args) nil)) - (let* ((modified (buffer-modified-p)) - (gnus-article-buffer (buffer-name)) - (gnus-cite-face-list `(,@(cdr gnus-cite-face-list) - ,(car gnus-cite-face-list)))) - (gnus-article-highlight-citation t) - (set-buffer-modified-p modified)))) - -;;; Internal bookkeeping variables: - -;; The value of `mh-folder-list-change-hook' is called whenever -;; mh-folder-list variable is set. -;; List of folder names for completion. -(defvar mh-folder-list nil) - -;; 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) - -;; Cached value of the `Unseen-Sequence:' component in the user's MH profile. -;; Name of the Unseen sequence. -(defvar mh-unseen-seq nil) - -;; Cached value of the `Previous-Sequence:' component in the user's MH -;; profile. -;; Name of the Previous sequence. -(defvar mh-previous-seq nil) - -;; 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) - -;; Name of MH-E scratch buffer. -(defconst mh-temp-buffer " *mh-temp*") - -;; Name of the MH-E folder list buffer. -(defconst mh-temp-folders-buffer "*Folders*") - -;; Name of the MH-E sequences list buffer. -(defconst mh-temp-sequences-buffer "*Sequences*") - -;; Window configuration before MH-E command. -(defvar mh-previous-window-config nil) - -;;Non-nil means next SPC or whatever goes to next undeleted message. -(defvar mh-page-to-next-msg-flag nil) - -;;; Internal variables local to a folder. - -;; Name of current folder, a string. -(defvar mh-current-folder nil) - -;; Buffer that displays message for this folder. -(defvar mh-show-buffer nil) - -;; Full path of directory for this folder. -(defvar mh-folder-filename nil) - -;;Number of msgs in buffer. -(defvar mh-msg-count nil) - -;; If non-nil, show the message in a separate window. -(defvar mh-showing-mode nil) - -(defvar mh-show-mode-map (make-sparse-keymap) - "Keymap used by the show buffer.") - -(defvar mh-show-folder-buffer nil - "Keeps track of folder whose message is being displayed.") - -;;; 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." - (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) - -;; 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) - - -;;; MH-E macros - -(defmacro with-mh-folder-updating (save-modification-flag &rest body) - "Format is (with-mh-folder-updating (SAVE-MODIFICATION-FLAG) &body BODY). -Execute BODY, which can modify the folder buffer without having to -worry about file locking or the read-only flag, and return its result. -If SAVE-MODIFICATION-FLAG is non-nil, the buffer's modification -flag is unchanged, otherwise it is cleared." - (setq save-modification-flag (car save-modification-flag)) ; CL style - `(prog1 - (let ((mh-folder-updating-mod-flag (buffer-modified-p)) - (buffer-read-only nil) - (buffer-file-name nil)) ;don't let the buffer get locked - (prog1 - (progn - ,@body) - (mh-set-folder-modified-p mh-folder-updating-mod-flag))) - ,@(if (not save-modification-flag) - '((mh-set-folder-modified-p nil))))) - -(put 'with-mh-folder-updating 'lisp-indent-hook 1) - -(defmacro mh-in-show-buffer (show-buffer &rest body) - "Format is (mh-in-show-buffer (SHOW-BUFFER) &body BODY). -Display buffer SHOW-BUFFER in other window and execute BODY in it. -Stronger than `save-excursion', weaker than `save-window-excursion'." - (setq show-buffer (car show-buffer)) ; CL style - `(let ((mh-in-show-buffer-saved-window (selected-window))) - (switch-to-buffer-other-window ,show-buffer) - (if mh-bury-show-buffer-flag (bury-buffer (current-buffer))) - (unwind-protect - (progn - ,@body) - (select-window mh-in-show-buffer-saved-window)))) - -(put 'mh-in-show-buffer 'lisp-indent-hook 1) - -(defmacro mh-make-seq (name msgs) - "Create sequence NAME with the given MSGS." - (list 'cons name msgs)) - -(defmacro mh-seq-name (sequence) - "Extract sequence name from the given SEQUENCE." - (list 'car sequence)) - -(defmacro mh-seq-msgs (sequence) - "Extract messages from the given SEQUENCE." - (list 'cdr sequence)) - -(defun mh-recenter (arg) - "Like recenter but with three improvements: -- At the end of the buffer it tries to show fewer empty lines. -- operates only if the current buffer is in the selected window. - (Commands like `save-some-buffers' can make this false.) -- nil ARG means recenter as if prefix argument had been given." - (cond ((not (eq (get-buffer-window (current-buffer)) (selected-window))) - nil) - ((= (point-max) (save-excursion - (forward-line (- (/ (window-height) 2) 2)) - (point))) - (let ((lines-from-end 2)) - (save-excursion - (while (> (point-max) (progn (forward-line) (point))) - (incf lines-from-end))) - (recenter (- lines-from-end)))) - ;; '(4) is the same as C-u prefix argument. - (t (recenter (or arg '(4)))))) - -(defun mh-start-of-uncleaned-message () - "Position uninteresting headers off the top of the window." - (let ((case-fold-search t)) - (re-search-forward - "^To:\\|^Cc:\\|^From:\\|^Subject:\\|^Date:" nil t) - (beginning-of-line) - (mh-recenter 0))) - -(defun mh-invalidate-show-buffer () - "Invalidate the show buffer so we must update it to use it." - (if (get-buffer mh-show-buffer) - (save-excursion - (set-buffer mh-show-buffer) - (mh-unvisit-file)))) - -(defun mh-unvisit-file () - "Separate current buffer from the message file it was visiting." - (or (not (buffer-modified-p)) - (null buffer-file-name) ;we've been here before - (yes-or-no-p (format "Message %s modified; flush changes? " - (file-name-nondirectory buffer-file-name))) - (error "Flushing changes not confirmed")) - (clear-visited-file-modtime) - (unlock-buffer) - (setq buffer-file-name nil)) - -;;;###mh-autoload -(defun mh-get-msg-num (error-if-no-message) - "Return the message number of the displayed message. -If the argument ERROR-IF-NO-MESSAGE is non-nil, then complain if the cursor is -not pointing to a message." - (save-excursion - (beginning-of-line) - (cond ((looking-at mh-scan-msg-number-regexp) - (string-to-int (buffer-substring (match-beginning 1) - (match-end 1)))) - (error-if-no-message - (error "Cursor not pointing to message")) - (t nil)))) - -(defun mh-folder-name-p (name) - "Return non-nil if NAME is the name of a folder. -A name (a string or symbol) can be a folder name if it begins with \"+\"." - (if (symbolp name) - (eq (aref (symbol-name name) 0) ?+) - (and (> (length name) 0) - (eq (aref name 0) ?+)))) - - -(defun mh-expand-file-name (filename &optional default) - "Expand FILENAME like `expand-file-name', but also handle MH folder names. -Any filename that starts with '+' is treated as a folder name. -See `expand-file-name' for description of DEFAULT." - (if (mh-folder-name-p filename) - (expand-file-name (substring filename 1) mh-user-path) - (expand-file-name filename default))) - - -(defun mh-msg-filename (msg &optional folder) - "Return the file name of MSG in FOLDER (default current folder)." - (expand-file-name (int-to-string msg) - (if folder - (mh-expand-file-name folder) - mh-folder-filename))) - -;;; Infrastructure to generate show-buffer functions from folder functions -;;; XEmacs does not have deactivate-mark? What is the equivalent of -;;; transient-mark-mode for XEmacs? Should we be restoring the mark in the -;;; folder buffer after the operation has been carried out. -(defmacro mh-defun-show-buffer (function original-function - &optional dont-return) - "Define FUNCTION to run ORIGINAL-FUNCTION in folder buffer. -If the buffer we start in is still visible and DONT-RETURN is nil then switch -to it after that." - `(defun ,function () - ,(format "Calls %s from the message's folder.\n%s\nSee `%s' for more info.\n" - original-function - (if dont-return "" - "When function completes, returns to the show buffer if it is -still visible.\n") - original-function) - (interactive) - (when (buffer-live-p (get-buffer mh-show-folder-buffer)) - (let ((config (current-window-configuration)) - (folder-buffer mh-show-folder-buffer) - (normal-exit nil) - ,@(if dont-return () '((cur-buffer-name (buffer-name))))) - (pop-to-buffer mh-show-folder-buffer nil) - (unless (equal (buffer-name - (window-buffer (frame-first-window (selected-frame)))) - folder-buffer) - (delete-other-windows)) - (mh-goto-cur-msg t) - (and (fboundp 'deactivate-mark) (deactivate-mark)) - (unwind-protect - (prog1 (call-interactively (function ,original-function)) - (setq normal-exit t)) - (and (fboundp 'deactivate-mark) (deactivate-mark)) - (cond ((not normal-exit) - (set-window-configuration config)) - ,(if dont-return - `(t (setq mh-previous-window-config config)) - `((and (get-buffer cur-buffer-name) - (window-live-p (get-buffer-window - (get-buffer cur-buffer-name)))) - (pop-to-buffer (get-buffer cur-buffer-name) nil))))))))) - -;;; Generate interactive functions for the show buffer from the corresponding -;;; folder functions. -(mh-defun-show-buffer mh-show-previous-undeleted-msg - mh-previous-undeleted-msg) -(mh-defun-show-buffer mh-show-next-undeleted-msg - mh-next-undeleted-msg) -(mh-defun-show-buffer mh-show-quit mh-quit) -(mh-defun-show-buffer mh-show-delete-msg mh-delete-msg) -(mh-defun-show-buffer mh-show-refile-msg mh-refile-msg) -(mh-defun-show-buffer mh-show-undo mh-undo) -(mh-defun-show-buffer mh-show-execute-commands mh-execute-commands) -(mh-defun-show-buffer mh-show-reply mh-reply t) -(mh-defun-show-buffer mh-show-redistribute mh-redistribute) -(mh-defun-show-buffer mh-show-forward mh-forward t) -(mh-defun-show-buffer mh-show-header-display mh-header-display) -(mh-defun-show-buffer mh-show-refile-or-write-again - mh-refile-or-write-again) -(mh-defun-show-buffer mh-show-show mh-show) -(mh-defun-show-buffer mh-show-write-message-to-file - mh-write-msg-to-file) -(mh-defun-show-buffer mh-show-extract-rejected-mail - mh-extract-rejected-mail t) -(mh-defun-show-buffer mh-show-delete-msg-no-motion - mh-delete-msg-no-motion) -(mh-defun-show-buffer mh-show-first-msg mh-first-msg) -(mh-defun-show-buffer mh-show-last-msg mh-last-msg) -(mh-defun-show-buffer mh-show-copy-msg mh-copy-msg) -(mh-defun-show-buffer mh-show-edit-again mh-edit-again t) -(mh-defun-show-buffer mh-show-goto-msg mh-goto-msg) -(mh-defun-show-buffer mh-show-inc-folder mh-inc-folder) -(mh-defun-show-buffer mh-show-delete-subject-or-thread - mh-delete-subject-or-thread) -(mh-defun-show-buffer mh-show-delete-subject mh-delete-subject) -(mh-defun-show-buffer mh-show-print-msg mh-print-msg) -(mh-defun-show-buffer mh-show-send mh-send t) -(mh-defun-show-buffer mh-show-toggle-showing mh-toggle-showing t) -(mh-defun-show-buffer mh-show-pipe-msg mh-pipe-msg t) -(mh-defun-show-buffer mh-show-sort-folder mh-sort-folder) -(mh-defun-show-buffer mh-show-visit-folder mh-visit-folder t) -(mh-defun-show-buffer mh-show-rescan-folder mh-rescan-folder) -(mh-defun-show-buffer mh-show-pack-folder mh-pack-folder) -(mh-defun-show-buffer mh-show-kill-folder mh-kill-folder t) -(mh-defun-show-buffer mh-show-list-folders mh-list-folders t) -(mh-defun-show-buffer mh-show-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) -(mh-defun-show-buffer mh-show-delete-seq mh-delete-seq) -(mh-defun-show-buffer mh-show-list-sequences mh-list-sequences) -(mh-defun-show-buffer mh-show-narrow-to-seq mh-narrow-to-seq) -(mh-defun-show-buffer mh-show-put-msg-in-seq mh-put-msg-in-seq) -(mh-defun-show-buffer mh-show-msg-is-in-seq mh-msg-is-in-seq) -(mh-defun-show-buffer mh-show-widen mh-widen) -(mh-defun-show-buffer mh-show-narrow-to-subject - mh-narrow-to-subject) -(mh-defun-show-buffer mh-show-store-msg mh-store-msg) -(mh-defun-show-buffer mh-show-page-digest mh-page-digest) -(mh-defun-show-buffer mh-show-page-digest-backwards - mh-page-digest-backwards) -(mh-defun-show-buffer mh-show-burst-digest mh-burst-digest) -(mh-defun-show-buffer mh-show-page-msg mh-page-msg) -(mh-defun-show-buffer mh-show-previous-page mh-previous-page) -(mh-defun-show-buffer mh-show-modify mh-modify t) -(mh-defun-show-buffer mh-show-next-button mh-next-button) -(mh-defun-show-buffer mh-show-prev-button mh-prev-button) -(mh-defun-show-buffer mh-show-toggle-mime-part mh-folder-toggle-mime-part) -(mh-defun-show-buffer mh-show-save-mime-part mh-folder-save-mime-part) -(mh-defun-show-buffer mh-show-inline-mime-part mh-folder-inline-mime-part) -(mh-defun-show-buffer mh-show-toggle-threads mh-toggle-threads) -(mh-defun-show-buffer mh-show-thread-delete mh-thread-delete) -(mh-defun-show-buffer mh-show-thread-refile mh-thread-refile) -(mh-defun-show-buffer mh-show-update-sequences mh-update-sequences) -(mh-defun-show-buffer mh-show-next-unread-msg mh-next-unread-msg) -(mh-defun-show-buffer mh-show-previous-unread-msg mh-previous-unread-msg) -(mh-defun-show-buffer mh-show-thread-ancestor mh-thread-ancestor) -(mh-defun-show-buffer mh-show-thread-next-sibling mh-thread-next-sibling) -(mh-defun-show-buffer mh-show-thread-previous-sibling - mh-thread-previous-sibling) -(mh-defun-show-buffer mh-show-index-visit-folder mh-index-visit-folder t) - -;;; Populate mh-show-mode-map -(gnus-define-keys mh-show-mode-map - " " mh-show-page-msg - "!" mh-show-refile-or-write-again - "," mh-show-header-display - "." mh-show-show - ">" mh-show-write-message-to-file - "?" mh-help - "E" mh-show-extract-rejected-mail - "M" mh-show-modify - "\177" mh-show-previous-page - "\C-d" mh-show-delete-msg-no-motion - "\t" mh-show-next-button - [backtab] mh-show-prev-button - "\M-\t" mh-show-prev-button - "\ed" mh-show-redistribute - "^" mh-show-refile-msg - "c" mh-show-copy-msg - "d" mh-show-delete-msg - "e" mh-show-edit-again - "f" mh-show-forward - "g" mh-show-goto-msg - "i" mh-show-inc-folder - "k" mh-show-delete-subject-or-thread - "l" mh-show-print-msg - "m" mh-show-send - "n" mh-show-next-undeleted-msg - "\M-n" mh-show-next-unread-msg - "o" mh-show-refile-msg - "p" mh-show-previous-undeleted-msg - "\M-p" mh-show-previous-unread-msg - "q" mh-show-quit - "r" mh-show-reply - "s" mh-show-send - "t" mh-show-toggle-showing - "u" mh-show-undo - "x" mh-show-execute-commands - "v" mh-show-index-visit-folder - "|" mh-show-pipe-msg) - -(gnus-define-keys (mh-show-folder-map "F" mh-show-mode-map) - "?" mh-prefix-help - "S" mh-show-sort-folder - "f" mh-show-visit-folder - "i" mh-index-search - "k" mh-show-kill-folder - "l" mh-show-list-folders - "o" mh-show-visit-folder - "r" mh-show-rescan-folder - "s" mh-show-search-folder - "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-prefix-help - "d" mh-show-delete-msg-from-seq - "k" mh-show-delete-seq - "l" mh-show-list-sequences - "n" mh-show-narrow-to-seq - "p" mh-show-put-msg-in-seq - "s" mh-show-msg-is-in-seq - "w" mh-show-widen) - -(gnus-define-keys (mh-show-thread-map "T" mh-show-mode-map) - "?" mh-prefix-help - "u" mh-show-thread-ancestor - "p" mh-show-thread-previous-sibling - "n" mh-show-thread-next-sibling - "t" mh-show-toggle-threads - "d" mh-show-thread-delete - "o" mh-show-thread-refile) - -(gnus-define-keys (mh-show-limit-map "/" mh-show-mode-map) - "?" mh-prefix-help - "s" mh-show-narrow-to-subject - "w" mh-show-widen) - -(gnus-define-keys (mh-show-extract-map "X" mh-show-mode-map) - "?" mh-prefix-help - "s" mh-show-store-msg - "u" mh-show-store-msg) - -;; Untested... -(gnus-define-keys (mh-show-digest-map "D" mh-show-mode-map) - "?" mh-prefix-help - " " mh-show-page-digest - "\177" mh-show-page-digest-backwards - "b" mh-show-burst-digest) - -(gnus-define-keys (mh-show-mime-map "K" mh-show-mode-map) - "?" mh-prefix-help - "a" mh-mime-save-parts - "v" mh-show-toggle-mime-part - "o" mh-show-save-mime-part - "i" mh-show-inline-mime-part - "\t" mh-show-next-button - [backtab] mh-show-prev-button - "\M-\t" mh-show-prev-button) - -(easy-menu-define - mh-show-sequence-menu mh-show-mode-map "Menu for MH-E folder-sequence." - '("Sequence" - ["Add Message to Sequence..." mh-show-put-msg-in-seq t] - ["List Sequences for Message" mh-show-msg-is-in-seq t] - ["Delete Message from Sequence..." mh-show-delete-msg-from-seq t] - ["List Sequences in Folder..." mh-show-list-sequences t] - ["Delete Sequence..." mh-show-delete-seq t] - ["Narrow to Sequence..." mh-show-narrow-to-seq t] - ["Widen from Sequence" mh-show-widen t] - "--" - ["Narrow to Subject Sequence" mh-show-narrow-to-subject t] - ["Delete Rest of Same Subject" mh-show-delete-subject t] - "--" - ["Push State Out to MH" mh-show-update-sequences t])) - -(easy-menu-define - mh-show-message-menu mh-show-mode-map "Menu for MH-E folder-message." - '("Message" - ["Show Message" mh-show-show t] - ["Show Message with Header" mh-show-header-display t] - ["Next Message" mh-show-next-undeleted-msg t] - ["Previous Message" mh-show-previous-undeleted-msg t] - ["Go to First Message" mh-show-first-msg t] - ["Go to Last Message" mh-show-last-msg t] - ["Go to Message by Number..." mh-show-goto-msg t] - ["Modify Message" mh-show-modify t] - ["Delete Message" mh-show-delete-msg t] - ["Refile Message" mh-show-refile-msg t] - ["Undo Delete/Refile" mh-show-undo t] - ["Process Delete/Refile" mh-show-execute-commands t] - "--" - ["Compose a New Message" mh-send t] - ["Reply to Message..." mh-show-reply t] - ["Forward Message..." mh-show-forward t] - ["Redistribute Message..." mh-show-redistribute t] - ["Edit Message Again" mh-show-edit-again t] - ["Re-edit a Bounced Message" mh-show-extract-rejected-mail t] - "--" - ["Copy Message to Folder..." mh-show-copy-msg t] - ["Print Message" mh-show-print-msg t] - ["Write Message to File..." mh-show-write-msg-to-file t] - ["Pipe Message to Command..." mh-show-pipe-msg t] - ["Unpack Uuencoded Message..." mh-show-store-msg t] - ["Burst Digest Message" mh-show-burst-digest t])) - -(easy-menu-define - mh-show-folder-menu mh-show-mode-map "Menu for MH-E folder." - '("Folder" - ["Incorporate New Mail" mh-show-inc-folder t] - ["Toggle Show/Folder" mh-show-toggle-showing t] - ["Execute Delete/Refile" mh-show-execute-commands t] - ["Rescan Folder" mh-show-rescan-folder t] - ["Thread Folder" mh-show-toggle-threads t] - ["Pack Folder" mh-show-pack-folder t] - ["Sort Folder" mh-show-sort-folder t] - "--" - ["List Folders" mh-show-list-folders t] - ["Visit a Folder..." mh-show-visit-folder t] - ["Search a Folder..." mh-show-search-folder t] - ["Indexed Search..." mh-index-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) - -(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." - (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) - (make-local-variable 'font-lock-defaults) - ;;(set (make-local-variable 'font-lock-support-mode) nil) - (cond - ((equal mh-highlight-citation-p 'font-lock) - (setq font-lock-defaults '(mh-show-font-lock-keywords-with-cite t))) - ((equal mh-highlight-citation-p 'gnus) - (setq font-lock-defaults '((mh-show-font-lock-keywords) - t nil nil nil - (font-lock-fontify-region-function - . mh-show-font-lock-fontify-region))) - (mh-gnus-article-highlight-citation)) - (t - (setq font-lock-defaults '(mh-show-font-lock-keywords t)))) - (if (and mh-xemacs-flag - font-lock-auto-fontify) - (turn-on-font-lock)) - (if (and (boundp 'tool-bar-mode) tool-bar-mode) - (set (make-local-variable 'tool-bar-map) mh-show-tool-bar-map)) - (when mh-decode-mime-flag - (add-hook 'kill-buffer-hook 'mh-mime-cleanup nil t)) - (easy-menu-add mh-show-sequence-menu) - (easy-menu-add mh-show-message-menu) - (easy-menu-add mh-show-folder-menu) - (make-local-variable 'mh-show-folder-buffer) - (buffer-disable-undo) - (setq buffer-read-only t) - (use-local-map mh-show-mode-map) - (run-hooks 'mh-show-mode-hook)) - -(defun mh-show-addr () - "Use `goto-address'." - (when mh-show-use-goto-addr-flag - (if (not (featurep 'goto-addr)) - (load "goto-addr" t t)) - (if (fboundp 'goto-address) - (goto-address)))) - -(defvar mh-show-xface-function - (cond ((and mh-xemacs-flag (locate-library "x-face")) - (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)) - (t #'ignore)) - "Determine at run time what function should be called to display X-Face.") - -(defun mh-show-xface () - "Display X-Face." - (when (and mh-show-use-xface-flag - (or mh-decode-mime-flag mhl-formfile - mh-clean-message-header-flag)) - (funcall mh-show-xface-function))) - -(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. - -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)) - (mh-show-msg message)) - -(defun mh-show-mouse (EVENT) - "Move point to mouse EVENT and show message." - (interactive "e") - (mouse-set-point EVENT) - (mh-show)) - -(defun mh-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." - (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) - (clean-message-header mh-clean-message-header-flag) - (show-window (get-buffer-window mh-show-buffer))) - (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) - (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)) - -(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. - -The message is displayed in raw form." - (interactive) - (let* ((message (or message (mh-get-msg-num t))) - (msg-filename (mh-msg-filename message)) - edit-buffer) - (when (not (file-exists-p msg-filename)) - (error "Message %d does not exist" message)) - - ;; Invalidate the show buffer if it is showing the same message that is - ;; to be edited. - (when (and (buffer-live-p (get-buffer mh-show-buffer)) - (equal (save-excursion (set-buffer mh-show-buffer) - buffer-file-name) - msg-filename)) - (mh-invalidate-show-buffer)) - - ;; Edit message - (find-file msg-filename) - (setq edit-buffer (current-buffer)) - - ;; Set buffer properties - (mh-letter-mode) - (use-local-map text-mode-map) - - ;; Just show the edit buffer... - (delete-other-windows) - (switch-to-buffer edit-buffer))) - -(defun mh-decode-quoted-printable () - "Run mimedecode on current buffer, replacing its contents." - (let ((case-fold-search t)) - (goto-char (point-min)) - (when (and (re-search-forward - "^content-transfer-encoding:[ \t]*quoted-printable" - (if mh-decode-mime-flag (mail-header-end) nil) t) - (search-forward "\n\n" nil t)) - (message "Converting quoted-printable characters...") - (let ((modified (buffer-modified-p)) - (command "mimedecode")) - (shell-command-on-region (point-min) (point-max) command t t) - (if (fboundp 'deactivate-mark) - (deactivate-mark)) - (set-buffer-modified-p modified)) - (message "Converting quoted-printable characters... done.")))) - -(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)) - (while (re-search-forward "^>From" nil t) - (replace-match "From")) - (set-buffer-modified-p modified)))) - -(defun mh-msg-folder (folder-name) - "Return the name of the buffer for FOLDER-NAME." - folder-name) - -(defun mh-display-msg (msg-num folder-name) - "Display MSG-NUM of FOLDER-NAME. -Sets the current buffer to the show buffer." - (let ((folder (mh-msg-folder folder-name))) - (set-buffer folder) - ;; When Gnus uses external displayers it has to keep handles longer. So - ;; we will delete these handles when mh-quit is called on the folder. It - ;; would be nicer if there are weak pointers in emacs lisp, then we could - ;; get the garbage collector to do this for us. - (unless (mh-buffer-data) - (setf (mh-buffer-data) (mh-make-buffer-data))) - ;; Bind variables in folder buffer in case they are local - (let ((formfile mhl-formfile) - (clean-message-header mh-clean-message-header-flag) - (invisible-headers mh-invisible-headers) - (visible-headers mh-visible-headers) - (msg-filename (mh-msg-filename msg-num folder-name)) - (show-buffer mh-show-buffer) - (mm-inline-media-tests mh-mm-inline-media-tests)) - (if (not (file-exists-p msg-filename)) - (error "Message %d does not exist" msg-num)) - (if (and (> mh-show-maximum-size 0) - (> (elt (file-attributes msg-filename) 7) - mh-show-maximum-size) - (not (y-or-n-p - (format - "Message %d (%d bytes) exceeds %d bytes. Display it? " - msg-num (elt (file-attributes msg-filename) 7) - mh-show-maximum-size)))) - (error "Message %d not displayed" msg-num)) - (set-buffer show-buffer) - (cond ((not (equal msg-filename buffer-file-name)) - (mh-unvisit-file) - (setq buffer-read-only nil) - (erase-buffer) - ;; Changing contents, so this hook needs to be reinitialized. - ;; pgp.el uses this. - (if (boundp 'write-contents-hooks) ;Emacs 19 - (kill-local-variable 'write-contents-hooks)) - (if formfile - (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear" - (if (stringp formfile) - (list "-form" formfile)) - msg-filename) - (insert-file-contents msg-filename)) - (if mh-decode-quoted-printable-flag - (mh-decode-quoted-printable)) - ;; 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)) - ;; Header cleanup - (goto-char (point-min)) - (cond (clean-message-header - (mh-clean-msg-header (point-min) - invisible-headers - visible-headers) - (goto-char (point-min))) - (t - (mh-start-of-uncleaned-message))) - ;; the parts of visiting we want to do (no locking) - (or (eq buffer-undo-list t) ;don't save undo info for prev msgs - (setq buffer-undo-list nil)) - (set-buffer-auto-saved) - ;; the parts of set-visited-file-name we want to do (no locking) - (setq buffer-file-name msg-filename) - (setq buffer-backed-up nil) - (auto-save-mode 1) - (set-mark nil) - (mh-show-mode) - (unwind-protect - (when (and mh-decode-mime-flag (not formfile)) - (setq buffer-read-only nil) - (mh-display-smileys) - (mh-display-emphasis)) - (setq buffer-read-only t)) - (set-buffer-modified-p nil) - (setq mh-show-folder-buffer folder) - (setq mode-line-buffer-identification - (list (format mh-show-buffer-mode-line-buffer-id - folder-name msg-num))) - (set-buffer folder) - (setq mh-showing-with-headers nil)))))) - -(defun mh-clean-msg-header (start invisible-headers visible-headers) - "Flush extraneous lines in message header. -Header is cleaned from START to the end of the message header. -INVISIBLE-HEADERS contains a regular expression specifying lines to delete -from the header. VISIBLE-HEADERS contains a regular expression specifying the -lines to display. INVISIBLE-HEADERS is ignored if VISIBLE-HEADERS is non-nil." - (let ((case-fold-search t) - (after-change-functions nil)) ;Work around emacs-20 font-lock bug - ;causing an endless loop. - (save-restriction - (goto-char start) - (if (search-forward "\n\n" nil 'move) - (backward-char 1)) - (narrow-to-region start (point)) - (goto-char (point-min)) - (if visible-headers - (while (< (point) (point-max)) - (cond ((looking-at visible-headers) - (forward-line 1) - (while (looking-at "[ \t]") (forward-line 1))) - (t - (mh-delete-line 1) - (while (looking-at "[ \t]") - (mh-delete-line 1))))) - (while (re-search-forward invisible-headers nil t) - (beginning-of-line) - (mh-delete-line 1) - (while (looking-at "[ \t]") - (mh-delete-line 1)))) - (unlock-buffer)))) - -(defun mh-delete-line (lines) - "Delete the next LINES lines." - (delete-region (point) (progn (forward-line lines) (point)))) - -(defun mh-notate (msg notation offset) - "Mark MSG with the character NOTATION at position OFFSET. -Null MSG means the message at cursor." - (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))) - -(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." - (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) - (goto-char point) - (unless no-error-if-no-message - (error "No message %d" number)) - (setq return-value nil)) - (beginning-of-line) - (or dont-show (not return-value) (mh-maybe-show number)) - return-value)) - -(defun mh-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))) - (and mh-auto-folder-collect-flag - (let ((mh-no-install t)) ;only get folders if MH installed - (condition-case err - (mh-make-folder-list-background) - (file-error))))) ;so don't complain if not installed - -(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)) - -(defun mh-find-seq (name) - "Return sequence NAME." - (assoc name mh-seq-list)) - -(defun mh-seq-to-msgs (seq) - "Return a list of the messages in SEQ." - (mh-seq-msgs (mh-find-seq seq))) - -(defun mh-update-scan-format (fmt width) - "Return a scan format with the (msg) width in the FMT replaced with WIDTH. - -The message number width portion of the format is discovered using -`mh-scan-msg-format-regexp'. Its replacement is controlled with -`mh-scan-msg-format-string'." - (or (and - (string-match mh-scan-msg-format-regexp fmt) - (let ((begin (match-beginning 1)) - (end (match-end 1))) - (concat (substring fmt 0 begin) - (format mh-scan-msg-format-string width) - (substring fmt end)))) - fmt)) - -(defun mh-message-number-width (folder) - "Return the widest message number in this FOLDER." - (or mh-progs (mh-find-path)) - (let ((tmp-buffer (get-buffer-create mh-temp-buffer)) - (width 0)) - (save-excursion - (set-buffer tmp-buffer) - (erase-buffer) - (apply 'call-process - (expand-file-name "scan" mh-progs) nil '(t nil) nil - (list folder "last" "-format" "%(msg)")) - (goto-char (point-min)) - (if (re-search-forward mh-scan-msg-number-regexp nil 0 1) - (setq width (length (buffer-substring - (match-beginning 1) (match-end 1)))))) - width)) - -(defun mh-add-msgs-to-seq (msgs seq &optional internal-flag) - "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." - (let ((entry (mh-find-seq seq))) - (if (and msgs (atom msgs)) (setq msgs (list msgs))) - (if (null entry) - (setq mh-seq-list - (cons (mh-make-seq seq (mh-canonicalize-sequence msgs)) - mh-seq-list)) - (if msgs (setcdr entry (mh-canonicalize-sequence - (append msgs (mh-seq-msgs entry)))))) - (cond ((not internal-flag) - (mh-add-to-sequence seq msgs) - (mh-notate-seq seq mh-note-seq (1+ mh-cmd-note)))))) - -(defun mh-canonicalize-sequence (msgs) - "Sort MSGS in decreasing order and remove duplicates." - (let* ((sorted-msgs (sort (copy-sequence msgs) '>)) - (head sorted-msgs)) - (while (cdr head) - (if (= (car head) (cadr head)) - (setcdr head (cddr head)) - (setq head (cdr head)))) - sorted-msgs)) - -(defvar mh-folder-hist nil) -(defvar mh-speed-folder-map) - -(defun mh-prompt-for-folder (prompt default can-create - &optional default-string) - "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. -The value of `mh-folder-list-change-hook' is a list of functions to be called, -with no arguments, whenever the cached folder list `mh-folder-list' is -changed." - (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)) - read-name folder-name) - (if (null mh-folder-list) - (mh-set-folder-list)) - (while (and (setq read-name (completing-read prompt mh-folder-list nil nil - "+" 'mh-folder-hist)) - (equal read-name "") - (equal default ""))) - (cond ((or (equal read-name "") (equal read-name "+")) - (setq read-name default)) - ((not (mh-folder-name-p read-name)) - (setq read-name (format "+%s" read-name)))) - (if (or (not read-name) (equal "" read-name)) - (error "No folder specified")) - (setq folder-name read-name) - (cond ((and (> (length folder-name) 0) - (eq (aref folder-name (1- (length folder-name))) ?/)) - (setq folder-name (substring folder-name 0 -1)))) - (let ((new-file-flag - (not (file-exists-p (mh-expand-file-name folder-name))))) - (cond ((and new-file-flag - (y-or-n-p - (format "Folder %s does not exist. Create it? " - folder-name))) - (message "Creating %s" folder-name) - (mh-exec-cmd-error nil "folder" folder-name) - (when (boundp 'mh-speed-folder-map) - (mh-speed-add-folder folder-name)) - (message "Creating %s...done" folder-name) - (setq mh-folder-list (cons (list read-name) mh-folder-list)) - (run-hooks 'mh-folder-list-change-hook)) - (new-file-flag - (error "Folder %s is not created" folder-name)) - ((not (file-directory-p (mh-expand-file-name folder-name))) - (error "\"%s\" is not a directory" - (mh-expand-file-name folder-name))) - ((and (null (assoc read-name mh-folder-list)) - (null (assoc (concat read-name "/") mh-folder-list))) - (setq mh-folder-list (cons (list read-name) mh-folder-list)) - (run-hooks 'mh-folder-list-change-hook)))) - folder-name)) - -(defvar mh-make-folder-list-process nil) ;The background process collecting - ;the folder list. - -(defvar mh-folder-list-temp nil) ;mh-folder-list as it is being built. - -(defvar mh-folder-list-partial-line "") ;Start of last incomplete line from - ;folder process. - -(defun mh-set-folder-list () - "Set `mh-folder-list' correctly. -A useful function for the command line or for when you need to -sync by hand. Format is in a form suitable for completing read. -The value of `mh-folder-list-change-hook' is a list of functions to be called, -with no arguments, once the list of folders has been created." - (message "Collecting folder names...") - (if (not mh-make-folder-list-process) - (mh-make-folder-list-background)) - (while (eq (process-status mh-make-folder-list-process) 'run) - (accept-process-output mh-make-folder-list-process)) - (setq mh-folder-list mh-folder-list-temp) - (run-hooks 'mh-folder-list-change-hook) - (setq mh-folder-list-temp nil) - (delete-process mh-make-folder-list-process) - (setq mh-make-folder-list-process nil) - (message "Collecting folder names...done")) - -(defun mh-make-folder-list-background () - "Start a background process to compute a list of the user's folders. -Call `mh-set-folder-list' to wait for the result." - (cond - ((not mh-make-folder-list-process) - (unless mh-inbox - (mh-find-path)) - (let ((process-connection-type nil)) - (setq mh-make-folder-list-process - (start-process "folders" nil (expand-file-name "folders" mh-progs) - "-fast" - (if mh-recursive-folders-flag - "-recurse" - "-norecurse"))) - (set-process-filter mh-make-folder-list-process - 'mh-make-folder-list-filter) - (process-kill-without-query mh-make-folder-list-process))))) - -(defun mh-make-folder-list-filter (process output) - "Given the PROCESS \"folders -fast\", parse OUTPUT. -See also `set-process-filter'." - (let ((position 0) - line-end - new-folder - (prevailing-match-data (match-data))) - (unwind-protect - ;; make sure got complete line - (while (setq line-end (string-match "\n" output position)) - (setq new-folder (format "+%s%s" - mh-folder-list-partial-line - (substring output position line-end))) - (setq mh-folder-list-partial-line "") - ;; is new folder a subfolder of previous? - (if (and mh-folder-list-temp - (string-match - (regexp-quote - (concat (car (car mh-folder-list-temp)) "/")) - new-folder)) - ;; append slash to parent folder for better completion - ;; (undone by mh-prompt-for-folder) - (setq mh-folder-list-temp - (cons - (list new-folder) - (cons - (list (concat (car (car mh-folder-list-temp)) "/")) - (cdr mh-folder-list-temp)))) - (setq mh-folder-list-temp - (cons (list new-folder) - mh-folder-list-temp))) - (setq position (1+ line-end))) - (set-match-data prevailing-match-data)) - (setq mh-folder-list-partial-line (substring output position)))) - -;;; 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-temp-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-temp-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 &rest args) - "Execute MH command COMMAND with ARGS in the background. -Any output from command is displayed in an asynchronous pop-up window." - (save-excursion - (set-buffer (get-buffer-create mh-temp-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 'mh-process-daemon))) - -(defun mh-process-daemon (process output) - "PROCESS daemon that puts OUTPUT into a temporary buffer." - (set-buffer (get-buffer-create mh-temp-buffer)) - (insert-before-markers output) - (display-buffer mh-temp-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))))))) - -(defun mh-list-to-string (l) - "Flatten the list L and make every element of the new list into a string." - (nreverse (mh-list-to-string-1 l))) - -(defun mh-list-to-string-1 (l) - "Flatten the list L and make every element of the new list into a string." - (let ((new-list nil)) - (while l - (cond ((null (car l))) - ((symbolp (car l)) - (setq new-list (cons (symbol-name (car l)) new-list))) - ((numberp (car l)) - (setq new-list (cons (int-to-string (car l)) new-list))) - ((equal (car l) "")) - ((stringp (car l)) (setq new-list (cons (car l) new-list))) - ((listp (car l)) - (setq new-list (nconc (mh-list-to-string-1 (car l)) - new-list))) - (t (error "Bad element in mh-list-to-string: %s" (car l)))) - (setq l (cdr l))) - new-list)) - -(provide 'mh-utils) - -;;; Local Variables: -;;; indent-tabs-mode: nil -;;; sentence-end-double-space: nil -;;; End: - -;;; mh-utils.el ends here
--- a/lisp/mail/mh-xemacs-compat.el Sun Jan 26 01:33:33 2003 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,62 +0,0 @@ -;;; mh-xemacs-compat.el --- GNU Emacs Functions needed by XEmacs - -;; Copyright (C) 2001, 2002 Free Software Foundation, Inc. - -;; Author: FSF -;; Maintainer: Bill Wohler <wohler@newt.com> -;; Keywords: mail -;; See: mh-e.el - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;;; Change Log: - -;; $Id: mh-xemacs-compat.el,v 1.13 2002/11/30 01:21:42 wohler Exp $ - -;;; Code: - -;;; Some requires: -(require 'rfc822) - -;;; Simple compatibility: - -(unless (fboundp 'match-string-no-properties) - (defsubst match-string-no-properties (match) - (buffer-substring-no-properties - (match-beginning match) (match-end match)))) - -(unless (fboundp 'line-beginning-position) - (defalias 'line-beginning-position 'point-at-bol)) -(unless (fboundp 'line-end-position) - (defalias 'line-end-position 'point-at-eol)) - -(unless (fboundp 'timerp) - (defalias 'timerp 'itimerp)) -(unless (fboundp 'cancel-timer) - (defalias 'cancel-timer 'delete-itimer)) - -(provide 'mh-xemacs-compat) - -;;; Local Variables: -;;; indent-tabs-mode: nil -;;; sentence-end-double-space: nil -;;; End: - -;;; mh-xemacs-compat.el ends here
--- a/lisp/makefile.nt Sun Jan 26 01:33:33 2003 +0000 +++ b/lisp/makefile.nt Sun Jan 26 02:38:37 2003 +0000 @@ -124,6 +124,7 @@ international \ language \ mail \ + mh-e \ net \ play \ progmodes \
--- a/lisp/makefile.w32-in Sun Jan 26 01:33:33 2003 +0000 +++ b/lisp/makefile.w32-in Sun Jan 26 02:38:37 2003 +0000 @@ -150,6 +150,7 @@ international \ language \ mail \ + mh-e \ net \ obsolete \ play \
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mh-e/mh-alias.el Sun Jan 26 02:38:37 2003 +0000 @@ -0,0 +1,590 @@ +;;; mh-alias.el --- MH-E mail alias completion and expansion +;; +;; Copyright (C) 1994, 1995, 1996, 1997, 2001, 2002 Free Software Foundation, Inc. + +;; Author: Peter S. Galbraith <psg@debian.org> +;; Maintainer: Bill Wohler <wohler@newt.com> +;; Keywords: mail +;; See: mh-e.el + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; [To be deleted when documented in MH-E manual.] +;; +;; This module provides mail alias completion when entering addresses. +;; +;; Use the TAB key to complete aliases (and optionally local usernames) when +;; initially composing a message in the To: and Cc: minibuffer prompts. You +;; may enter multiple addressees separated with a comma (but do *not* add any +;; space after the comma). +;; +;; In the header of a message draft, use "M-TAB (mh-letter-complete)" to +;; complete aliases. This is useful when you want to add an addressee as an +;; afterthought when creating a message, or when adding an additional +;; addressee to a reply. +;; +;; By default, completion is case-insensitive. This can be changed by +;; customizing the variable `mh-alias-completion-ignore-case-flag'. This is +;; useful, for example, to differentiate between people aliases in lowercase +;; such as: +;; +;; p.galbraith: Peter Galbraith <GalbraithP@dfo-mpo.gc.ca> +;; +;; and lists in uppercase such as: +;; +;; MH-E: MH-E mailing list <mh-e-devel@lists.sourceforge.net> +;; +;; Note that this variable affects minibuffer completion only. If you have an +;; alias for P.Galbraith and type in p.galbraith at the prompt, it will still +;; be expanded in the letter buffer because MH is case-insensitive. +;; +;; When you press ", (mh-alias-minibuffer-confirm-address)" after an alias in +;; the minibuffer, the expansion for the previous mail alias appears briefly. +;; To inhibit this, customize the variable `mh-alias-flash-on-comma'. +;; +;; The addresses and aliases entered in the minibuffer are added to the +;; message draft. To expand the aliases before they are added to the draft, +;; customize the variable `mh-alias-expand-aliases-flag'. +;; +;; Completion is also performed on usernames extracted from the /etc/passwd +;; file. This can be a handy tool on a machine where you and co-workers +;; exchange messages, but should probably be disabled on a system with +;; thousands of users you don't know. This is done by customizing the +;; variable `mh-alias-local-users'. This variable also takes a string which +;; is executed to generate the password file. For example, you'd use "ypcat +;; passwd" for NIS. +;; +;; Aliases are loaded the first time you send mail and get the "To:" prompt +;; and whenever a source of aliases changes. Sources of system aliases are +;; defined in the customization variable `mh-alias-system-aliases' and +;; include: +;; +;; /etc/nmh/MailAliases +;; /usr/lib/mh/MailAliases +;; /etc/passwd +;; +;; Sources of personal aliases are read from the files listed in your MH +;; profile component Aliasfile. Multiple files are separated by white space +;; and are relative to your mail directory. +;; +;; Alias Insertions +;; ~~~~~~~~~~~~~~~~ +;; There are commands to insert new aliases into your alias file(s) (defined +;; by the `Aliasfile' component in the .mh_profile file or by the variable +;; `mh-alias-insert-file'). In particular, there is a tool-bar icon to grab +;; an alias from the From line of the current message. + +;;; Code: + +(require 'mh-e) +(load "cmr" t t) ; Non-fatal dependency for + ; completing-read-multiple. +(eval-when-compile (defvar mail-abbrev-syntax-table)) + +;;; Autoloads +(autoload 'mail-abbrev-complete-alias "mailabbrev") +(autoload 'multi-prompt "multi-prompt") + +(defvar mh-alias-alist nil + "Alist of MH aliases.") +(defvar mh-alias-blind-alist nil + "Alist of MH aliases that are blind lists.") +(defvar mh-alias-passwd-alist nil + "Alist of aliases extracted from passwd file and their expansions.") +(defvar mh-alias-tstamp nil + "Time aliases were last loaded.") +(defvar mh-alias-read-address-map nil) +(if mh-alias-read-address-map + () + (setq mh-alias-read-address-map + (copy-keymap minibuffer-local-completion-map)) + (if mh-alias-flash-on-comma + (define-key mh-alias-read-address-map + "," 'mh-alias-minibuffer-confirm-address)) + (define-key mh-alias-read-address-map " " 'self-insert-command)) + + +;;; Alias Loading + +(defun mh-alias-tstamp (arg) + "Check whether alias files have been modified. +Return t if any file listed in the MH profile component Aliasfile has been +modified since the timestamp. +If ARG is non-nil, set timestamp with the current time." + (if arg + (let ((time (current-time))) + (setq mh-alias-tstamp (list (nth 0 time) (nth 1 time)))) + (let ((stamp)) + (car (memq t (mapcar + (function + (lambda (file) + (when (and file (file-exists-p file)) + (setq stamp (nth 5 (file-attributes file))) + (or (> (car stamp) (car mh-alias-tstamp)) + (and (= (car stamp) (car mh-alias-tstamp)) + (> (cadr stamp) (cadr mh-alias-tstamp))))))) + (mh-alias-filenames t))))))) + +(defun mh-alias-filenames (arg) + "Return list of filenames that contain aliases. +The filenames come from the MH profile component Aliasfile and are expanded. +If ARG is non-nil, filenames listed in `mh-alias-system-aliases' are appended." + (or mh-progs (mh-find-path)) + (save-excursion + (let* ((filename (mh-profile-component "Aliasfile")) + (filelist (and filename (split-string filename "[ \t]+"))) + (userlist + (mapcar + (function + (lambda (file) + (if (and mh-user-path file + (file-exists-p (expand-file-name file mh-user-path))) + (expand-file-name file mh-user-path)))) + filelist))) + (if arg + (if (stringp mh-alias-system-aliases) + (append userlist (list mh-alias-system-aliases)) + (append userlist mh-alias-system-aliases)) + userlist)))) + +(defun mh-alias-local-users () + "Return an alist of local users from /etc/passwd." + (let (passwd-alist) + (save-excursion + (set-buffer (get-buffer-create mh-temp-buffer)) + (erase-buffer) + (cond + ((eq mh-alias-local-users t) + (if (file-readable-p "/etc/passwd") + (insert-file-contents "/etc/passwd"))) + ((stringp mh-alias-local-users) + (insert mh-alias-local-users "\n") + (shell-command-on-region (point-min)(point-max) mh-alias-local-users t) + (goto-char (point-min)))) + (while (< (point) (point-max)) + (cond + ((looking-at "\\([^:]*\\):[^:]*:\\([^:]*\\):[^:]*:\\([^:,]*\\)[:,]") + (when (> (string-to-int (match-string 2)) 200) + (let* ((username (match-string 1)) + (gecos-name (match-string 3)) + (realname + (if (string-match "&" gecos-name) + (concat + (substring gecos-name 0 (match-beginning 0)) + (capitalize username) + (substring gecos-name (match-end 0))) + gecos-name))) + (setq passwd-alist + (cons (list username + (if (string-equal "" realname) + (concat "<" username ">") + (concat realname " <" username ">"))) + passwd-alist)))))) + (forward-line 1))) + passwd-alist)) + +;;;###mh-autoload +(defun mh-alias-reload () + "Load MH aliases into `mh-alias-alist'." + (interactive) + (save-excursion + (message "Loading MH aliases...") + (mh-alias-tstamp t) + (mh-exec-cmd-quiet t "ali" "-nolist" "-nouser") + (setq mh-alias-alist nil) + (setq mh-alias-blind-alist nil) + (while (< (point) (point-max)) + (cond + ((looking-at "^[ \t]")) ;Continuation line + ((looking-at "\\(.+\\): .+: .*$") ; A new -blind- MH alias + (when (not (assoc-ignore-case (match-string 1) mh-alias-blind-alist)) + (setq mh-alias-blind-alist + (cons (list (match-string 1)) mh-alias-blind-alist)) + (setq mh-alias-alist (cons (list (match-string 1)) mh-alias-alist)))) + ((looking-at "\\(.+\\): .*$") ; A new MH alias + (when (not (assoc-ignore-case (match-string 1) mh-alias-alist)) + (setq mh-alias-alist + (cons (list (match-string 1)) mh-alias-alist))))) + (forward-line 1))) + (when mh-alias-local-users + (setq mh-alias-passwd-alist (mh-alias-local-users)) + ;; Update aliases with local users, but leave existing aliases alone. + (let ((local-users mh-alias-passwd-alist) + user) + (while local-users + (setq user (car local-users)) + (if (not (assoc-ignore-case (car user) mh-alias-alist)) + (setq mh-alias-alist (append mh-alias-alist (list user)))) + (setq local-users (cdr local-users))))) + (message "Loading MH aliases...done")) + +(defun mh-alias-reload-maybe () + "Load new MH aliases." + (if (or (not mh-alias-alist) ; Doesn't exist, so create it. + (mh-alias-tstamp nil)) ; Out of date, so recreate it. + (mh-alias-reload))) + + +;;; Alias Expansion + +(defun mh-alias-ali (alias &optional user) + "Return ali expansion for ALIAS. +ALIAS must be a string for a single alias. +If USER is t, then assume ALIAS is an address and call ali -user. +ali returns the string unchanged if not defined. The same is done here." + (save-excursion + (let ((user-arg (if user "-user" "-nouser"))) + (mh-exec-cmd-quiet t "ali" user-arg "-nolist" alias)) + (goto-char (point-max)) + (if (looking-at "^$") (delete-backward-char 1)) + (buffer-substring (point-min)(point-max)))) + +(defun mh-alias-expand (alias) + "Return expansion for ALIAS. +Blind aliases or users from /etc/passwd are not expanded." + (cond + ((assoc-ignore-case alias mh-alias-blind-alist) + alias) ; Don't expand a blind alias + ((assoc-ignore-case alias mh-alias-passwd-alist) + (cadr (assoc-ignore-case alias mh-alias-passwd-alist))) + (t + (mh-alias-ali alias)))) + +;;;###mh-autoload +(defun mh-read-address (prompt) + "Read an address from the minibuffer with PROMPT." + (mh-alias-reload-maybe) + (if (not mh-alias-alist) ; If still no aliases, just prompt + (read-string prompt) + (let* ((minibuffer-local-completion-map mh-alias-read-address-map) + (completion-ignore-case mh-alias-completion-ignore-case-flag) + (the-answer + (or (cond + ((fboundp 'completing-read-multiple) + (completing-read-multiple prompt mh-alias-alist nil nil)) + ((featurep 'multi-prompt) + (multi-prompt "," nil prompt mh-alias-alist nil nil)) + (t + (split-string + (completing-read "To: " mh-alias-alist nil nil) + ",")))))) + (if (not mh-alias-expand-aliases-flag) + (mapconcat 'identity the-answer ", ") + ;; Loop over all elements, checking if in passwd aliast or blind first + (mapconcat 'mh-alias-expand the-answer ",\n "))))) + +;;;###mh-autoload +(defun mh-alias-minibuffer-confirm-address () + "Display the alias expansion if `mh-alias-flash-on-comma' is non-nil." + (interactive) + (if (not mh-alias-flash-on-comma) + () + (save-excursion + (let* ((case-fold-search t) + (the-name (buffer-substring + (progn (skip-chars-backward " \t")(point)) + ;; This moves over to previous comma, if any + (progn (or (and (not (= 0 (skip-chars-backward "^,"))) + ;; the skips over leading whitespace + (skip-chars-forward " ")) + ;; no comma, then to beginning of word + (skip-chars-backward "^ \t")) + ;; In Emacs21, the beginning of the prompt + ;; line is accessible, which wasn't the case + ;; in emacs20. Skip over it. + (if (looking-at "^[^ \t]+:") + (skip-chars-forward "^ \t")) + (skip-chars-forward " ") + (point))))) + (if (assoc-ignore-case the-name mh-alias-alist) + (message "%s -> %s" the-name (mh-alias-expand the-name)) + ;; Check if if was a single word likely to be an alias + (if (and (equal mh-alias-flash-on-comma 1) + (not (string-match " " the-name))) + (message "No alias for %s" the-name)))))) + (self-insert-command 1)) + +;;;###mh-autoload +(defun mh-alias-letter-expand-alias () + "Expand mail alias before point." + (mh-alias-reload-maybe) + (let ((mail-abbrevs mh-alias-alist)) + (mail-abbrev-complete-alias)) + (when mh-alias-expand-aliases-flag + (let* ((end (point)) + (syntax-table (syntax-table)) + (beg (unwind-protect + (save-excursion + (set-syntax-table mail-abbrev-syntax-table) + (backward-word 1) + (point)) + (set-syntax-table syntax-table))) + (alias (buffer-substring beg end)) + (expansion (mh-alias-expand alias))) + (delete-region beg end) + (insert expansion)))) + +;;; Adding addresses to alias file. + +(defun mh-alias-suggest-alias (string) + "Suggest an alias for STRING." + (cond + ((string-match "^\\sw+$" string) + ;; One word -> downcase it. + (downcase string)) + ((string-match "^\\(\\sw+\\)\\s-+\\(\\sw+\\)$" string) + ;; Two words -> first.last + (downcase + (format "%s.%s" (match-string 1 string) (match-string 2 string)))) + ((string-match "^\\([-a-zA-Z0-9._]+\\)@[-a-zA-z0-9_]+\\.+[a-zA-Z0-9]+$" + string) + ;; email only -> downcase username + (downcase (match-string 1 string))) + ((string-match "^\"\\(.*\\)\".*" string) + ;; "Some name" <somename@foo.bar> -> recurse -> "Some name" + (mh-alias-suggest-alias (match-string 1 string))) + ((string-match "^\\(.*\\) +<.*>$" string) + ;; Some name <somename@foo.bar> -> recurse -> Some name + (mh-alias-suggest-alias (match-string 1 string))) + ((string-match (concat mh-address-mail-regexp " +(\\(.*\\))$") string) + ;; somename@foo.bar (Some name) -> recurse -> Some name + (mh-alias-suggest-alias (match-string 1 string))) + ((string-match "^\\(Dr\\|Prof\\)\\.? +\\(.*\\)" string) + ;; Strip out title + (mh-alias-suggest-alias (match-string 2 string))) + ((string-match "^\\(.*\\), +\\(Jr\\.?\\|II+\\)$" string) + ;; Strip out tails with comma + (mh-alias-suggest-alias (match-string 1 string))) + ((string-match "^\\(.*\\) +\\(Jr\\.?\\|II+\\)$" string) + ;; Strip out tails + (mh-alias-suggest-alias (match-string 1 string))) + ((string-match "^\\(\\sw+\\) +[A-Z]\\.? +\\(.*\\)$" string) + ;; Strip out initials + (mh-alias-suggest-alias + (format "%s %s" (match-string 1 string) (match-string 2 string)))) + ((string-match "^\\([^,]+\\), +\\(.*\\)$" string) + ;; Reverse order of comma-separated fields + (mh-alias-suggest-alias + (format "%s %s" (match-string 2 string) (match-string 1 string)))) + (t + ;; Output string, with spaces replaced by dots. + (downcase (replace-regexp-in-string + "\\.\\.+" "." + (replace-regexp-in-string " +" "." string)))))) + +(defun mh-alias-which-file-has-alias (alias file-list) + "Return the name of writable file which defines ALIAS from list FILE-LIST." + (save-excursion + (set-buffer (get-buffer-create mh-temp-buffer)) + (let ((the-list file-list) + (found)) + (while the-list + (erase-buffer) + (when (file-writable-p (car file-list)) + (insert-file-contents (car file-list)) + (if (re-search-forward (concat "^" (regexp-quote alias) ":")) + (setq found (car file-list) + the-list nil) + (setq the-list (cdr the-list))))) + found))) + +(defun mh-alias-insert-file (&optional alias) + "Return the alias file to write a new entry for ALIAS in. +Use variable `mh-alias-insert-file' if non-nil, else use AliasFile component +value. +If ALIAS is specified and it already exists, try to return the file that +contains it." + (cond + ((and mh-alias-insert-file (listp mh-alias-insert-file)) + (if (not (elt mh-alias-insert-file 1)) ; Only one entry, use it + (car mh-alias-insert-file) + (if (or (not alias) + (string-equal alias (mh-alias-ali alias))) ;alias doesn't exist + (completing-read "Alias file [press Tab]: " + (mapcar 'list mh-alias-insert-file) nil t) + (or (mh-alias-which-file-has-alias alias mh-alias-insert-file) + (completing-read "Alias file [press Tab]: " + (mapcar 'list mh-alias-insert-file) nil t))))) + ((and mh-alias-insert-file (stringp mh-alias-insert-file)) + mh-alias-insert-file) + (t + ;; writable ones returned from (mh-alias-filenames): + (let ((autolist (delq nil (mapcar (lambda (file) + (if (and (file-writable-p file) + (not (string-equal + file "/etc/passwd"))) + file)) + (mh-alias-filenames t))))) + (cond + ((not autolist) + (error "No writable alias file. +Set `mh-alias-insert-file' or set AliasFile in your .mh_profile file")) + ((not (elt autolist 1)) ; Only one entry, use it + (car autolist)) + ((or (not alias) + (string-equal alias (mh-alias-ali alias))) ;alias doesn't exist + (completing-read "Alias file [press Tab]: " + (mapcar 'list autolist) nil t)) + (t + (or (mh-alias-which-file-has-alias alias autolist) + (completing-read "Alias file [press Tab]: " + (mapcar 'list autolist) nil t)))))))) + +(defun mh-alias-address-to-alias (address) + "Return the ADDRESS alias if defined, or nil." + (let* ((aliases (mh-alias-ali address t))) + (if (string-equal aliases address) + nil ; ali returned same string -> no. + ;; For the comma-separated aliases reyurned by ali, check that one of + ;; them doesn't expand into a list. e.g. we do have an individual + ;; alias for that adress. + (car (delq nil (mapcar + (function + (lambda (alias) + (let ((recurse (mh-alias-ali alias nil))) + (if (string-match ".*,.*" recurse) + nil + alias)))) + (split-string aliases ", +"))))))) + +;;;###mh-autoload +(defun mh-alias-from-has-no-alias-p () + "Return t is From has no current alias set." + (mh-alias-reload-maybe) + (save-excursion + (if (not (mh-folder-line-matches-show-buffer-p)) + nil ;No corresponding show buffer + (if (eq major-mode 'mh-folder-mode) + (set-buffer mh-show-buffer)) + (not (mh-alias-address-to-alias (mh-extract-from-header-value)))))) + +(defun mh-alias-add-alias-to-file (alias address &optional file) + "Add ALIAS for ADDRESS in alias FILE without alias check or prompts. +Prompt for alias file if not provided and there is more than one candidate. +If ALIAS matches exactly, prompt to [i]nsert before old value or [a]ppend +after it." + (if (not file) + (setq file (mh-alias-insert-file alias))) + (save-excursion + (set-buffer (find-file-noselect file)) + (goto-char (point-min)) + (let ((alias-search (concat alias ":")) + (letter) + (here (point)) + (case-fold-search t)) + (cond + ;; Search for exact match (if we had the same alias before) + ((re-search-forward + (concat "^" (regexp-quote alias-search) " *\\(.*\\)") nil t) + (let ((answer (read-string + (format "Exists for %s; [i]nsert, [a]ppend: " + (match-string 1)))) + (case-fold-search t)) + (cond ((string-match "^i" answer)) + ((string-match "^a" answer) + (forward-line 1)) + (t + error "Quitting.")))) + ;; No, so sort-in at the right place + ;; search for "^alias", then "^alia", etc. + ((eq mh-alias-insertion-location 'sorted) + (setq letter (substring alias-search -1) + alias-search (substring alias-search 0 -1)) + (while (and (not (equal alias-search "")) + (not (re-search-forward + (concat "^" (regexp-quote alias-search)) nil t))) + (setq letter (substring alias-search -1) + alias-search (substring alias-search 0 -1))) + ;; Next, move forward to sort alphabetically for following letters + (beginning-of-line) + (while (re-search-forward + (concat "^" (regexp-quote alias-search) "[a-" letter "]") + nil t) + (forward-line 1))) + ((eq mh-alias-insertion-location 'bottom) + (goto-char (point-max))) + ((eq mh-alias-insertion-location 'top) + (goto-char (point-min))))) + (beginning-of-line) + (insert (format "%s: %s\n" alias address)) + (save-buffer))) + +;;;###mh-autoload +(defun mh-alias-add-alias (alias address) + "*Add ALIAS for ADDRESS in personal alias file. +Prompts for confirmation if the address already has an alias. +If the alias is already is use, `mh-alias-add-alias-to-file' will prompt." + (interactive "P\nP") + (mh-alias-reload-maybe) + (setq alias (completing-read "Alias: " mh-alias-alist nil nil alias)) + (setq address (read-string "Address: " address)) + (let ((address-alias (mh-alias-address-to-alias address)) + (alias-address (mh-alias-expand alias))) + (if (string-equal alias-address alias) + (setq alias-address nil)) + (cond + ((and (equal alias address-alias) + (equal address alias-address)) + (message "Already defined as: %s" alias-address)) + (address-alias + (if (y-or-n-p (format "Address has alias %s; set new one? " + address-alias)) + (mh-alias-add-alias-to-file alias address))) + (t + (mh-alias-add-alias-to-file alias address))))) + +;;;###mh-autoload +(defun mh-alias-grab-from-field () + "*Add ALIAS for ADDRESS in personal alias file. +Prompts for confirmation if the alias is already in use or if the address +already has an alias." + (interactive) + (mh-alias-reload-maybe) + (save-excursion + (cond + ((mh-folder-line-matches-show-buffer-p) + (set-buffer mh-show-buffer)) + ((and (eq major-mode 'mh-folder-mode) + (mh-get-msg-num nil)) + (set-buffer (get-buffer-create mh-temp-buffer)) + (insert-file-contents (mh-msg-filename (mh-get-msg-num t)))) + ((eq major-mode 'mh-folder-mode) + (error "Cursor not pointing to a message"))) + (let* ((address (mh-extract-from-header-value)) + (alias (mh-alias-suggest-alias address))) + (mh-alias-add-alias alias address)))) + +;;;###mh-autoload +(defun mh-alias-add-address-under-point () + "Insert an alias for email address under point." + (interactive) + (let ((address (mh-goto-address-find-address-at-point))) + (if address + (mh-alias-add-alias nil address) + (message "No email address found under point.")))) + +(provide 'mh-alias) + +;;; Local Variables: +;;; indent-tabs-mode: nil +;;; sentence-end-double-space: nil +;;; End: + +;;; mh-alias.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mh-e/mh-comp.el Sun Jan 26 02:38:37 2003 +0000 @@ -0,0 +1,1525 @@ +;;; mh-comp.el --- MH-E functions for composing messages + +;; Copyright (C) 1993,1995,1997,2000,2001,2002 Free Software Foundation, Inc. + +;; Author: Bill Wohler <wohler@newt.com> +;; Maintainer: Bill Wohler <wohler@newt.com> +;; Keywords: mail +;; See: mh-e.el + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Internal support for MH-E package. + +;;; Change Log: + +;; $Id: mh-comp.el,v 1.26 2003/01/08 23:21:16 wohler Exp $ + +;;; Code: + +(require 'mh-e) +(require 'gnus-util) +(require 'easymenu) +(require 'cl) + +;; Shush the byte-compiler +(defvar adaptive-fill-first-line-regexp) +(defvar font-lock-defaults) +(defvar mark-active) +(defvar sendmail-coding-system) +(defvar mh-identity-list) +(defvar mh-identity-default) +(defvar mh-identity-menu) + +;;; Autoloads +(autoload 'Info-goto-node "info") +(autoload 'mail-mode-fill-paragraph "sendmail") +(autoload 'mm-handle-displayed-p "mm-decode") + +(autoload 'sc-cite-original "sc" + "Workhorse citing function which performs the initial citation. +This is callable from the various mail and news readers' reply +function according to the agreed upon standard. See `\\[sc-describe]' +for more details. `sc-cite-original' does not do any yanking of the +original message but it does require a few things: + + 1) The reply buffer is the current buffer. + + 2) The original message has been yanked and inserted into the + reply buffer. + + 3) Verbose mail headers from the original message have been + inserted into the reply buffer directly before the text of the + original message. + + 4) Point is at the beginning of the verbose headers. + + 5) Mark is at the end of the body of text to be cited. + +For Emacs 19's, the region need not be active (and typically isn't +when this function is called. Also, the hook `sc-pre-hook' is run +before, and `sc-post-hook' is run after the guts of this function.") + +;;; Site customization (see also mh-utils.el): + +(defvar mh-send-prog "send" + "Name of the MH send program. +Some sites need to change this because of a name conflict.") + +(defvar mh-redist-full-contents nil + "Non-nil if the `dist' command needs whole letter for redistribution. +This is the case only when `send' is compiled with the BERK option. +If MH will not allow you to redist a previously redist'd msg, set to nil.") + +(defvar mh-redist-background nil + "If non-nil redist will be done in background like send. +This allows transaction log to be visible if -watch, -verbose or -snoop are +used.") + +(defvar mh-note-repl "-" + "String whose first character is used to notate replied to messages.") + +(defvar mh-note-forw "F" + "String whose first character is used to notate forwarded messages.") + +(defvar mh-note-dist "R" + "String whose first character is used to notate redistributed messages.") + +(defvar mh-yank-hooks nil + "Obsolete hook for modifying a citation just inserted in the mail buffer. +Each hook function can find the citation between point and mark. +And each hook function should leave point and mark around the citation +text as modified. + +This is a normal hook, misnamed for historical reasons. +It is semi-obsolete and is only used if `mail-citation-hook' is nil.") + +(defvar mail-citation-hook nil + "*Hook for modifying a citation just inserted in the mail buffer. +Each hook function can find the citation between point and mark. +And each hook function should leave point and mark around the citation +text as modified. + +If this hook is entirely empty (nil), the text of the message is inserted +with `mh-ins-buf-prefix' prefixed to each line. + +See also the variable `mh-yank-from-start-of-msg', which controls how +much of the message passed to the hook. + +This hook was historically provided to set up supercite. You may now leave +this nil and set up supercite by setting the variable +`mh-yank-from-start-of-msg' to 'supercite or, for more automatic insertion, +to 'autosupercite.") + +(defvar mh-comp-formfile "components" + "Name of file to be used as a skeleton for composing messages. +Default is \"components\". If not an absolute file name, the file +is searched for first in the user's MH directory, then in the +system MH lib directory.") + +(defvar mh-repl-formfile "replcomps" + "Name of file to be used as a skeleton for replying to messages. +Default is \"replcomps\". If not an absolute file name, the file +is searched for first in the user's MH directory, then in the +system MH lib directory.") + +(defvar mh-repl-group-formfile "replgroupcomps" + "Name of file to be used as a skeleton for replying to messages. +This file is used to form replies to the sender and all recipients of a +message. Only used if `mh-nmh-flag' is non-nil. Default is \"replgroupcomps\". +If not an absolute file name, the file is searched for first in the user's MH +directory, then in the system MH lib directory.") + +(defvar mh-rejected-letter-start + (format "^%s$" + (regexp-opt + '("Content-Type: message/rfc822" ;MIME MDN + " ----- Unsent message follows -----" ;from sendmail V5 + " --------Unsent Message below:" ; from sendmail at BU + " ----- Original message follows -----" ;from sendmail V8 + "------- Unsent Draft" ;from MH itself + "---------- Original Message ----------" ;from zmailer + " --- The unsent message follows ---" ;from AIX mail system + " Your message follows:" ;from MMDF-II + "Content-Description: Returned Content" ;1993 KJ sendmail + )))) + +(defvar mh-new-draft-cleaned-headers + "^Date:\\|^Received:\\|^Message-Id:\\|^From:\\|^Sender:\\|^Errors-To:\\|^Delivery-Date:\\|^Return-Path:" + "Regexp of header lines to remove before offering a message as a new draft. +Used by the \\<mh-folder-mode-map>`\\[mh-edit-again]' and `\\[mh-extract-rejected-mail]' commands.") + +(defvar mh-to-field-choices '(("t" . "To:") ("s" . "Subject:") ("c" . "Cc:") + ("b" . "Bcc:") ("f" . "Fcc:") ("r" . "From:") + ("d" . "Dcc:")) + "Alist of (final-character . field-name) choices for `mh-to-field'.") + +(defvar mh-letter-mode-map (copy-keymap text-mode-map) + "Keymap for composing mail.") + +(defvar mh-letter-mode-syntax-table nil + "Syntax table used by MH-E while in MH-Letter mode.") + +(if mh-letter-mode-syntax-table + () + (setq mh-letter-mode-syntax-table + (make-syntax-table text-mode-syntax-table)) + (modify-syntax-entry ?% "." mh-letter-mode-syntax-table)) + +(defvar mh-sent-from-folder nil + "Folder of msg assoc with this letter.") + +(defvar mh-sent-from-msg nil + "Number of msg assoc with this letter.") + +(defvar mh-send-args nil + "Extra args to pass to \"send\" command.") + +(defvar mh-annotate-char nil + "Character to use to annotate `mh-sent-from-msg'.") + +(defvar mh-annotate-field nil + "Field name for message annotation.") + +;;;###autoload +(defun mh-smail () + "Compose and send mail with the MH mail system. +This function is an entry point to MH-E, the Emacs front end +to the MH mail system. + +See documentation of `\\[mh-send]' for more details on composing mail." + (interactive) + (mh-find-path) + (call-interactively 'mh-send)) + +(defvar mh-error-if-no-draft nil) ;raise error over using old draft + +;;;###autoload +(defun mh-smail-batch (&optional to subject other-headers &rest ignored) + "Set up a mail composition draft with the MH mail system. +This function is an entry point to MH-E, the Emacs front end +to the MH mail system. This function does not prompt the user +for any header fields, and thus is suitable for use by programs +that want to create a mail buffer. +Users should use `\\[mh-smail]' to compose mail. +Optional arguments for setting certain fields include TO, SUBJECT, and +OTHER-HEADERS. Additional arguments are IGNORED." + (mh-find-path) + (let ((mh-error-if-no-draft t)) + (mh-send (or to "") "" (or subject "")))) + +;; XEmacs needs this: +;;;###autoload +(defun mh-user-agent-compose (&optional to subject other-headers continue + switch-function yank-action + send-actions) + "Set up mail composition draft with the MH mail system. +This is `mail-user-agent' entry point to MH-E. + +The optional arguments TO and SUBJECT specify recipients and the +initial Subject field, respectively. + +OTHER-HEADERS is an alist specifying additional +header fields. Elements look like (HEADER . VALUE) where both +HEADER and VALUE are strings. + +CONTINUE, SWITCH-FUNCTION, YANK-ACTION and SEND-ACTIONS are ignored." + (mh-find-path) + (let ((mh-error-if-no-draft t)) + (mh-send to "" subject) + (while other-headers + (mh-insert-fields (concat (car (car other-headers)) ":") + (cdr (car other-headers))) + (setq other-headers (cdr other-headers))))) + +;;;###mh-autoload +(defun mh-edit-again (msg) + "Clean up a draft or a message MSG previously sent and make it resendable. +Default is the current message. +The variable `mh-new-draft-cleaned-headers' specifies the headers to remove. +See also documentation for `\\[mh-send]' function." + (interactive (list (mh-get-msg-num t))) + (let* ((from-folder mh-current-folder) + (config (current-window-configuration)) + (draft + (cond ((and mh-draft-folder (equal from-folder mh-draft-folder)) + (pop-to-buffer (find-file-noselect (mh-msg-filename msg)) t) + (rename-buffer (format "draft-%d" msg)) + ;; Make buffer writable... + (setq buffer-read-only nil) + ;; If buffer was being used to display the message reinsert + ;; from file... + (when (eq major-mode 'mh-show-mode) + (erase-buffer) + (insert-file-contents buffer-file-name)) + (buffer-name)) + (t + (mh-read-draft "clean-up" (mh-msg-filename msg) nil))))) + (mh-clean-msg-header (point-min) mh-new-draft-cleaned-headers nil) + (mh-insert-header-separator) + (goto-char (point-min)) + (save-buffer) + (mh-compose-and-send-mail draft "" from-folder nil nil nil nil nil nil + config) + (mh-letter-mode-message))) + +;;;###mh-autoload +(defun mh-extract-rejected-mail (msg) + "Extract message MSG returned by the mail system and make it resendable. +Default is the current message. The variable `mh-new-draft-cleaned-headers' +gives the headers to clean out of the original message. +See also documentation for `\\[mh-send]' function." + (interactive (list (mh-get-msg-num t))) + (let ((from-folder mh-current-folder) + (config (current-window-configuration)) + (draft (mh-read-draft "extraction" (mh-msg-filename msg) nil))) + (goto-char (point-min)) + (cond ((re-search-forward mh-rejected-letter-start nil t) + (skip-chars-forward " \t\n") + (delete-region (point-min) (point)) + (mh-clean-msg-header (point-min) mh-new-draft-cleaned-headers nil)) + (t + (message "Does not appear to be a rejected letter."))) + (mh-insert-header-separator) + (goto-char (point-min)) + (save-buffer) + (mh-compose-and-send-mail draft "" from-folder msg + (mh-get-header-field "To:") + (mh-get-header-field "From:") + (mh-get-header-field "Cc:") + nil nil config) + (mh-letter-mode-message))) + +;;;###mh-autoload +(defun mh-forward (to cc &optional msg-or-seq) + "Forward one or more messages to the recipients TO and CC. + +Use the optional MSG-OR-SEQ to specify a message or sequence to forward. + +Default is the displayed message. If optional prefix argument is given then +prompt for the message sequence. If variable `transient-mark-mode' is non-nil +and the mark is active, then the selected region is forwarded. +See also documentation for `\\[mh-send]' function." + (interactive (list (mh-read-address "To: ") + (mh-read-address "Cc: ") + (cond + ((mh-mark-active-p t) + (mh-region-to-msg-list (region-beginning) (region-end))) + (current-prefix-arg + (mh-read-seq-default "Forward" t)) + (t + (mh-get-msg-num t))))) + (let* ((folder mh-current-folder) + (msgs (cond ((numberp msg-or-seq) (list msg-or-seq)) + ((listp msg-or-seq) msg-or-seq) + (t (mh-seq-to-msgs msg-or-seq)))) + (config (current-window-configuration)) + (fwd-msg-file (mh-msg-filename (car msgs) folder)) + ;; forw always leaves file in "draft" since it doesn't have -draft + (draft-name (expand-file-name "draft" mh-user-path)) + (draft (cond ((or (not (file-exists-p draft-name)) + (y-or-n-p "The file 'draft' exists. Discard it? ")) + (mh-exec-cmd "forw" "-build" (if mh-nmh-flag "-mime") + mh-current-folder msgs) + (prog1 + (mh-read-draft "" draft-name t) + (mh-insert-fields "To:" to "Cc:" cc) + (save-buffer))) + (t + (mh-read-draft "" draft-name nil))))) + (let (orig-from + orig-subject) + (save-excursion + (set-buffer (get-buffer-create mh-temp-buffer)) + (erase-buffer) + (insert-file-contents fwd-msg-file) + (setq orig-from (mh-get-header-field "From:")) + (setq orig-subject (mh-get-header-field "Subject:"))) + (let ((forw-subject + (mh-forwarded-letter-subject orig-from orig-subject)) + (compose)) + (mh-insert-fields "Subject:" forw-subject) + (goto-char (point-min)) + ;; If using MML, translate mhn + (if (equal mh-compose-insertion 'gnus) + (save-excursion + (setq compose t) + (re-search-forward (format "^\\(%s\\)?$" + mh-mail-header-separator)) + (while + (re-search-forward + "^#forw \\[\\([^]]+\\)\\] \\(+\\S-+\\) \\(.*\\)$" + (point-max) t) + (let ((description (if (equal (match-string 1) + "forwarded messages") + "forwarded message %d" + (match-string 1))) + (msgs (split-string (match-string 3))) + (i 0)) + (beginning-of-line) + (delete-region (point) (progn (forward-line 1) (point))) + (dolist (msg msgs) + (setq i (1+ i)) + (mh-mml-forward-message (format description i) + folder msg)))))) + ;; Postition just before forwarded message + (if (re-search-forward "^------- Forwarded Message" nil t) + (forward-line -1) + (re-search-forward (format "^\\(%s\\)?$" mh-mail-header-separator)) + (forward-line 1)) + (delete-other-windows) + (mh-add-msgs-to-seq msgs 'forwarded t) + (mh-compose-and-send-mail draft "" folder msg-or-seq + to forw-subject cc + mh-note-forw "Forwarded:" + config) + (if compose + (setq mh-mml-compose-insert-flag t)) + (mh-letter-mode-message))))) + +(defun mh-forwarded-letter-subject (from subject) + "Return a Subject suitable for a forwarded message. +Original message has headers FROM and SUBJECT." + (let ((addr-start (string-match "<" from)) + (comment (string-match "(" from))) + (cond ((and addr-start (> addr-start 0)) + ;; Full Name <luser@host> + (setq from (substring from 0 (1- addr-start)))) + (comment + ;; luser@host (Full Name) + (setq from (substring from (1+ comment) (1- (length from))))))) + (format mh-forward-subject-format from subject)) + +;;;###autoload +(defun mh-smail-other-window () + "Compose and send mail in other window with the MH mail system. +This function is an entry point to MH-E, the Emacs front end +to the MH mail system. + +See documentation of `\\[mh-send]' for more details on composing mail." + (interactive) + (mh-find-path) + (call-interactively 'mh-send-other-window)) + +;;;###mh-autoload +(defun mh-redistribute (to cc &optional msg) + "Redistribute displayed message to recipients TO and CC. +Use optional argument MSG to redistribute another message. +Depending on how your copy of MH was compiled, you may need to change the +setting of the variable `mh-redist-full-contents'. See its documentation." + (interactive (list (mh-read-address "Redist-To: ") + (mh-read-address "Redist-Cc: ") + (mh-get-msg-num t))) + (or msg + (setq msg (mh-get-msg-num t))) + (save-window-excursion + (let ((folder mh-current-folder) + (draft (mh-read-draft "redistribution" + (if mh-redist-full-contents + (mh-msg-filename msg) + nil) + nil))) + (mh-goto-header-end 0) + (insert "Resent-To: " to "\n") + (if (not (equal cc "")) (insert "Resent-cc: " cc "\n")) + (mh-clean-msg-header (point-min) + "^Message-Id:\\|^Received:\\|^Return-Path:\\|^Sender:\\|^Date:\\|^From:" + nil) + (save-buffer) + (message "Redistributing...") + (if (not mh-redist-background) + (if mh-redist-full-contents + (call-process "/bin/sh" nil 0 nil "-c" + (format "mhdist=1 mhaltmsg=%s %s -push %s" + buffer-file-name + (expand-file-name mh-send-prog mh-progs) + buffer-file-name)) + (call-process "/bin/sh" nil 0 nil "-c" + (format + "mhdist=1 mhaltmsg=%s mhannotate=1 %s -push %s" + (mh-msg-filename msg folder) + (expand-file-name mh-send-prog mh-progs) + buffer-file-name)))) + (mh-annotate-msg msg folder mh-note-dist + "-component" "Resent:" + "-text" (format "\"%s %s\"" to cc)) + (if mh-redist-background + (mh-exec-cmd-daemon "/bin/sh" "-c" + (format "mhdist=1 mhaltmsg=%s %s %s %s" + (if mh-redist-full-contents + buffer-file-name + (mh-msg-filename msg folder)) + (if mh-redist-full-contents + "" + "mhannotate=1") + (mh-expand-file-name "send" mh-progs) + buffer-file-name))) + (kill-buffer draft) + (message "Redistributing...done")))) + +(defun mh-show-buffer-message-number (&optional buffer) + "Message number of displayed message in corresponding show buffer. +Return nil if show buffer not displayed. +If in `mh-letter-mode', don't display the message number being replied to, +but rather the message number of the show buffer associated with our +originating folder buffer. +Optional argument BUFFER can be used to specify the buffer." + (save-excursion + (if buffer + (set-buffer buffer)) + (cond ((eq major-mode 'mh-show-mode) + (let ((number-start (mh-search-from-end ?/ buffer-file-name))) + (car (read-from-string (substring buffer-file-name + (1+ number-start)))))) + ((and (eq major-mode 'mh-folder-mode) + mh-show-buffer + (get-buffer mh-show-buffer)) + (mh-show-buffer-message-number mh-show-buffer)) + ((and (eq major-mode 'mh-letter-mode) + mh-sent-from-folder + (get-buffer mh-sent-from-folder)) + (mh-show-buffer-message-number mh-sent-from-folder)) + (t + nil)))) + +;;;###mh-autoload +(defun mh-reply (message &optional reply-to includep) + "Reply to MESSAGE (default: current message). +If the optional argument REPLY-TO is not given, prompts for type of addresses +to reply to: + from sender only, + to sender and primary recipients, + cc/all sender and all recipients. +If optional prefix argument INCLUDEP provided, then include the message +in the reply using filter `mhl.reply' in your MH directory. +If the file named by `mh-repl-formfile' exists, it is used as a skeleton +for the reply. See also documentation for `\\[mh-send]' function." + (interactive (list + (mh-get-msg-num t) + (let ((minibuffer-help-form + "from => Sender only\nto => Sender and primary recipients\ncc or all => Sender and all recipients")) + (or mh-reply-default-reply-to + (completing-read "Reply to whom? (from, to, all) [from]: " + '(("from") ("to") ("cc") ("all")) + nil + t))) + current-prefix-arg)) + (let* ((folder mh-current-folder) + (show-buffer mh-show-buffer) + (config (current-window-configuration)) + (group-reply (or (equal reply-to "cc") (equal reply-to "all"))) + (form-file (cond ((and mh-nmh-flag group-reply + (stringp mh-repl-group-formfile)) + mh-repl-group-formfile) + ((stringp mh-repl-formfile) mh-repl-formfile) + (t nil)))) + (message "Composing a reply...") + (mh-exec-cmd "repl" "-build" "-noquery" "-nodraftfolder" + (if form-file + (list "-form" form-file)) + mh-current-folder message + (cond ((or (equal reply-to "from") (equal reply-to "")) + '("-nocc" "all")) + ((equal reply-to "to") + '("-cc" "to")) + (group-reply (if mh-nmh-flag + '("-group" "-nocc" "me") + '("-cc" "all" "-nocc" "me")))) + (cond ((or (eq mh-yank-from-start-of-msg 'autosupercite) + (eq mh-yank-from-start-of-msg 'autoattrib)) + '("-noformat")) + (includep '("-filter" "mhl.reply")) + (t '()))) + (let ((draft (mh-read-draft "reply" + (expand-file-name "reply" mh-user-path) + t))) + (delete-other-windows) + (save-buffer) + + (let ((to (mh-get-header-field "To:")) + (subject (mh-get-header-field "Subject:")) + (cc (mh-get-header-field "Cc:"))) + (goto-char (point-min)) + (mh-goto-header-end 1) + (or includep + (not mh-reply-show-message-flag) + (mh-in-show-buffer (show-buffer) + (mh-display-msg message folder))) + (mh-add-msgs-to-seq message 'answered t) + (message "Composing a reply...done") + (mh-compose-and-send-mail draft "" folder message to subject cc + mh-note-repl "Replied:" config)) + (when (and (or (eq 'autosupercite mh-yank-from-start-of-msg) + (eq 'autoattrib mh-yank-from-start-of-msg)) + (eq (mh-show-buffer-message-number) mh-sent-from-msg)) + (undo-boundary) + (mh-yank-cur-msg)) + (mh-letter-mode-message)))) + +;;;###mh-autoload +(defun mh-send (to cc subject) + "Compose and send a letter. + +Do not call this function from outside MH-E; use \\[mh-smail] instead. + +The file named by `mh-comp-formfile' will be used as the form. +The letter is composed in `mh-letter-mode'; see its documentation for more +details. +If `mh-compose-letter-function' is defined, it is called on the draft and +passed three arguments: TO, CC, and SUBJECT." + (interactive (list + (mh-read-address "To: ") + (mh-read-address "Cc: ") + (read-string "Subject: "))) + (let ((config (current-window-configuration))) + (delete-other-windows) + (mh-send-sub to cc subject config))) + +;;;###mh-autoload +(defun mh-send-other-window (to cc subject) + "Compose and send a letter in another window. + +Do not call this function from outside MH-E; use \\[mh-smail-other-window] +instead. + +The file named by `mh-comp-formfile' will be used as the form. +The letter is composed in `mh-letter-mode'; see its documentation for more +details. +If `mh-compose-letter-function' is defined, it is called on the draft and +passed three arguments: TO, CC, and SUBJECT." + (interactive (list + (mh-read-address "To: ") + (mh-read-address "Cc: ") + (read-string "Subject: "))) + (let ((pop-up-windows t)) + (mh-send-sub to cc subject (current-window-configuration)))) + +(defun mh-send-sub (to cc subject config) + "Do the real work of composing and sending a letter. +Expects the TO, CC, and SUBJECT fields as arguments. +CONFIG is the window configuration before sending mail." + (let ((folder mh-current-folder) + (msg-num (mh-get-msg-num nil))) + (message "Composing a message...") + (let ((draft (mh-read-draft + "message" + (let (components) + (cond + ((file-exists-p + (setq components + (expand-file-name mh-comp-formfile mh-user-path))) + components) + ((file-exists-p + (setq components + (expand-file-name mh-comp-formfile mh-lib))) + components) + ((file-exists-p + (setq components + (expand-file-name mh-comp-formfile + ;; What is this mh-etc ?? -sm + ;; This is dead code, so + ;; remove it. + ;(and (boundp 'mh-etc) mh-etc) + ))) + components) + (t + (error (format "Can't find components file \"%s\"" + components))))) + nil))) + (mh-insert-fields "To:" to "Subject:" subject "Cc:" cc) + (goto-char (point-max)) + (mh-compose-and-send-mail draft "" folder msg-num + to subject cc + nil nil config) + (mh-letter-mode-message)))) + +(defun mh-read-draft (use initial-contents delete-contents-file) + "Read draft file into a draft buffer and make that buffer the current one. +USE is a message used for prompting about the intended use of the message. +INITIAL-CONTENTS is filename that is read into an empty buffer, or nil +if buffer should not be modified. Delete the initial-contents file if +DELETE-CONTENTS-FILE flag is set. +Returns the draft folder's name. +If the draft folder facility is enabled in ~/.mh_profile, a new buffer is +used each time and saved in the draft folder. The draft file can then be +reused." + (cond (mh-draft-folder + (let ((orig-default-dir default-directory) + (draft-file-name (mh-new-draft-name))) + (pop-to-buffer (generate-new-buffer + (format "draft-%s" + (file-name-nondirectory draft-file-name)))) + (condition-case () + (insert-file-contents draft-file-name t) + (file-error)) + (setq default-directory orig-default-dir))) + (t + (let ((draft-name (expand-file-name "draft" mh-user-path))) + (pop-to-buffer "draft") ; Create if necessary + (if (buffer-modified-p) + (if (y-or-n-p "Draft has been modified; kill anyway? ") + (set-buffer-modified-p nil) + (error "Draft preserved"))) + (setq buffer-file-name draft-name) + (clear-visited-file-modtime) + (unlock-buffer) + (cond ((and (file-exists-p draft-name) + (not (equal draft-name initial-contents))) + (insert-file-contents draft-name) + (delete-file draft-name)))))) + (cond ((and initial-contents + (or (zerop (buffer-size)) + (if (y-or-n-p + (format "A draft exists. Use for %s? " use)) + (if mh-error-if-no-draft + (error "A prior draft exists")) + t))) + (erase-buffer) + (insert-file-contents initial-contents) + (if delete-contents-file (delete-file initial-contents)))) + (auto-save-mode 1) + (if mh-draft-folder + (save-buffer)) ; Do not reuse draft name + (buffer-name)) + +(defun mh-new-draft-name () + "Return the pathname of folder for draft messages." + (save-excursion + (mh-exec-cmd-quiet t "mhpath" mh-draft-folder "new") + (buffer-substring (point-min) (1- (point-max))))) + +(defun mh-annotate-msg (msg buffer note &rest args) + "Mark MSG in BUFFER with character NOTE and annotate message with ARGS." + (apply 'mh-exec-cmd "anno" buffer msg args) + (save-excursion + (cond ((get-buffer buffer) ; Buffer may be deleted + (set-buffer buffer) + (if (numberp msg) + (mh-notate msg note (1+ mh-cmd-note)) + (mh-notate-seq msg note (1+ mh-cmd-note))))))) + +(defun mh-insert-fields (&rest name-values) + "Insert the NAME-VALUES pairs in the current buffer. +If the field exists, append the value to it. +Do not insert any pairs whose value is the empty string." + (let ((case-fold-search t)) + (while name-values + (let ((field-name (car name-values)) + (value (car (cdr name-values)))) + (cond ((equal value "") + nil) + ((mh-position-on-field field-name) + (insert " " (or value ""))) + (t + (insert field-name " " value "\n"))) + (setq name-values (cdr (cdr name-values))))))) + +(defun mh-position-on-field (field &optional ignored) + "Move to the end of the FIELD in the header. +Move to end of entire header if FIELD not found. +Returns non-nil iff FIELD was found. +The optional second arg is for pre-version 4 compatibility and is IGNORED." + (cond ((mh-goto-header-field field) + (mh-header-field-end) + t) + ((mh-goto-header-end 0) + nil))) + +(defun mh-get-header-field (field) + "Find and return the body of FIELD in the mail header. +Returns the empty string if the field is not in the header of the +current buffer." + (if (mh-goto-header-field field) + (progn + (skip-chars-forward " \t") ;strip leading white space in body + (let ((start (point))) + (mh-header-field-end) + (buffer-substring-no-properties start (point)))) + "")) + +(fset 'mh-get-field 'mh-get-header-field) ;MH-E 4 compatibility + +(defun mh-goto-header-field (field) + "Move to FIELD in the message header. +Move to the end of the FIELD name, which should end in a colon. +Returns t if found, nil if not." + (goto-char (point-min)) + (let ((case-fold-search t) + (headers-end (save-excursion + (mh-goto-header-end 0) + (point)))) + (re-search-forward (format "^%s" field) headers-end t))) + +(defun mh-goto-header-end (arg) + "Move the cursor ARG lines after the header." + (if (re-search-forward "^-*$" nil nil) + (forward-line arg))) + +(defun mh-extract-from-header-value () + "Extract From: string from header." + (save-excursion + (if (not (mh-goto-header-field "From:")) + (error "No From header line found") + (skip-chars-forward " \t") + (buffer-substring-no-properties + (point) (progn (mh-header-field-end)(point)))))) + + + +;;; Mode for composing and sending a draft message. + +(put 'mh-letter-mode 'mode-class 'special) + +;;; Menu extracted from mh-menubar.el V1.1 (31 July 2001) +(eval-when-compile (defvar mh-letter-menu nil)) +(cond + ((fboundp 'easy-menu-define) + (easy-menu-define + mh-letter-menu mh-letter-mode-map "Menu for MH-E letter mode." + '("Letter" + ["Send This Draft" mh-send-letter t] + ["Split Current Line" mh-open-line t] + ["Check Recipient" mh-check-whom t] + ["Yank Current Message" mh-yank-cur-msg t] + ["Insert a Message..." mh-insert-letter t] + ["Insert Signature" mh-insert-signature t] + ["GPG Sign message" + mh-mml-secure-message-sign-pgpmime mh-gnus-pgp-support-flag] + ["GPG Encrypt message" + mh-mml-secure-message-encrypt-pgpmime mh-gnus-pgp-support-flag] + ["Compose Insertion (MIME)..." mh-compose-insertion t] + ;; ["Compose Compressed tar (MIME)..." + ;;mh-mhn-compose-external-compressed-tar t] + ;; ["Compose Anon FTP (MIME)..." mh-mhn-compose-anon-ftp t] + ["Compose Forward (MIME)..." mh-compose-forward t] + ;; The next two will have to be merged. But I also need to make sure the + ;; user can't mix directives of both types. + ["Pull in All Compositions (mhn)" + mh-edit-mhn mh-mhn-compose-insert-flag] + ["Pull in All Compositions (gnus)" + mh-mml-to-mime mh-mml-compose-insert-flag] + ["Revert to Non-MIME Edit (mhn)" + mh-revert-mhn-edit (equal mh-compose-insertion 'mhn)] + ["Kill This Draft" mh-fully-kill-draft t])))) + +;;; Help Messages +;;; Group messages logically, more or less. +(defvar mh-letter-mode-help-messages + '((nil + "Send letter: \\[mh-send-letter]" + "\t\tOpen line: \\[mh-open-line]\n" + "Kill letter: \\[mh-fully-kill-draft]" + "\t\tInsert:\n" + "Check recipients: \\[mh-check-whom]" + "\t\t Current message: \\[mh-yank-cur-msg]\n" + "Encrypt message: \\[mh-mml-secure-message-encrypt-pgpmime]" + "\t\t Attachment: \\[mh-compose-insertion]\n" + "Sign message: \\[mh-mml-secure-message-sign-pgpmime]" + "\t\t Message to forward: \\[mh-compose-forward]\n" + " " + "\t\t Signature: \\[mh-insert-signature]")) + "Key binding cheat sheet. + +This is an associative array which is used to show the most common commands. +The key is a prefix char. The value is one or more strings which are +concatenated together and displayed in the minibuffer if ? is pressed after +the prefix character. The special key nil is used to display the +non-prefixed commands. + +The substitutions described in `substitute-command-keys' are performed as +well.") + +;;;###mh-autoload +(defun mh-fill-paragraph-function (arg) + "Fill paragraph at or after point. +Prefix ARG means justify as well. This function enables `fill-paragraph' to +work better in MH-Letter mode." + (interactive "P") + (let ((fill-paragraph-function) (fill-prefix)) + (if (mh-in-header-p) + (mail-mode-fill-paragraph arg) + (fill-paragraph arg)))) + +;;;###autoload +(define-derived-mode mh-letter-mode text-mode "MH-Letter" + "Mode for composing letters in MH-E.\\<mh-letter-mode-map> + +When you have finished composing, type \\[mh-send-letter] to send the message +using the MH mail handling system. + +There are two types of MIME directives used by MH-E: Gnus and MH. The option +`mh-compose-insertion' controls what type of directives are inserted by MH-E +commands. These directives can be converted to MIME body parts by running +\\[mh-edit-mhn] for mhn directives or \\[mh-mml-to-mime] for Gnus directives. +This step is mandatory if these directives are added manually. If the +directives are inserted with MH-E commands such as \\[mh-compose-insertion], +the directives are expanded automatically when the letter is sent. + +Options that control this mode can be changed with +\\[customize-group]; specify the \"mh-compose\" group. + +When a message is composed, the hooks `text-mode-hook' and +`mh-letter-mode-hook' are run. + +\\{mh-letter-mode-map}" + + (or mh-user-path (mh-find-path)) + (make-local-variable 'mh-send-args) + (make-local-variable 'mh-annotate-char) + (make-local-variable 'mh-annotate-field) + (make-local-variable 'mh-previous-window-config) + (make-local-variable 'mh-sent-from-folder) + (make-local-variable 'mh-sent-from-msg) + (make-local-variable 'mail-header-separator) + (setq mail-header-separator mh-mail-header-separator) ;override sendmail.el + (make-local-variable 'mh-help-messages) + (setq mh-help-messages mh-letter-mode-help-messages) + + ;; From sendmail.el for proper paragraph fill + ;; sendmail.el also sets a normal-auto-fill-function (not done here) + (make-local-variable 'paragraph-separate) + (make-local-variable 'paragraph-start) + (make-local-variable 'fill-paragraph-function) + (setq fill-paragraph-function 'mh-fill-paragraph-function) + (make-local-variable 'adaptive-fill-regexp) + (setq adaptive-fill-regexp + (concat adaptive-fill-regexp + "\\|[ \t]*[-[:alnum:]]*>+[ \t]*")) + (make-local-variable 'adaptive-fill-first-line-regexp) + (setq adaptive-fill-first-line-regexp + (concat adaptive-fill-first-line-regexp + "\\|[ \t]*[-[:alnum:]]*>+[ \t]*")) + ;; `-- ' precedes the signature. `-----' appears at the start of the + ;; lines that delimit forwarded messages. + ;; Lines containing just >= 3 dashes, perhaps after whitespace, + ;; are also sometimes used and should be separators. + (setq paragraph-start (concat (regexp-quote mail-header-separator) + "\\|\t*\\([-|#;>* ]\\|(?[0-9]+[.)]\\)+$" + "\\|[ \t]*[[:alnum:]]*>+[ \t]*$\\|[ \t]*$\\|" + "-- $\\|---+$\\|" + page-delimiter)) + (setq paragraph-separate paragraph-start) + ;; --- End of code from sendmail.el --- + + (if (and (boundp 'tool-bar-mode) tool-bar-mode) + (set (make-local-variable 'tool-bar-map) mh-letter-tool-bar-map)) + (make-local-variable 'font-lock-defaults) + (cond + ((or (equal mh-highlight-citation-p 'font-lock) + (equal mh-highlight-citation-p 'gnus)) + ;; Let's use font-lock even if gnus is used in show-mode. The reason + ;; is that gnus uses static text properties which are not appropriate + ;; for a buffer that will be edited. So the choice here is either fontify + ;; the citations and header... + (setq font-lock-defaults '(mh-show-font-lock-keywords-with-cite t))) + (t + ;; ...or the header only + (setq font-lock-defaults '(mh-show-font-lock-keywords t)))) + (easy-menu-add mh-letter-menu) + ;; See if a "forw: -mime" message containing a MIME composition. + ;; Mode clears local vars, so can't do this in mh-forward. + (save-excursion + (goto-char (point-min)) + (when (and (re-search-forward + (format "^\\(%s\\)?$" mail-header-separator) nil t) + (= 0 (forward-line 1)) + (looking-at "^#forw")) + (require 'mh-mime) ;Need mh-mhn-compose-insert-flag local var + (setq mh-mhn-compose-insert-flag t))) + (setq fill-column mh-letter-fill-column) + ;; If text-mode-hook turned on auto-fill, tune it for messages + (when auto-fill-function + (make-local-variable 'auto-fill-function) + (setq auto-fill-function 'mh-auto-fill-for-letter))) + +(defun mh-auto-fill-for-letter () + "Perform auto-fill for message. +Header is treated specially by inserting a tab before continuation lines." + (if (mh-in-header-p) + (let ((fill-prefix "\t")) + (do-auto-fill)) + (do-auto-fill))) + +(defun mh-insert-header-separator () + "Insert `mh-mail-header-separator', if absent." + (save-excursion + (goto-char (point-min)) + (rfc822-goto-eoh) + (if (looking-at "$") + (insert mh-mail-header-separator)))) + +;;;###mh-autoload +(defun mh-to-field () + "Move point to the end of a specified header field. +The field is indicated by the previous keystroke (the last keystroke +of the command) according to the list in the variable `mh-to-field-choices'. +Create the field if it does not exist. Set the mark to point before moving." + (interactive) + (expand-abbrev) + (let ((target (cdr (or (assoc (char-to-string (logior last-input-char ?`)) + mh-to-field-choices) + ;; also look for a char for version 4 compat + (assoc (logior last-input-char ?`) + mh-to-field-choices)))) + (case-fold-search t)) + (push-mark) + (cond ((mh-position-on-field target) + (let ((eol (point))) + (skip-chars-backward " \t") + (delete-region (point) eol)) + (if (and (not (eq (logior last-input-char ?`) ?s)) + (save-excursion + (backward-char 1) + (not (looking-at "[:,]")))) + (insert ", ") + (insert " "))) + (t + (if (mh-position-on-field "To:") + (forward-line 1)) + (insert (format "%s \n" target)) + (backward-char 1))))) + +;;;###mh-autoload +(defun mh-to-fcc (&optional folder) + "Insert an Fcc: FOLDER field in the current message. +Prompt for the field name with a completion list of the current folders." + (interactive) + (or folder + (setq folder (mh-prompt-for-folder + "Fcc" + (or (and mh-default-folder-for-message-function + (save-excursion + (goto-char (point-min)) + (funcall + mh-default-folder-for-message-function))) + "") + t))) + (let ((last-input-char ?\C-f)) + (expand-abbrev) + (save-excursion + (mh-to-field) + (insert (if (mh-folder-name-p folder) + (substring folder 1) + folder))))) + +;;;###mh-autoload +(defun mh-insert-signature () + "Insert the file named by `mh-signature-file-name' at point. +The value of `mh-letter-insert-signature-hook' is a list of functions to be +called, with no arguments, before the signature is actually inserted." + (interactive) + (let ((mh-signature-file-name mh-signature-file-name)) + (run-hooks 'mh-letter-insert-signature-hook) + (if mh-signature-file-name + (insert-file-contents mh-signature-file-name))) + (force-mode-line-update)) + +;;;###mh-autoload +(defun mh-check-whom () + "Verify recipients of the current letter, showing expansion of any aliases." + (interactive) + (let ((file-name buffer-file-name)) + (save-buffer) + (message "Checking recipients...") + (mh-in-show-buffer ("*Recipients*") + (bury-buffer (current-buffer)) + (erase-buffer) + (mh-exec-cmd-output "whom" t file-name)) + (message "Checking recipients...done"))) + + + +;;; Routines to compose and send a letter. + +(defun mh-insert-x-face () + "Append X-Face field to header. +If the field already exists, this function does nothing." + (when (and (file-exists-p mh-x-face-file) + (file-readable-p mh-x-face-file)) + (save-excursion + (when (null (mh-position-on-field "X-Face")) + (insert "X-Face: ") + (goto-char (+ (point) (cadr (insert-file-contents mh-x-face-file)))) + (if (not (looking-at "^")) + (insert "\n")))))) + +(defun mh-insert-x-mailer () + "Append an X-Mailer field to the header. +The versions of MH-E, Emacs, and MH are shown." + + ;; Lazily initialize mh-x-mailer-string. + (when (null mh-x-mailer-string) + (save-window-excursion + (mh-version) + (set-buffer mh-temp-buffer) + (if mh-nmh-flag + (search-forward-regexp "^nmh-\\(\\S +\\)") + (search-forward-regexp "^MH \\(\\S +\\)" nil t)) + (let ((x-mailer-mh (buffer-substring (match-beginning 1) (match-end 1)))) + (setq mh-x-mailer-string + (format "MH-E %s; %s %s; %s %d.%d" + mh-version (if mh-nmh-flag "nmh" "MH") x-mailer-mh + (if mh-xemacs-flag + "XEmacs" + "Emacs") + emacs-major-version emacs-minor-version))) + (kill-buffer mh-temp-buffer))) + ;; Insert X-Mailer, but only if it doesn't already exist. + (save-excursion + (when (null (mh-goto-header-field "X-Mailer")) + (mh-insert-fields "X-Mailer:" mh-x-mailer-string)))) + +(defun mh-regexp-in-field-p (regexp &rest fields) + "Non-nil means REGEXP was found in FIELDS." + (save-excursion + (let ((search-result nil) + (field)) + (while fields + (setq field (car fields)) + (if (and (mh-goto-header-field field) + (re-search-forward + regexp (save-excursion (mh-header-field-end)(point)) t)) + (setq fields nil + search-result t) + (setq fields (cdr fields)))) + search-result))) + +(defun mh-insert-mail-followup-to () + "Insert Mail-Followup-To: if To or Cc match `mh-insert-mail-followup-to-list'." + (save-excursion + (if (and (or (mh-goto-header-field "To:")(mh-goto-header-field "cc:")) + (not (mh-goto-header-field "Mail-Followup-To: "))) + (let ((list mh-insert-mail-followup-to-list)) + (while list + (let ((regexp (nth 0 (car list))) + (entry (nth 1 (car list)))) + (when (mh-regexp-in-field-p regexp "To:" "cc:") + (if (mh-goto-header-field "Mail-Followup-To: ") + (insert entry ", ") + (mh-goto-header-end 0) + (insert "Mail-Followup-To: " entry "\n"))) + (setq list (cdr list)))))))) + +(defun mh-compose-and-send-mail (draft send-args + sent-from-folder sent-from-msg + to subject cc + annotate-char annotate-field + config) + "Edit and compose a draft message in buffer DRAFT and send or save it. +SEND-ARGS is the argument passed to the send command. +SENT-FROM-FOLDER is buffer containing scan listing of current folder, or +nil if none exists. +SENT-FROM-MSG is the message number or sequence name or nil. +The TO, SUBJECT, and CC fields are passed to the +`mh-compose-letter-function'. +If ANNOTATE-CHAR is non-null, it is used to notate the scan listing of the +message. In that case, the ANNOTATE-FIELD is used to build a string +for `mh-annotate-msg'. +CONFIG is the window configuration to restore after sending the letter." + (pop-to-buffer draft) + (if mh-insert-mail-followup-to-flag (mh-insert-mail-followup-to)) + (mh-letter-mode) + + ;; mh-identity support + (if (and (boundp 'mh-identity-default) + mh-identity-default) + (mh-insert-identity mh-identity-default)) + (when (and (boundp 'mh-identity-list) + mh-identity-list) + (mh-identity-make-menu) + (easy-menu-add mh-identity-menu)) + + (setq mh-sent-from-folder sent-from-folder) + (setq mh-sent-from-msg sent-from-msg) + (setq mh-send-args send-args) + (setq mh-annotate-char annotate-char) + (setq mh-annotate-field annotate-field) + (setq mh-previous-window-config config) + (setq mode-line-buffer-identification (list "{%b}")) + (if (and (boundp 'mh-compose-letter-function) + mh-compose-letter-function) + ;; run-hooks will not pass arguments. + (let ((value mh-compose-letter-function)) + (if (and (listp value) (not (eq (car value) 'lambda))) + (while value + (funcall (car value) to subject cc) + (setq value (cdr value))) + (funcall mh-compose-letter-function to subject cc))))) + +(defun mh-letter-mode-message () + "Display a help message for users of `mh-letter-mode'. +This should be the last function called when composing the draft." + (message "%s" (substitute-command-keys + (concat "Type \\[mh-send-letter] to send message, " + "\\[mh-help] for help.")))) + +;;;###mh-autoload +(defun mh-send-letter (&optional arg) + "Send the draft letter in the current buffer. +If optional prefix argument ARG is provided, monitor delivery. +The value of `mh-before-send-letter-hook' is a list of functions to be called, +with no arguments, before doing anything. +Run `\\[mh-edit-mhn]' if variable `mh-mhn-compose-insert-flag' is set. +Run `\\[mh-mml-to-mime]' if variable `mh-mml-compose-insert-flag' is set. +Insert X-Mailer field if variable `mh-insert-x-mailer-flag' is set. +Insert X-Face field if the file specified by `mh-x-face-file' exists." + (interactive "P") + (run-hooks 'mh-before-send-letter-hook) + (cond + ((and (boundp 'mh-mhn-compose-insert-flag) + mh-mhn-compose-insert-flag) + (mh-edit-mhn)) + ((and (boundp 'mh-mml-compose-insert-flag) + mh-mml-compose-insert-flag) + (mh-mml-to-mime))) + (if mh-insert-x-mailer-flag (mh-insert-x-mailer)) + (mh-insert-x-face) + (save-buffer) + (message "Sending...") + (let ((draft-buffer (current-buffer)) + (file-name buffer-file-name) + (config mh-previous-window-config) + (coding-system-for-write + (if (and (local-variable-p 'buffer-file-coding-system + (current-buffer)) ;XEmacs needs two args + ;; We're not sure why, but buffer-file-coding-system + ;; tends to get set to undecided-unix. + (not (memq buffer-file-coding-system + '(undecided undecided-unix undecided-dos)))) + buffer-file-coding-system + (or (and (boundp 'sendmail-coding-system) sendmail-coding-system) + (and (boundp 'default-buffer-file-coding-system ) + default-buffer-file-coding-system) + 'iso-latin-1)))) + ;; The default BCC encapsulation will make a MIME message unreadable. + ;; With nmh use the -mime arg to prevent this. + (if (and mh-nmh-flag + (mh-goto-header-field "Bcc:") + (mh-goto-header-field "Content-Type:")) + (setq mh-send-args (format "-mime %s" mh-send-args))) + (cond (arg + (pop-to-buffer "MH mail delivery") + (erase-buffer) + (mh-exec-cmd-output mh-send-prog t "-watch" "-nopush" + "-nodraftfolder" mh-send-args file-name) + (goto-char (point-max)) ; show the interesting part + (recenter -1) + (set-buffer draft-buffer)) ; for annotation below + (t + (mh-exec-cmd-daemon mh-send-prog "-nodraftfolder" "-noverbose" + mh-send-args file-name))) + (if mh-annotate-char + (mh-annotate-msg mh-sent-from-msg + mh-sent-from-folder + mh-annotate-char + "-component" mh-annotate-field + "-text" (format "\"%s %s\"" + (mh-get-header-field "To:") + (mh-get-header-field "Cc:")))) + + (cond ((or (not arg) + (y-or-n-p "Kill draft buffer? ")) + (kill-buffer draft-buffer) + (if config + (set-window-configuration config)))) + (if arg + (message "Sending...done") + (message "Sending...backgrounded")))) + +;;;###mh-autoload +(defun mh-insert-letter (folder message verbatim) + "Insert a message into the current letter. +Removes the header fields according to the variable `mh-invisible-headers'. +Prefixes each non-blank line with `mh-ins-buf-prefix', unless +`mh-yank-from-start-of-msg' is set for supercite in which case supercite is +used to format the message. +Prompts for FOLDER and MESSAGE. If prefix argument VERBATIM provided, do +not indent and do not delete headers. Leaves the mark before the letter +and point after it." + (interactive + (list (mh-prompt-for-folder "Message from" mh-sent-from-folder nil) + (read-input (format "Message number%s: " + (if (numberp mh-sent-from-msg) + (format " [%d]" mh-sent-from-msg) + ""))) + current-prefix-arg)) + (save-restriction + (narrow-to-region (point) (point)) + (let ((start (point-min))) + (if (equal message "") (setq message (int-to-string mh-sent-from-msg))) + (insert-file-contents + (expand-file-name message (mh-expand-file-name folder))) + (when (not verbatim) + (mh-clean-msg-header start mh-invisible-headers mh-visible-headers) + (goto-char (point-max)) ;Needed for sc-cite-original + (push-mark) ;Needed for sc-cite-original + (goto-char (point-min)) ;Needed for sc-cite-original + (mh-insert-prefix-string mh-ins-buf-prefix))))) + +(defun mh-extract-from-attribution () + "Extract phrase or comment from From header field." + (save-excursion + (if (not (mh-goto-header-field "From: ")) + nil + (skip-chars-forward " ") + (cond + ((looking-at "\"\\([^\"\n]+\\)\" \\(<.+>\\)") + (format "%s %s %s" (match-string 1)(match-string 2) + mh-extract-from-attribution-verb)) + ((looking-at "\\([^<\n]+<.+>\\)$") + (format "%s %s" (match-string 1) mh-extract-from-attribution-verb)) + ((looking-at "\\([^ ]+@[^ ]+\\) +(\\(.+\\))$") + (format "%s <%s> %s" (match-string 2)(match-string 1) + mh-extract-from-attribution-verb)) + ((looking-at " *\\(.+\\)$") + (format "%s %s" (match-string 1) mh-extract-from-attribution-verb)))))) + +;;;###mh-autoload +(defun mh-yank-cur-msg () + "Insert the current message into the draft buffer. +Prefix each non-blank line in the message with the string in +`mh-ins-buf-prefix'. If a region is set in the message's buffer, then +only the region will be inserted. Otherwise, the entire message will +be inserted if `mh-yank-from-start-of-msg' is non-nil. If this variable +is nil, the portion of the message following the point will be yanked. +If `mh-delete-yanked-msg-window-flag' is non-nil, any window displaying the +yanked message will be deleted." + (interactive) + (if (and mh-sent-from-folder + (save-excursion (set-buffer mh-sent-from-folder) mh-show-buffer) + (save-excursion (set-buffer mh-sent-from-folder) + (get-buffer mh-show-buffer)) + mh-sent-from-msg) + (let ((to-point (point)) + (to-buffer (current-buffer))) + (set-buffer mh-sent-from-folder) + (if mh-delete-yanked-msg-window-flag + (delete-windows-on mh-show-buffer)) + (set-buffer mh-show-buffer) ; Find displayed message + (let* ((from-attr (mh-extract-from-attribution)) + (yank-region (mh-mark-active-p nil)) + (mh-ins-str + (cond ((and yank-region + (or (eq 'supercite mh-yank-from-start-of-msg) + (eq 'autosupercite mh-yank-from-start-of-msg) + (eq t mh-yank-from-start-of-msg))) + ;; supercite needs the full header + (concat + (buffer-substring (point-min) (mail-header-end)) + "\n" + (buffer-substring (region-beginning) (region-end)))) + (yank-region + (buffer-substring (region-beginning) (region-end))) + ((or (eq 'body mh-yank-from-start-of-msg) + (eq 'attribution + mh-yank-from-start-of-msg) + (eq 'autoattrib + mh-yank-from-start-of-msg)) + (buffer-substring + (save-excursion + (goto-char (point-min)) + (mh-goto-header-end 1) + (point)) + (point-max))) + ((or (eq 'supercite mh-yank-from-start-of-msg) + (eq 'autosupercite mh-yank-from-start-of-msg) + (eq t mh-yank-from-start-of-msg)) + (buffer-substring (point-min) (point-max))) + (t + (buffer-substring (point) (point-max)))))) + (set-buffer to-buffer) + (save-restriction + (narrow-to-region to-point to-point) + (insert (mh-filter-out-non-text mh-ins-str)) + (goto-char (point-max)) ;Needed for sc-cite-original + (push-mark) ;Needed for sc-cite-original + (goto-char (point-min)) ;Needed for sc-cite-original + (mh-insert-prefix-string mh-ins-buf-prefix) + (if (or (eq 'attribution mh-yank-from-start-of-msg) + (eq 'autoattrib mh-yank-from-start-of-msg)) + (insert from-attr "\n\n")) + ;; If the user has selected a region, he has already "edited" the + ;; text, so leave the cursor at the end of the yanked text. In + ;; either case, leave a mark at the opposite end of the included + ;; text to make it easy to jump or delete to the other end of the + ;; text. + (push-mark) + (goto-char (point-max)) + (if (null yank-region) + (mh-exchange-point-and-mark-preserving-active-mark))))) + (error "There is no current message"))) + +(defun mh-filter-out-non-text (string) + "Return STRING but without adornments such as MIME buttons and smileys." + (with-temp-buffer + ;; Insert the string to filter + (insert string) + (goto-char (point-min)) + + ;; Remove the MIME buttons + (let ((can-move-forward t) + (in-button nil)) + (while can-move-forward + (cond ((and (not (get-text-property (point) 'mh-data)) + in-button) + (delete-region (1- (point)) (point)) + (setq in-button nil)) + ((get-text-property (point) 'mh-data) + (delete-region (point) + (save-excursion (forward-line) (point))) + (setq in-button t)) + (t (setq can-move-forward (= (forward-line) 0)))))) + + ;; Return the contents without properties... This gets rid of emphasis + ;; and smileys + (buffer-substring-no-properties (point-min) (point-max)))) + +(defun mh-insert-prefix-string (mh-ins-string) + "Insert prefix string before each line in buffer. +The inserted letter is cited using `sc-cite-original' if +`mh-yank-from-start-of-msg' is one of 'supercite or 'autosupercite. Otherwise, +simply insert MH-INS-STRING before each line." + (goto-char (point-min)) + (cond ((or (eq mh-yank-from-start-of-msg 'supercite) + (eq mh-yank-from-start-of-msg 'autosupercite)) + (sc-cite-original)) + (mail-citation-hook + (run-hooks 'mail-citation-hook)) + (mh-yank-hooks ;old hook name + (run-hooks 'mh-yank-hooks)) + (t + (or (bolp) (forward-line 1)) + (while (< (point) (point-max)) + (insert mh-ins-string) + (forward-line 1)) + (goto-char (point-min))))) ;leave point like sc-cite-original + +;;;###mh-autoload +(defun mh-fully-kill-draft () + "Kill the draft message file and the draft message buffer. +Use \\[kill-buffer] if you don't want to delete the draft message file." + (interactive) + (if (y-or-n-p "Kill draft message? ") + (let ((config mh-previous-window-config)) + (if (file-exists-p buffer-file-name) + (delete-file buffer-file-name)) + (set-buffer-modified-p nil) + (kill-buffer (buffer-name)) + (message "") + (if config + (set-window-configuration config))) + (error "Message not killed"))) + +(defun mh-current-fill-prefix () + "Return the `fill-prefix' on the current line as a string." + (save-excursion + (beginning-of-line) + ;; This assumes that the major-mode sets up adaptive-fill-regexp + ;; correctly such as mh-letter-mode or sendmail.el's mail-mode. But + ;; perhaps I should use the variable and simply inserts its value here, + ;; and set it locally in a let scope. --psg + (if (re-search-forward adaptive-fill-regexp nil t) + (match-string 0) + ""))) + +;;;###mh-autoload +(defun mh-open-line () + "Insert a newline and leave point after it. +In addition, insert newline and quoting characters before text after point. +This is useful in breaking up paragraphs in replies." + (interactive) + (let ((column (current-column)) + (prefix (mh-current-fill-prefix))) + (if (> (length prefix) column) + (message "Sorry, point seems to be within the line prefix") + (newline 2) + (insert prefix) + (while (> column (current-column)) + (insert " ")) + (forward-line -1)))) + +;;;###mh-autoload +(defun mh-letter-complete (arg) + "Perform completion on header field or word preceding point. +Alias completion is done within the mail header on selected fields and +by the function designated by `mh-letter-complete-function' elsewhere, +passing the prefix ARG if any." + (interactive "P") + (let ((case-fold-search t)) + (if (and (mh-in-header-p) + (save-excursion + (mh-header-field-beginning) + (looking-at "^.*\\(to\\|cc\\|from\\):"))) + (mh-alias-letter-expand-alias) + (funcall mh-letter-complete-function arg)))) + +;;; Build the letter-mode keymap: +;;; If this changes, modify mh-letter-mode-help-messages accordingly, above. +(gnus-define-keys mh-letter-mode-map + "\C-c?" mh-help + "\C-c\C-c" mh-send-letter + "\C-c\C-d" mh-insert-identity + "\C-c\C-e" mh-edit-mhn + "\C-c\C-f\C-b" mh-to-field + "\C-c\C-f\C-c" mh-to-field + "\C-c\C-f\C-d" mh-to-field + "\C-c\C-f\C-f" mh-to-fcc + "\C-c\C-f\C-r" mh-to-field + "\C-c\C-f\C-s" mh-to-field + "\C-c\C-f\C-t" mh-to-field + "\C-c\C-fb" mh-to-field + "\C-c\C-fc" mh-to-field + "\C-c\C-fd" mh-to-field + "\C-c\C-ff" mh-to-fcc + "\C-c\C-fr" mh-to-field + "\C-c\C-fs" mh-to-field + "\C-c\C-ft" mh-to-field + "\C-c\C-i" mh-insert-letter + "\C-c\C-m\C-e" mh-mml-secure-message-encrypt-pgpmime + "\C-c\C-m\C-f" mh-compose-forward + "\C-c\C-m\C-i" mh-compose-insertion + "\C-c\C-m\C-m" mh-mml-to-mime + "\C-c\C-m\C-s" mh-mml-secure-message-sign-pgpmime + "\C-c\C-m\C-u" mh-revert-mhn-edit + "\C-c\C-me" mh-mml-secure-message-encrypt-pgpmime + "\C-c\C-mf" mh-compose-forward + "\C-c\C-mi" mh-compose-insertion + "\C-c\C-mm" mh-mml-to-mime + "\C-c\C-ms" mh-mml-secure-message-sign-pgpmime + "\C-c\C-mu" mh-revert-mhn-edit + "\C-c\C-o" mh-open-line + "\C-c\C-q" mh-fully-kill-draft + "\C-c\C-\\" mh-fully-kill-draft ;if no C-q + "\C-c\C-s" mh-insert-signature + "\C-c\C-^" mh-insert-signature ;if no C-s + "\C-c\C-w" mh-check-whom + "\C-c\C-y" mh-yank-cur-msg + "\M-\t" mh-letter-complete) + +;; "C-c /" prefix is used in mh-letter-mode by pgp.el and mailcrypt.el. + +(provide 'mh-comp) + +;;; Local Variables: +;;; indent-tabs-mode: nil +;;; sentence-end-double-space: nil +;;; End: + +;;; mh-comp.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mh-e/mh-customize.el Sun Jan 26 02:38:37 2003 +0000 @@ -0,0 +1,1751 @@ +;;; mh-customize.el --- MH-E customization + +;; Copyright (C) 2002 Free Software Foundation, Inc. + +;; Author: Bill Wohler <wohler@newt.com> +;; Maintainer: Bill Wohler <wohler@newt.com> +;; Keywords: mail +;; See: mh-e.el + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; All of the defgroups, defcustoms, and deffaces in MH-E are found here. This +;; makes it possible to customize modules that aren't loaded yet. It also +;; makes it easier to organize the customization groups. + +;; This file contains the following sections: +;; +;; 1. MH-E Customization Groups +;; +;; These are the customization group definitions. These are organized in a +;; logical order. High-level, windows and toolbar, folder, message, +;; composing and hooks. +;; +;; 2. MH-E Customization +;; +;; Here are the actual customization variables. There is a sub-section for +;; each group in the MH-E Customization Groups section. Within each +;; section, variables are sorted alphabetically. The manual section +;; dictates which group a variable should be placed. New variables should +;; be placed in the section where they would most likely be defined. +;; +;; All hooks should be placed in the 'mh-hook group; in addition, add the +;; group in which the hook is defined in the manual (or, if it is new, +;; where it would be defined). These two actions insures that the hooks +;; appear last in each group. +;; +;; 3. Faces + +;;; Change Log: + +;; $Id: mh-customize.el,v 1.1 2003/01/08 23:21:16 wohler Exp $ + +;;; Code: + +;;;###mh-autoload +(defun mh-customize () + "Customize MH-E variables." + (interactive) + (customize-group 'mh)) + +;;; MH-E Customization Groups + +(defgroup mh nil + "GNU Emacs interface to the MH mail system." + :link '(custom-manual "(mh-e)Top") + :group 'mail) + +(defgroup mh-toolbar nil + "Toolbar configuration." + :prefix "mh-" + :group 'mh) + +(defgroup mh-speed nil + "Speedbar and folder configuration." + :prefix "mh-" + :link '(custom-manual "(mh-e)Customizing Moving Mail") + :group 'mh) + +(defgroup mh-folder nil + "Options for controlling scan listing." + :prefix "mh-" + :link '(custom-manual "(mh-e)Customizing Moving Mail") + :group 'mh) + +(defgroup mh-show nil + "Message display." + :prefix "mh-" + :link '(custom-manual "(mh-e)Customizing Reading") + :group 'mh) + +(defgroup mh-letter nil + "Composing messages." + :prefix "mh-" + :link '(custom-manual "(mh-e)Customizing Sending") + :group 'mh) + +(defgroup mh-alias nil + "Alias handling." + :link '(custom-manual "(mh-e)Customizing mh-e") + :prefix "mh-alias-" + :group 'mh) + +(defgroup mh-index nil + "Indexed searching." + :link '(custom-manual "(mh-e)Customizing mh-e") + :prefix "mh-" + :group 'mh) + +(defgroup mh-identity nil + "Multiple personalities." + :link '(custom-manual "(mh-e)Customizing mh-e") + :prefix "mh-" + :group 'mh) + +(defgroup mh-faces nil + "Faces used in MH-E." + :link '(custom-manual "(mh-e)Customizing mh-e") + :prefix "mh-" + :group 'faces + :group 'mh) + +(defgroup mh-hooks nil + "MH-E hooks." + :link '(custom-manual "(mh-e)Customizing mh-e") + :prefix "mh-" + :group 'mh) + +;;; Faces + +(defgroup mh-speed-faces nil + "Faces used in speedbar." + :link '(custom-manual "(mh-e)Customizing mh-e") + :prefix "mh-" + :group 'mh-faces + :group 'mh-speed) + +(defgroup mh-folder-faces nil + "Faces used in scan listing." + :link '(custom-manual "(mh-e)Customizing mh-e") + :prefix "mh-" + :group 'mh-faces + :group 'mh-folder) + +(defgroup mh-show-faces nil + "Faces used in message display." + :link '(custom-manual "(mh-e)Customizing mh-e") + :prefix "mh-" + :group 'mh-faces + :group 'mh-show) + +(defgroup mh-index-faces nil + "Faces used in indexed searches." + :link '(custom-manual "(mh-e)Customizing mh-e") + :prefix "mh-" + :group 'mh-faces + :group 'mh-index) + + + +;;; MH-E Customization (:group mh) + +;;; Toolbar configuration (:group 'mh-toolbar) + +(defconst mh-tool-bar-item-inc "Incorporate new mail in Inbox") +(defconst mh-tool-bar-item-save-mime "Save MIME parts") +(defconst mh-tool-bar-item-prev-msg "Previous message") +(defconst mh-tool-bar-item-page-msg "Page this message") +(defconst mh-tool-bar-item-next-msg "Next message") +(defconst mh-tool-bar-item-delete "Mark for deletion") +(defconst mh-tool-bar-item-refile "Refile this message") +(defconst mh-tool-bar-item-undo "Undo this mark") +(defconst mh-tool-bar-item-perform "Perform moves and deletes") +(defconst mh-tool-bar-item-toggle-show "Toggle showing message") +(defconst mh-tool-bar-item-reply-from "Reply to \"from\"") +(defconst mh-tool-bar-item-reply-to "Reply to \"to\"") +(defconst mh-tool-bar-item-reply-all "Reply to \"all\"") +(defconst mh-tool-bar-item-reply "Reply to this message") +(defconst mh-tool-bar-item-alias "Grab From alias") +(defconst mh-tool-bar-item-compose "Compose new message") +(defconst mh-tool-bar-item-rescan "Rescan this folder") +(defconst mh-tool-bar-item-repack "Repack this folder") +(defconst mh-tool-bar-item-search "Search") +(defconst mh-tool-bar-item-visit "Visit other folder") +(defconst mh-tool-bar-item-prefs "MH-E preferences") +(defconst mh-tool-bar-item-help "Help") +(defconst mh-tool-bar-item-widen "Widen from this sequence") + +(defconst mh-tool-bar-item-send "Send this letter") +(defconst mh-tool-bar-item-attach "Insert attachment") +(defconst mh-tool-bar-item-spell "Check spelling") +(defconst mh-tool-bar-item-save "Save current buffer to its file") +(defconst mh-tool-bar-item-undo-op "Undo last operation") +(defconst mh-tool-bar-item-kill + "Cut (kill) text in region between mark and current position") +(defconst mh-tool-bar-item-copy + "Copy text in region between mark and current position") +(defconst mh-tool-bar-item-paste + "Paste (yank) text cut or copied earlier") +(defconst mh-tool-bar-item-kill-draft "Kill this draft") +(defconst mh-tool-bar-item-comp-prefs "MH-E composition preferences") + +(defcustom mh-tool-bar-reply-3-buttons-flag nil + "*Non-nil means use three buttons for reply commands in tool-bar. +If you have room on your tool-bar because you are using a large font, you +may set this variable to expand the single reply button into three buttons +that won't lead to minibuffer prompt about who to reply to." + :type 'boolean + :group 'mh-toolbar) + +(defcustom mh-tool-bar-search-function 'mh-search-folder + "*Function called by the tool-bar search button. +See `mh-search-folder' and `mh-index-search' for details." + :type '(choice (const mh-search-folder) + (const mh-index-search) + (function :tag "Other function")) + :group 'mh-toolbar) + +(eval-when-compile (defvar tool-bar-map)) +(defvar mh-show-tool-bar-map nil) +(defun mh-tool-bar-show-set () + "Construct toolbar for `mh-show-mode'." + (when (fboundp 'tool-bar-add-item) + (setq + mh-show-tool-bar-map + (let ((tool-bar-map (make-sparse-keymap))) + (if (member mh-tool-bar-item-inc mh-tool-bar-folder-buttons) + (tool-bar-add-item "mail" 'mh-inc-folder 'mh-showtoolbar-inc-folder + :help mh-tool-bar-item-inc)) + (if (member mh-tool-bar-item-save-mime mh-tool-bar-folder-buttons) + (tool-bar-add-item "attach" 'mh-mime-save-parts + 'mh-showtoolbar-mime-save-parts + :help mh-tool-bar-item-save-mime)) + (if (member mh-tool-bar-item-prev-msg mh-tool-bar-folder-buttons) + (tool-bar-add-item "left_arrow" 'mh-show-previous-undeleted-msg + 'mh-showtoolbar-prev + :help mh-tool-bar-item-prev-msg)) + (if (member mh-tool-bar-item-page-msg mh-tool-bar-folder-buttons) + (tool-bar-add-item "page-down" 'mh-show-page-msg 'mh-showtoolbar-page + :help mh-tool-bar-item-page-msg)) + (if (member mh-tool-bar-item-next-msg mh-tool-bar-folder-buttons) + (tool-bar-add-item "right_arrow" 'mh-show-next-undeleted-msg + 'mh-showtoolbar-next + :help mh-tool-bar-item-next-msg)) + (if (member mh-tool-bar-item-delete mh-tool-bar-folder-buttons) + (tool-bar-add-item "close" 'mh-show-delete-msg + 'mh-showtoolbar-delete + :help mh-tool-bar-item-delete)) + (if (member mh-tool-bar-item-refile mh-tool-bar-folder-buttons) + (tool-bar-add-item "refile" 'mh-show-refile-msg + 'mh-showtoolbar-refile + :help mh-tool-bar-item-refile)) + (if (member mh-tool-bar-item-undo mh-tool-bar-folder-buttons) + (tool-bar-add-item "undo" 'mh-show-undo 'mh-showtoolbar-undo + :help mh-tool-bar-item-undo)) + (if (member mh-tool-bar-item-perform mh-tool-bar-folder-buttons) + (tool-bar-add-item "execute" 'mh-show-execute-commands + 'mh-showtoolbar-exec + :help mh-tool-bar-item-perform)) + (if (member mh-tool-bar-item-toggle-show mh-tool-bar-folder-buttons) + (tool-bar-add-item "show" 'mh-show-toggle-showing + 'mh-showtoolbar-toggle-show + :help mh-tool-bar-item-toggle-show)) + (if (member mh-tool-bar-item-reply-from mh-tool-bar-folder-buttons) + (tool-bar-add-item "reply-from" + (lambda (&optional arg) + (interactive "P") + (set-buffer mh-show-folder-buffer) + (mh-reply (mh-get-msg-num nil) "from" arg)) + 'mh-showtoolbar-reply-from + :help mh-tool-bar-item-reply-from)) + (if (member mh-tool-bar-item-reply-to mh-tool-bar-folder-buttons) + (tool-bar-add-item "reply-to" + (lambda (&optional arg) + (interactive "P") + (set-buffer mh-show-folder-buffer) + (mh-reply (mh-get-msg-num nil) "to" arg)) + 'mh-showtoolbar-reply-to + :help mh-tool-bar-item-reply-to)) + (if (member mh-tool-bar-item-reply-all mh-tool-bar-folder-buttons) + (tool-bar-add-item "reply-all" + (lambda (&optional arg) + (interactive "P") + (set-buffer mh-show-folder-buffer) + (mh-reply (mh-get-msg-num nil) "all" arg)) + 'mh-showtoolbar-reply-all + :help mh-tool-bar-item-reply-all)) + (if (member mh-tool-bar-item-reply mh-tool-bar-folder-buttons) + (tool-bar-add-item "mail/reply2" 'mh-show-reply + 'mh-showtoolbar-reply + :help mh-tool-bar-item-reply)) + (if (member mh-tool-bar-item-alias mh-tool-bar-folder-buttons) + (tool-bar-add-item "alias" 'mh-alias-grab-from-field + 'mh-showtoolbar-alias + :help mh-tool-bar-item-alias + :enable '(mh-alias-from-has-no-alias-p))) + (if (member mh-tool-bar-item-compose mh-tool-bar-folder-buttons) + (tool-bar-add-item "mail_compose" 'mh-send 'mh-showtoolbar-compose + :help mh-tool-bar-item-compose)) + (if (member mh-tool-bar-item-rescan mh-tool-bar-folder-buttons) + (tool-bar-add-item "rescan" 'mh-show-rescan-folder + 'mh-showtoolbar-rescan + :help mh-tool-bar-item-rescan)) + (if (member mh-tool-bar-item-repack mh-tool-bar-folder-buttons) + (tool-bar-add-item "repack" 'mh-show-pack-folder + 'mh-showtoolbar-pack + :help mh-tool-bar-item-repack)) + (if (member mh-tool-bar-item-search mh-tool-bar-folder-buttons) + (tool-bar-add-item "search" + (lambda (&optional arg) + (interactive "P") + (call-interactively + mh-tool-bar-search-function)) + 'mh-showtoolbar-search + :help mh-tool-bar-item-search)) + (if (member mh-tool-bar-item-visit mh-tool-bar-folder-buttons) + (tool-bar-add-item "fld_open" 'mh-visit-folder + 'mh-showtoolbar-visit + :help mh-tool-bar-item-visit)) + (if (member mh-tool-bar-item-prefs mh-tool-bar-folder-buttons) + (tool-bar-add-item "preferences" (lambda () + (interactive) + (customize-group "mh")) + 'mh-showtoolbar-customize + :help mh-tool-bar-item-prefs)) + (if (member mh-tool-bar-item-help mh-tool-bar-folder-buttons) + (tool-bar-add-item "help" (lambda () + (interactive) + (Info-goto-node "(mh-e)Top")) + 'mh-showtoolbar-help + :help mh-tool-bar-item-help)) + tool-bar-map)))) + +(defvar mh-letter-tool-bar-map nil) +;;;###mh-autoload +(defun mh-tool-bar-letter-set () + "Construct toolbar for `mh-letter-mode'." + (when (fboundp 'tool-bar-add-item) + (setq + mh-letter-tool-bar-map + (let ((tool-bar-map (make-sparse-keymap))) + (if (member mh-tool-bar-item-send mh-tool-bar-letter-buttons) + (tool-bar-add-item "mail_send" 'mh-send-letter + 'mh-lettertoolbar-send + :help mh-tool-bar-item-send)) + (if (member mh-tool-bar-item-attach mh-tool-bar-letter-buttons) + (tool-bar-add-item "attach" 'mh-compose-insertion + 'mh-lettertoolbar-compose + :help mh-tool-bar-item-attach)) + (if (member mh-tool-bar-item-spell mh-tool-bar-letter-buttons) + (tool-bar-add-item "spell" 'ispell-message 'mh-lettertoolbar-ispell + :help mh-tool-bar-item-spell)) + (if (member mh-tool-bar-item-save mh-tool-bar-letter-buttons) + (tool-bar-add-item-from-menu 'save-buffer "save")) + (if (member mh-tool-bar-item-undo-op mh-tool-bar-letter-buttons) + (tool-bar-add-item-from-menu 'undo "undo")) + (if (member mh-tool-bar-item-kill mh-tool-bar-letter-buttons) + (tool-bar-add-item-from-menu 'kill-region "cut")) + (if (member mh-tool-bar-item-copy mh-tool-bar-letter-buttons) + (tool-bar-add-item-from-menu 'menu-bar-kill-ring-save "copy")) + (if (member mh-tool-bar-item-paste mh-tool-bar-letter-buttons) + (tool-bar-add-item-from-menu 'yank "paste")) + (if (member mh-tool-bar-item-kill-draft mh-tool-bar-letter-buttons) + (tool-bar-add-item "close" 'mh-fully-kill-draft + 'mh-lettertoolbar-kill + :help mh-tool-bar-item-kill-draft)) + (if (member mh-tool-bar-item-comp-prefs mh-tool-bar-letter-buttons) + (tool-bar-add-item "preferences" (lambda () + (interactive) + (customize-group "mh-compose")) + 'mh-lettertoolbar-customize + :help mh-tool-bar-item-comp-prefs)) + (if (member mh-tool-bar-item-help mh-tool-bar-letter-buttons) + (tool-bar-add-item "help" (lambda () + (interactive) + (Info-goto-node "(mh-e)Draft Editing")) + 'mh-lettertoolbar-help + :help mh-tool-bar-item-help)) + tool-bar-map)))) + +(defvar mh-folder-tool-bar-map nil) +(defvar mh-folder-seq-tool-bar-map nil + "Tool-bar to use when narrowed to a sequence in MH-Folder buffers.") +;;;###mh-autoload +(defun mh-tool-bar-folder-set () + "Construct toolbar for `mh-folder-mode'." + (when (fboundp 'tool-bar-add-item) + (setq + mh-folder-tool-bar-map + (let ((tool-bar-map (make-sparse-keymap))) + (if (member mh-tool-bar-item-inc mh-tool-bar-folder-buttons) + (tool-bar-add-item "mail" 'mh-inc-folder + 'mh-foldertoolbar-inc-folder + :help mh-tool-bar-item-inc)) + (if (member mh-tool-bar-item-save-mime mh-tool-bar-folder-buttons) + (tool-bar-add-item "attach" 'mh-mime-save-parts + 'mh-foldertoolbar-mime-save-parts + :help mh-tool-bar-item-save-mime)) + (if (member mh-tool-bar-item-prev-msg mh-tool-bar-folder-buttons) + (tool-bar-add-item "left_arrow" 'mh-previous-undeleted-msg + 'mh-foldertoolbar-prev + :help mh-tool-bar-item-prev-msg)) + (if (member mh-tool-bar-item-page-msg mh-tool-bar-folder-buttons) + (tool-bar-add-item "page-down" 'mh-page-msg 'mh-foldertoolbar-page + :help mh-tool-bar-item-page-msg)) + (if (member mh-tool-bar-item-next-msg mh-tool-bar-folder-buttons) + (tool-bar-add-item "right_arrow" 'mh-next-undeleted-msg + 'mh-foldertoolbar-next + :help mh-tool-bar-item-next-msg)) + (if (member mh-tool-bar-item-delete mh-tool-bar-folder-buttons) + (tool-bar-add-item "close" 'mh-delete-msg 'mh-foldertoolbar-delete + :help mh-tool-bar-item-delete)) + (if (member mh-tool-bar-item-refile mh-tool-bar-folder-buttons) + (tool-bar-add-item "refile" 'mh-refile-msg 'mh-foldertoolbar-refile + :help mh-tool-bar-item-refile)) + (if (member mh-tool-bar-item-undo mh-tool-bar-folder-buttons) + (tool-bar-add-item "undo" 'mh-undo 'mh-foldertoolbar-undo + :help mh-tool-bar-item-undo)) + (if (member mh-tool-bar-item-perform mh-tool-bar-folder-buttons) + (tool-bar-add-item "execute" 'mh-execute-commands + 'mh-foldertoolbar-exec + :help mh-tool-bar-item-perform)) + (if (member mh-tool-bar-item-toggle-show mh-tool-bar-folder-buttons) + (tool-bar-add-item "show" 'mh-toggle-showing + 'mh-foldertoolbar-toggle-show + :help mh-tool-bar-item-toggle-show)) + (if (member mh-tool-bar-item-reply-from mh-tool-bar-folder-buttons) + (tool-bar-add-item "reply-from" + (lambda (&optional arg) + (interactive "P") + (mh-reply (mh-get-msg-num nil) "from" arg)) + 'mh-foldertoolbar-reply-from + :help mh-tool-bar-item-reply-from)) + (if (member mh-tool-bar-item-reply-to mh-tool-bar-folder-buttons) + (tool-bar-add-item "reply-to" + (lambda (&optional arg) + (interactive "P") + (mh-reply (mh-get-msg-num nil) "to" arg)) + 'mh-foldertoolbar-reply-to + :help mh-tool-bar-item-reply-to)) + (if (member mh-tool-bar-item-reply-all mh-tool-bar-folder-buttons) + (tool-bar-add-item "reply-all" + (lambda (&optional arg) + (interactive "P") + (mh-reply (mh-get-msg-num nil) "all" arg)) + 'mh-foldertoolbar-reply-all + :help mh-tool-bar-item-reply-all)) + (if (member mh-tool-bar-item-reply mh-tool-bar-folder-buttons) + (tool-bar-add-item "mail/reply2" 'mh-reply + 'mh-foldertoolbar-reply + :help mh-tool-bar-item-reply)) + (if (member mh-tool-bar-item-alias mh-tool-bar-folder-buttons) + (tool-bar-add-item "alias" 'mh-alias-grab-from-field + 'mh-foldertoolbar-alias + :help mh-tool-bar-item-alias + :enable '(mh-alias-from-has-no-alias-p))) + (if (member mh-tool-bar-item-compose mh-tool-bar-folder-buttons) + (tool-bar-add-item "mail_compose" 'mh-send 'mh-foldertoolbar-compose + :help mh-tool-bar-item-compose)) + (if (member mh-tool-bar-item-rescan mh-tool-bar-folder-buttons) + (tool-bar-add-item "rescan" 'mh-rescan-folder + 'mh-foldertoolbar-rescan + :help mh-tool-bar-item-rescan)) + (if (member mh-tool-bar-item-repack mh-tool-bar-folder-buttons) + (tool-bar-add-item "repack" 'mh-pack-folder 'mh-foldertoolbar-pack + :help mh-tool-bar-item-repack)) + (if (member mh-tool-bar-item-search mh-tool-bar-folder-buttons) + (tool-bar-add-item "search" + (lambda (&optional arg) + (interactive "P") + (call-interactively + mh-tool-bar-search-function)) + 'mh-foldertoolbar-search + :help mh-tool-bar-item-search)) + (if (member mh-tool-bar-item-visit mh-tool-bar-folder-buttons) + (tool-bar-add-item "fld_open" 'mh-visit-folder + 'mh-foldertoolbar-visit + :help mh-tool-bar-item-visit)) + (if (member mh-tool-bar-item-prefs mh-tool-bar-folder-buttons) + (tool-bar-add-item "preferences" (lambda () + (interactive) + (customize-group "mh")) + 'mh-foldertoolbar-customize + :help mh-tool-bar-item-prefs)) + (if (member mh-tool-bar-item-help mh-tool-bar-folder-buttons) + (tool-bar-add-item "help" (lambda () + (interactive) + (Info-goto-node "(mh-e)Top")) + 'mh-foldertoolbar-help + :help mh-tool-bar-item-help)) + tool-bar-map)) + + (setq mh-folder-seq-tool-bar-map + (let ((tool-bar-map (copy-keymap mh-folder-tool-bar-map))) + (if (member mh-tool-bar-item-widen mh-tool-bar-folder-buttons) + (tool-bar-add-item "widen" 'mh-widen 'mh-foldertoolbar-widen + :help mh-tool-bar-item-widen)) + tool-bar-map)))) + +(defun mh-tool-bar-folder-buttons-set (symbol value) + "Update the `mh-tool-bar-folder-buttons' variable, and rebuild the tool-bar. +Sets the default for SYMBOL (e.g. `mh-tool-bar-folder-buttons') to VALUE (as +set in customization). This is called after 'customize is used to alter +`mh-tool-bar-folder-buttons'." + (set-default symbol value) + (mh-tool-bar-show-set) + (mh-tool-bar-folder-set)) + +(custom-declare-variable + 'mh-tool-bar-folder-buttons + '(append + (list mh-tool-bar-item-inc + mh-tool-bar-item-save-mime + mh-tool-bar-item-prev-msg + mh-tool-bar-item-page-msg + mh-tool-bar-item-next-msg + mh-tool-bar-item-delete + mh-tool-bar-item-refile + mh-tool-bar-item-undo + mh-tool-bar-item-perform +;;; mh-tool-bar-item-toggle-show + ) + (if mh-tool-bar-reply-3-buttons-flag + (list mh-tool-bar-item-reply-from + mh-tool-bar-item-reply-to + mh-tool-bar-item-reply-all) + (list mh-tool-bar-item-reply)) + (list mh-tool-bar-item-alias + mh-tool-bar-item-compose + mh-tool-bar-item-rescan +;;; mh-tool-bar-item-repack + mh-tool-bar-item-search + mh-tool-bar-item-visit + mh-tool-bar-item-prefs + mh-tool-bar-item-help + mh-tool-bar-item-widen)) + "Buttons to include in MH-E folder/show toolbar." + :group 'mh-toolbar + :set 'mh-tool-bar-folder-buttons-set + :type `(set (const ,mh-tool-bar-item-inc) + (const ,mh-tool-bar-item-save-mime) + (const ,mh-tool-bar-item-prev-msg) + (const ,mh-tool-bar-item-page-msg) + (const ,mh-tool-bar-item-next-msg) + (const ,mh-tool-bar-item-delete) + (const ,mh-tool-bar-item-refile) + (const ,mh-tool-bar-item-undo) + (const ,mh-tool-bar-item-perform) + (const ,mh-tool-bar-item-toggle-show) + (const ,mh-tool-bar-item-reply-from) + (const ,mh-tool-bar-item-reply-to) + (const ,mh-tool-bar-item-reply-all) + (const ,mh-tool-bar-item-reply) + (const ,mh-tool-bar-item-alias) + (const ,mh-tool-bar-item-compose) + (const ,mh-tool-bar-item-rescan) + (const ,mh-tool-bar-item-repack) + (const ,mh-tool-bar-item-search) + (const ,mh-tool-bar-item-visit) + (const ,mh-tool-bar-item-prefs) + (const ,mh-tool-bar-item-help) + (const ,mh-tool-bar-item-widen))) + +(defun mh-tool-bar-letter-buttons-set (symbol value) + "Update the `mh-tool-bar-letter-buttons' variable, and rebuild the tool-bar. +Sets the default for SYMBOL (e.g. `mh-tool-bar-letter-buttons') to VALUE (as +set in customization). This is called after 'customize is used to alter +`mh-tool-bar-letter-buttons'." + (set-default symbol value) + (mh-tool-bar-letter-set)) + +(custom-declare-variable + 'mh-tool-bar-letter-buttons + '(list mh-tool-bar-item-send + mh-tool-bar-item-attach + mh-tool-bar-item-spell + mh-tool-bar-item-save + mh-tool-bar-item-undo-op + mh-tool-bar-item-kill + mh-tool-bar-item-copy + mh-tool-bar-item-paste + mh-tool-bar-item-kill-draft + mh-tool-bar-item-comp-prefs + mh-tool-bar-item-help) + "Buttons to include in MH-E letter toolbar." + :group 'mh-toolbar + :set 'mh-tool-bar-letter-buttons-set + :type `(set (const ,mh-tool-bar-item-send) + (const ,mh-tool-bar-item-attach) + (const ,mh-tool-bar-item-spell) + (const ,mh-tool-bar-item-save) + (const ,mh-tool-bar-item-undo-op) + (const ,mh-tool-bar-item-kill) + (const ,mh-tool-bar-item-copy) + (const ,mh-tool-bar-item-paste) + (const ,mh-tool-bar-item-kill-draft) + (const ,mh-tool-bar-item-comp-prefs) + (const ,mh-tool-bar-item-help))) + + + +;;; Speedbar and folder configuration (:group 'mh-speed) + +(defcustom mh-large-folder 200 + "The number of messages that indicates a large folder. +If a folder is deemed to be large, that is the number of messages in it exceed +this value, then confirmation is needed when it is visited. Even when +`mh-show-threads-flag' is non-nil, the folder is not automatically threaded, if +it is large. If set to nil all folders are treated as if they are small." + :type '(choice (const :tag "No limit") integer) + :group 'mh-speed) + +(defcustom mh-speed-flists-interval 60 + "Time between calls to flists in seconds. +If 0, flists is not called repeatedly." + :type 'integer + :group 'mh-speed) + +(defcustom mh-speed-run-flists-flag t + "Non-nil means flists is used. +If non-nil, flists is executed every `mh-speed-flists-interval' seconds to +update the display of the number of unseen and total messages in each folder. +If resources are limited, this can be set to nil and the speedbar display can +be updated manually with the \\[mh-speed-flists] command." + :type 'boolean + :group 'mh-speed) + +;;; Options for controlling scan listing (:group 'mh-folder) + +(defcustom mh-adaptive-cmd-note-flag t + "*Non-nil means that the message number width is determined dynamically. +This is done once when a folder is first opened by running scan on the last +message of the folder. The message number for the last message is extracted +and its width calculated. This width is used when calling `mh-set-cmd-note'. + +If you prefer fixed-width message numbers, set this variable to nil and call +`mh-set-cmd-note' with the width specified by the scan format in +`mh-scan-format-file'. For example, the default width is 4, so you would use +\"(mh-set-cmd-note 4)\" if `mh-scan-format-file' were nil." + :type 'boolean + :group 'mh-folder) + +(defcustom mh-auto-folder-collect-flag t + "*Non-nil means to collect all folder names at startup in the background. +Otherwise, the internal list of folder names is built as folders are +referenced." + :type 'boolean + :group 'mh-folder) + +(defcustom mh-inc-prog "inc" + "*Program to run to incorporate new mail into a folder. +Normally \"inc\". This file is searched for relative to +the `mh-progs' directory unless it is an absolute pathname." + :type 'string + :group 'mh-folder) + +(defcustom mh-lpr-command-format "lpr -J '%s'" + "*Format for Unix command that prints a message. +The string should be a Unix command line, with the string '%s' where +the job's name (folder and message number) should appear. The formatted +message text is piped to this command when you type \\<mh-folder-mode-map>`\\[mh-print-msg]'." + :type 'string + :group 'mh-folder) + +(defcustom mh-mime-save-parts-default-directory t + "Default directory to use for `mh-mime-save-parts'. +If nil, prompt and set for next time the command is used during same session. +If t, prompt always" + :type '(choice (const :tag "Prompt the first time" nil) + (const :tag "Prompt always" t) + directory) + :group 'mh-folder) + +(defcustom mh-recenter-summary-flag nil + "*Non-nil means to recenter the summary window. +Recenter the summary window when the show window is toggled off if non-nil." + :type 'boolean + :group 'mh-folder) + +(defcustom mh-print-background-flag nil + "*Non-nil means messages should be printed in the background. +WARNING: do not delete the messages until printing is finished; +otherwise, your output may be truncated." + :type 'boolean + :group 'mh-folder) + +(defcustom mh-recursive-folders-flag nil + "*Non-nil means that commands which operate on folders do so recursively." + :type 'boolean + :group 'mh-folder) + +(defcustom mh-scan-format-file t + "Specifies the format file to pass to the scan program. +If t, the format string will be taken from the either `mh-scan-format-mh' +or `mh-scan-format-nmh' depending on whether MH or nmh is in use. +If nil, the default scan output will be used. + +If you customize the scan format, you may need to modify a few variables +containing regexps that MH-E uses to identify specific portions of the output. +Use `M-x apropos RET mh-scan.*regexp' to obtain a list of these variables. You +may also have to call `mh-set-cmd-note' with the width of your message +numbers. See also `mh-adaptive-cmd-note-flag'." + :type '(choice (const :tag "Use MH-E scan format" t) + (const :tag "Use default scan format" nil) + (file :tag "Specify a scan format file")) + :group 'mh-folder) + +(defcustom mh-scan-prog "scan" + "*Program to run to generate one-line-per-message listing of a folder. +Normally \"scan\" or a file name linked to scan. This file is searched +for relative to the `mh-progs' directory unless it is an absolute pathname." + :type 'string + :group 'mh-folder) +(make-variable-buffer-local 'mh-scan-prog) + +(defcustom mh-show-threads-flag nil + "Non-nil means new folders start in threaded mode. +Threading large number of messages can be time consuming. So if the flag is +non-nil then threading will be done only if the number of messages being +threaded is less than `mh-large-folder'." + :type 'boolean + :group 'mh-folder) + +(defcustom mh-store-default-directory nil + "*Last directory used by \\[mh-store-msg]; default for next store. +A directory name string, or nil to use current directory." + :type '(choice (const :tag "Current" nil) + directory) + :group 'mh-folder) + +(defcustom mh-update-sequences-after-mh-show-flag t + "*Non-nil means `mh-update-sequence' is called from `mh-show-mode'. +If set, `mh-update-sequence' is run every time a message is shown, telling +MH or nmh that this is your current message. It's useful, for example, to +display MIME content using \"M-! mhshow RET\"" + :type 'boolean + :group 'mh-folder) + +;;; Message display (:group 'mh-show) + +(defcustom mh-bury-show-buffer-flag t + "*Non-nil means that the displayed show buffer for a folder is buried." + :type 'boolean + :group 'mh-show) + +(defcustom mh-clean-message-header-flag t + "*Non-nil means clean headers of messages that are displayed or inserted. +The variables `mh-invisible-headers' and `mh-visible-headers' control +what is removed." + :type 'boolean + :group 'mh-show) + +(defcustom mh-decode-mime-flag (not (not (locate-library "mm-decode"))) + "*Non-nil means that Gnus is used to show MIME attachments with Gnus." + :type 'boolean + :group 'mh-show) + +(defcustom mh-decode-quoted-printable-flag + (not (null (and (fboundp 'executable-find)(executable-find "mimedecode")))) + "Non-nil means decode quoted-printable MIME part with `mimedecode'. + +Quoted-printable message parts are translated to 8-bit characters by the +`mimedecode' command. However, unless there is only one quoted-printable body +part, Gnus will have already decoded the quoted-printable parts. + +This variable is initialized t if `mimedecode' is available. + +The source code for `mimedecode' can be obtained from +http://www.freesoft.org/CIE/FAQ/mimedeco.c." + :type 'boolean + :group 'mh-show) + +(defcustom mh-display-buttons-for-inline-parts-flag nil + "*Non-nil means display buttons for all inline MIME parts. +If non-nil, buttons are displayed for all MIME parts. Inline parts start off +in displayed state but they can be hidden by clicking the button. If nil no +buttons are shown for inline parts." + :type 'boolean + :group 'mh-show) + +(defcustom mh-do-not-confirm-flag nil + "*Non-nil means do not prompt for confirmation. +Commands such as `mh-pack-folder' prompt to confirm whether to process +outstanding moves and deletes or not before continuing. A non-nil setting will +perform the action--which is usually desired but cannot be retracted--without +question." + :type 'boolean + :group 'mh-show) + +(defcustom mh-graphical-smileys-flag t + "*Non-nil means graphical smileys are displayed. +Non-nil means that small graphics will be used in the show buffer instead of +patterns like :-), ;-) etc. The setting only has effect if +`mh-decode-mime-flag' is non-nil." + :type 'boolean + :group 'mh-show) + +(defcustom mh-graphical-emphasis-flag t + "*Non-nil means graphical emphasis is displayed. +Non-nil means that _underline_ will be underlined, *bold* will appear in bold, +/italic/ will appear in italic etc. See `gnus-emphasis-alist' for the whole +list. The setting only has effect if `mh-decode-mime-flag' is non-nil." + :type 'boolean + :group 'mh-show) + +(defcustom mh-highlight-citation-p 'gnus + "How to highlight citations in show buffers. +The gnus method uses a different color for each indentation." + :type '(choice (const :tag "Use gnus" gnus) + (const :tag "Use font-lock" font-lock) + (const :tag "Don't fontify" nil)) + :group 'mh-show) + +(defcustom mh-max-inline-image-height nil + "*Maximum inline image height if Content-Disposition is not present. +If nil, image will be displayed if its height is smaller than the height of +the window." + :type '(choice (const nil) integer) + :group 'mh-show) + +(defcustom mh-max-inline-image-width nil + "*Maximum inline image width if Content-Disposition is not present. +If nil, image will be displayed if its width is smaller than the width of the +window." + :type '(choice (const nil) integer) + :group 'mh-show) + +(defcustom mh-show-maximum-size 0 + "*Maximum size of message (in bytes) to display automatically. +Provides an opportunity to skip over large messages which may be slow to load. +Use a value of 0 to display all messages automatically regardless of size." + :type 'integer + :group 'mh-show) + +;; Use goto-addr if it was already loaded (which probably sets this +;; variable to t), or if this variable is otherwise set to t. +(defcustom mh-show-use-goto-addr-flag (and (boundp 'goto-address-highlight-p) + goto-address-highlight-p) + "*Non-nil means highlight URLs and email addresses. +The `goto-addr' module is used." + :type 'boolean + :group 'mh-show) + +(defcustom mh-show-use-xface-flag + (and window-system + (not (null (cond + (mh-xemacs-flag + (locate-library "x-face")) + ((>= emacs-major-version 21) + (locate-library "x-face-e21")) + (t ;Emacs20 + nil)))) + (not (null (and (fboundp 'executable-find) + (executable-find + "uncompface"))))) + "*Non-nil means display faces in `mh-show-mode' with external x-face package. +It is available from ftp://ftp.jpl.org/pub/elisp/. Download it and put its +files in the Emacs `load-path' and MH-E will invoke it automatically for you if +this variable is non-nil. + +The `uncompface' binary is also required to be in the execute PATH. It can +be obtained from: ftp://ftp.cs.indiana.edu/pub/faces/compface/compface.tar.Z" + :type 'boolean + :group 'mh-show) + +(defcustom mh-summary-height (or (and (fboundp 'frame-height) + (> (frame-height) 24) + (min 10 (/ (frame-height) 6))) + 4) + "*Number of lines in MH-Folder window (including the mode line)." + :type 'integer + :group 'mh-show) + +(defcustom mh-visible-headers nil + "*Contains a regexp specifying the headers to keep when cleaning. +Only used if `mh-clean-message-header-flag' is non-nil. Setting it overrides +the variable `mh-invisible-headers'." + :type '(choice (const nil) regexp) + :group 'mh-show) + +(defcustom mhl-formfile nil + "*Name of format file to be used by mhl to show and print messages. +A value of t means use the default format file. +nil means don't use mhl to format messages when showing; mhl is still used, +with the default format file, to format messages when printing them. +The format used should specify a non-zero value for overflowoffset so +the message continues to conform to RFC 822 and MH-E can parse the headers." + :type '(choice (const nil) (const t) string) + :group 'mh-show) +(put 'mhl-formfile 'info-file "mh-e") + +(defvar mh-invisible-headers nil + "*Regexp matching lines in a message header that are not to be shown. +If `mh-visible-headers' is non-nil, it is used instead to specify what +to keep.") + +(defun mh-invisible-headers () + "Make or remake the variable `mh-invisible-headers'. +Done using `mh-invisible-header-fields' as input." + (setq mh-invisible-headers + (concat + "^" + (let ((max-specpdl-size 1000)) ;workaround for insufficient default + (regexp-opt + (append + (if (not mh-show-use-xface-flag) + '("X-Face: ")) + mh-invisible-header-fields)))))) + +(defun mh-invisible-header-fields-set (symbol value) + "Update `mh-invisible-header-fields'. +The function is called with SYMBOL bound to `mh-invisible-header-fields' and +VALUE is the the list of headers that are invisible. As a side effect, the +variable `mh-invisible-fields' is set." + (set-default symbol value) + (mh-invisible-headers)) + +;; Keep fields alphabetized. Mention source, if known. +(defcustom mh-invisible-header-fields + '("Autoforwarded: " + "Bestservhost: " + "Content-" ; RFC 2045 + "Delivered-To: " ; Egroups/yahoogroups mailing list manager + "Delivery-Date: " ; MH + "Delivery: " + "Encoding: " + "Errors-To: " + "Forwarded: " ; MH + "From " ; sendmail + "Importance: " ; MS Outlook + "In-Reply-To: " ; MH + "Lines: " + "List-" ; Mailman mailing list manager + "List-" ; Unknown mailing list managers + "List-Subscribe: " ; Unknown mailing list managers + "List-Unsubscribe: " ; Unknown mailing list managers + "Mail-from: " ; MH + "Mailing-List: " ; Egroups/yahoogroups mailing list manager + "Message-Id: " ; RFC 822 + "Mime-Version" ; RFC 2045 + "NNTP-" ; News + "Old-Return-Path: " + "Original-Encoded-Information-Types: " ; X400 + "P1-Content-Type: " ; X400 + "P1-Message-Id: " ; X400 + "P1-Recipient: " ; X400 + "Path: " + "Precedence: " + "Prev-Resent" ; MH + "Priority: " + "Received: " ; RFC 822 + "References: " + "Remailed-" ; MH + "Replied: " ; MH + "Resent" ; MH + "Return-Path: " ; RFC 822 + "Sensitivity: " ; MS Outlook + "Status: " ; sendmail + "Ua-Content-Id: " ; X400 + "User-Agent: " + "Via: " ; MH + "X-Abuse-Info: " + "X-Accept-Language: " + "X-Accept-Language: " ; Netscape/Mozilla + "X-Ack: " + "X-Apparently-From: " ; MS Outlook + "X-Apparently-To: " ; Egroups/yahoogroups mailing list manager + "X-Authentication-Warning: " ; sendmail + "X-Beenthere: " ; Mailman mailing list manager + "X-Complaints-To: " + "X-Cron-Env: " + "X-Delivered" + "X-Envelope-Sender: " + "X-Envelope-To: " + "X-Folder: " ; Spam + "X-From-Line" + "X-Gnus-Mail-Source: " ; gnus + "X-Habeas-SWE-1: " ; Spam + "X-Habeas-SWE-2: " ; Spam + "X-Habeas-SWE-3: " ; Spam + "X-Habeas-SWE-4: " ; Spam + "X-Habeas-SWE-5: " ; Spam + "X-Habeas-SWE-6: " ; Spam + "X-Habeas-SWE-7: " ; Spam + "X-Habeas-SWE-8: " ; Spam + "X-Habeas-SWE-9: " ; Spam + "X-Info: " ; NTMail + "X-Juno-" ; Juno + "X-List-Host: " ; Unknown mailing list managers + "X-List-Subscribe: " ; Unknown mailing list managers + "X-List-Unsubscribe: " ; Unknown mailing list managers + "X-Listserver: " ; Unknown mailing list managers + "X-Loop: " ; Unknown mailing list managers + "X-MIME-Autoconverted: " ; sendmail + "X-MIMETrack: " + "X-MS-TNEF-Correlator: " ; MS Outlook + "X-Mailing-List: " ; Unknown mailing list managers + "X-Mailman-Version: " ; Mailman mailing list manager + "X-Message-Id" + "X-MimeOLE: " ; MS Outlook + "X-Mozilla-Status: " ; Netscape/Mozilla + "X-Msmail-" ; MS Outlook + "X-News: " ; News + "X-No-Archive: " + "X-Orcl-Content-Type: " + "X-Original-Complaints-To: " + "X-Original-Date: " ; SourceForge mailing list manager + "X-Original-Trace: " + "X-OriginalArrivalTime: " ; Hotmail + "X-Originating-IP: " ; Hotmail + "X-Priority: " ; MS Outlook + "X-Qotd-" ; User added + "X-Received-Date: " + "X-Received: " + "X-Request-" + "X-SBClass: " ; Spam + "X-SBNote: " ; Spam + "X-SBPass: " ; Spam + "X-SBRule: " ; Spam + "X-Scanned-By" + "X-Sender: " + "X-Server-Date: " + "X-Server-Uuid: " + "X-Sieve: " ; Sieve filtering + "X-Spam-Level: " ; Spam + "X-Spam-Score: " ; Spam + "X-Spam-Status: " ; Spam + "X-SpamBouncer: " ; Spam + "X-Trace: " + "X-UIDL: " + "X-UserInfo1: " + "X-VSMLoop: " ; NTMail + "X-Vms-To: " + "X-Wss-Id: " ; Worldtalk gateways + "X-eGroups-" ; Egroups/yahoogroups mailing list manager + "X-pgp: " + "X-submission-address: " + "X400-" ; X400 + "Xref: ") +"*List of header fields that are not to be shown. +Regexps are not allowed. Unique fields should have a \": \" suffix; +otherwise, the element can be used to render an entire class of fields +that start with the same prefix invisible. +This variable is ignored if `mh-visible-headers' is set." + :type '(repeat (string :tag "Header field")) + :set 'mh-invisible-header-fields-set + :group 'mh-show) + +;;; Composing messages (:group 'mh-letter) + +(defcustom mh-compose-insertion (if (locate-library "mml") 'gnus 'mhn) + "Use either 'gnus or 'mhn to insert MIME message directives in messages." + :type '(choice (const :tag "Use gnus" gnus) + (const :tag "Use mhn" mhn)) + :group 'mh-letter) + +(defcustom mh-compose-letter-function nil + "Invoked when setting up a letter draft. +It is passed three arguments: TO recipients, SUBJECT, and CC recipients." + :type '(choice (const nil) function) + :group 'mh-letter) + +(defcustom mh-delete-yanked-msg-window-flag nil + "*Non-nil means delete any window displaying the message. +Controls window display when a message is yanked by \\<mh-letter-mode-map>\\[mh-yank-cur-msg]. +If non-nil, yanking the current message into a draft letter deletes any +windows displaying the message." + :type 'boolean + :group 'mh-letter) + +(defcustom mh-extract-from-attribution-verb "wrote:" + "*Verb to use for attribution when a message is yanked by \\<mh-letter-mode-map>\\[mh-yank-cur-msg]." + :type '(choice (const "wrote:") + (const "a écrit :") + (string :tag "Custom string")) + :group 'mh-letter) + +(defcustom mh-forward-subject-format "%s: %s" + "*Format to generate the Subject: line contents for a forwarded message. +The two string arguments to the format are the sender of the original +message and the original subject line." + :type 'string + :group 'mh-letter) + +(defcustom mh-ins-buf-prefix "> " + "*String to put before each non-blank line of a yanked or inserted message. +\\<mh-letter-mode-map>Used when the message is inserted into an outgoing letter +by \\[mh-insert-letter] or \\[mh-yank-cur-msg]." + :type 'string + :group 'mh-letter) + +(defcustom mh-insert-mail-followup-to-flag t + "Non-nil means maybe append a Mail-Followup-To field to the header. +The insertion is done if the To: or Cc: fields matches an entry in +`mh-insert-mail-followup-to-list'." + :type 'boolean + :group 'mh-letter) + +(defcustom mh-insert-mail-followup-to-list nil + "Alist of addresses for which a Mail-Followup-To field is inserted. +Each element has the form (REGEXP ADDRESS). +When the REGEXP appears in the To or cc fields of a message, the corresponding +ADDRESS is inserted in a Mail-Followup-To field. + +Here's a customization example: + + regexp: mh-e-users@lists.s\\\\(ourceforge\\\\|f\\\\).net + address: mh-e-users@lists.sourceforge.net + +This corresponds to: + + (setq mh-insert-mail-followup-to-list + '((\"mh-e-users@lists.s\\\\(ourceforge\\\\|f\\\\).net\" + \"mh-e-users@lists.sourceforge.net\"))) + +While it might be tempting to add a descriptive name to the mailing list +address, consider that this field will appear in other people's outgoing +mail in their To: field. It might be best to keep it simple." + :type '(repeat (list (string :tag "regexp") (string :tag "address"))) + :group 'mh-letter) + +(defcustom mh-insert-x-mailer-flag t + "*Non-nil means append an X-Mailer field to the header." + :type 'boolean + :group 'mh-letter) + +(defcustom mh-letter-fill-column 72 + "*Fill column to use in `mh-letter-mode'. +This is usually less than in other text modes because email messages get +quoted by some prefix (sometimes many times) when they are replied to, +and it's best to avoid quoted lines that span more than 80 columns." + :type 'integer + :group 'mh-letter) + +(defcustom mh-reply-default-reply-to nil + "*Sets the person or persons to whom a reply will be sent. +If nil, prompt for recipient. If non-nil, then \\<mh-folder-mode-map>`\\[mh-reply]' will use this +value and it should be one of \"from\", \"to\", \"cc\", or \"all\". +The values \"cc\" and \"all\" do the same thing." + :type '(choice (const :tag "Prompt" nil) + (const "from") (const "to") + (const "cc") (const "all")) + :group 'mh-letter) + +(defcustom mh-reply-show-message-flag t + "*Non-nil means the show buffer is displayed using \\<mh-letter-mode-map>\\[mh-reply]. + +The setting of this variable determines whether the MH `show-buffer' is +displayed with the current message when using `mh-reply' without a prefix +argument. Set it to nil if you already include the message automatically +in your draft using + repl: -filter repl.filter +in your ~/.mh_profile file." + :type 'boolean + :group 'mh-letter) + +(defcustom mh-signature-file-name "~/.signature" + "*Name of file containing the user's signature. +Inserted into message by \\<mh-letter-mode-map>\\[mh-insert-signature]." + :type 'file + :group 'mh-letter) + +(defcustom mh-x-face-file "~/.face" + "*File name containing the encoded X-Face string to insert in outgoing mail. +If nil, or the file does not exist, nothing is added to message headers." + :type 'file + :group 'mh-letter) + +(defvar mh-x-mailer-string nil + "*String containing the contents of the X-Mailer header field. +If nil, this variable is initialized to show the version of MH-E, Emacs, and +MH the first time a message is composed.") + +(defcustom mh-yank-from-start-of-msg 'attribution + "*Controls which part of a message is yanked by \\<mh-letter-mode-map>\\[mh-yank-cur-msg]. +If t, include the entire message, with full headers. This is historically +here for use with supercite, but is now deprecated in favor of the setting +`supercite' below. + +If the symbol `body', then yank the message minus the header. + +If the symbol `supercite', include the entire message, with full headers. +This also causes the invocation of `sc-cite-original' without the setting +of `mail-citation-hook', now deprecated practice. + +If the symbol `autosupercite', do as for `supercite' automatically when +show buffer matches the message being replied-to. When this option is used, +the -noformat switch is passed to the repl program to override a -filter or +-format switch. + +If the symbol `attribution', then yank the message minus the header and add +a simple attribution line at the top. + +If the symbol `autoattrib', do as for `attribution' automatically when show +buffer matches the message being replied-to. You can make sure this is +always the case by setting `mh-reply-show-message-flag' to t (which is the +default) and optionally `mh-delete-yanked-msg-window-flag' to t as well such +that the show window is never displayed. When the `autoattrib' option is +used, the -noformat switch is passed to the repl program to override a +-filter or -format switch. + +If nil, yank only the portion of the message following the point. + +If the show buffer has a region, this variable is ignored unless its value is +one of `attribution' or `autoattrib' in which case the attribution is added +to the yanked region." + :type '(choice (const :tag "Below point" nil) + (const :tag "Without header" body) + (const :tag "Invoke supercite" supercite) + (const :tag "Invoke supercite, automatically" autosupercite) + (const :tag "Without header, with attribution" attribution) + (const :tag "Without header, with attribution, automatically" + autoattrib) + (const :tag "Entire message with headers" t)) + :group 'mh-letter) + +(defcustom mh-letter-complete-function 'ispell-complete-word + "*Function to call when completing outside of fields specific to aliases." + :type '(choice function (const nil)) + :group 'mh-letter) + +;;; Alias handling (:group 'mh-alias) + +(defcustom mh-alias-system-aliases + '("/etc/nmh/MailAliases" "/usr/lib/mh/MailAliases" "/etc/passwd") + "*A list of system files from which to cull aliases. +If these files are modified, they are automatically reread. This list need +include only system aliases and the passwd file, since personal alias files +listed in your \"AliasFile\" MH profile component are automatically included. +You can update the alias list manually using \\[mh-alias-reload]." + :group 'mh-alias + :type '(choice (file) (repeat file))) + +(defcustom mh-alias-expand-aliases-flag nil + "*Non-nil means to expand aliases entered in the minibuffer. +In other words, aliases entered in the minibuffer will be expanded to the full +address in the message draft. By default, this expansion is not performed." + :group 'mh-alias + :type 'boolean) + +(defcustom mh-alias-completion-ignore-case-flag t + "*Non-nil means don't consider case significant in MH alias completion. +This is the default in plain MH, so it is the default here as well. It +can be useful to set this to t if, for example, you use lowercase +aliases for people and uppercase for mailing lists." + :group 'mh-alias + :type 'boolean) + +(defcustom mh-alias-flash-on-comma t + "*Specify whether to flash or warn on translation. +When a [comma] is pressed while entering aliases or addresses, setting this +variable to the following values has the listed effects: +t Flash alias translation but don't warn if there is no translation. +1 Flash alias translation and warn if there is no translation. +nil Do not flash alias translation nor warn if there is no translation." + :group 'mh-alias + :type '(choice (const :tag "Flash but don't warn if no translation" t) + (const :tag "Flash and warn if no translation" 1) + (const :tag "Don't flash nor warn if no translation" nil))) + +(defcustom mh-alias-local-users t + "*If t, local users are completed in MH-E To: and Cc: prompts. + +Users with a userid greater than some magic number (usually 200) are available +for completion. + +If you set this variable to a string, it will be executed to generate a +password file. A value of \"ypcat passwd\" is helpful if NIS is in use." + :group 'mh-alias + :type '(choice (boolean) (string))) + +(defcustom mh-alias-insert-file nil + "*Filename to use to store new MH-E aliases. +This variable can also be a list of filenames, in which case MH-E will prompt +for one of them. If nil, the default, then MH-E will use the first file found +in the \"AliasFile\" component of the MH profile." + :group 'mh-alias + :type '(choice (const :tag "Use AliasFile MH profile component" nil) + (file :tag "Alias file") + (repeat :tag "List of alias files" file))) + +(defcustom mh-alias-insertion-location 'sorted + "Specifies where new aliases are entered in alias files. +Options are sorted alphabetically, at the top of the file or at the bottom." + :type '(choice (const :tag "Sorted alphabetically" sorted) + (const :tag "At the top of file" top) + (const :tag "At the bottom of file" bottom)) + :group 'mh-alias) + +;;; Indexed searching (:group 'mh-index) + +(defcustom mh-index-program nil + "Indexing program that MH-E shall use. +The possible choices are swish++, swish-e, namazu, glimpse and grep. By +default this variable is nil which means that the programs are tried in order +and the first one found is used." + :type '(choice (const :tag "auto-detect" nil) + (const :tag "swish++" swish++) + (const :tag "swish-e" swish) + (const :tag "namazu" namazu) + (const :tag "glimpse" glimpse) + (const :tag "grep" grep)) + :group 'mh-index) + +;;; Multiple personalities (:group 'mh-identity) + +(defcustom mh-identity-list nil + "*List holding MH-E identity. +Omit the colon and trailing space from the field names. +The keyword name \"none\" is reversed for internal use. +Use the keyname name \"signature\" to specify either a signature file or a +function to call to insert a signature at point. + +Providing an empty Value (\"\") will cause the field to be deleted. + +Example entries using the customize interface: + Keyword name: work + From + Value: John Doe <john@work.com> + Organization + Value: Acme Inc. + Keyword name: home + From + Value: John Doe <johndoe@home.net> + Organization + Value: + +This would produce the equivalent of: + (setq mh-identity-list + '((\"work\" + ((\"From\" . \"John Doe <john@work.com>\") + (\"Organization\" . \"Acme Inc.\"))) + (\"home\" + ((\"From\" . \"John Doe <johndoe@home.net>\") + (\"Organization\" . \"\")))))" + :type '(repeat (list :tag "" + (string :tag "Keyword name") + (repeat :tag "At least one pair from below" + (choice (cons :tag "From field" + (const "From") + (string :tag "Value")) + (cons :tag "Organization field" + (const "Organization") + (string :tag "Value")) + (cons :tag "Signature" + (const "signature") + (choice (file) (function))) + (cons :tag "Other field & value pair" + (string :tag "Field") + (string :tag "Value")))))) + :set 'mh-identity-list-set + :group 'mh-identity) + +(defcustom mh-identity-default nil + "Default identity to use when `mh-letter-mode' is called." + ;; Dynamically render :type corresponding to `mh-identity-list' entries, + ;; e.g.: + ;; :type '(radio (const :tag "none" nil) + ;; (const "home") + ;; (const "work")) + :type (append + '(radio) + (cons '(const :tag "none" nil) + (mapcar (function (lambda (arg) `(const ,arg))) + (mapcar 'car mh-identity-list)))) + :group 'mh-identity) + +;;; Hooks (:group 'mh-hooks + group where hook defined) + +;;; These are alphabetized. All hooks should be placed in the 'mh-hook group; +;;; in addition, add the group in which the hook is defined in the manual (or, +;;; if it is new, where it would be defined). + +(defcustom mh-before-quit-hook nil + "Invoked by \\<mh-folder-mode-map>`\\[mh-quit]' before quitting MH-E. +See also `mh-quit-hook'." + :type 'hook + :group 'mh-hooks + :group 'mh-folder) + +(defcustom mh-before-send-letter-hook nil + "Invoked at the beginning of the \\<mh-letter-mode-map>\\[mh-send-letter] command." + :type 'hook + :group 'mh-hooks + :group 'mh-letter) + +(defcustom mh-delete-msg-hook nil + "Invoked after marking each message for deletion." + :type 'hook + :group 'mh-hooks + :group 'mh-folder) + +(defcustom mh-edit-mhn-hook nil + "Invoked on the formatted letter by \\<mh-letter-mode-map>\\[mh-edit-mhn]." + :type 'hook + :group 'mh-hooks + :group 'mh-letter) + +(defcustom mh-find-path-hook nil + "Invoked by `mh-find-path' after reading the user's MH profile." + :type 'hook + :group 'mh-hooks + :group 'mh-folder) + +(defcustom mh-folder-list-change-hook nil + "Invoked whenever the cached folder list `mh-folder-list' is changed." + :type 'hook + :group 'mh-hooks + :group 'mh-folder) + +(defcustom mh-folder-mode-hook nil + "Invoked in `mh-folder-mode' on a new folder." + :type 'hook + :group 'mh-hooks + :group 'mh-folder) + +(defcustom mh-folder-updated-hook nil + "Invoked when the folder actions (such as moves and deletes) are performed. +Variables that are useful in this hook include `mh-delete-list' and +`mh-refile-list' which can be used to see which changes are being made to +current folder, `mh-current-folder'." + :type 'hook + :group 'mh-hooks) + +(defcustom mh-inc-folder-hook nil + "Invoked by \\<mh-folder-mode-map>`\\[mh-inc-folder]' after incorporating mail into a folder." + :type 'hook + :group 'mh-hooks + :group 'mh-folder) + +(defcustom mh-index-show-hook nil + "Invoked after the message has been displayed." + :type 'hook + :group 'mh-hooks + :group 'mh-index) + +(defcustom mh-letter-insert-signature-hook nil + "Invoked at the beginning of the \\<mh-letter-mode-map>\\[mh-insert-signature] command. +Can be used to determine which signature file to use based on message content. +On return, if `mh-signature-file-name' is non-nil that file will be inserted at +the current point in the buffer." + :type 'hook + :group 'mh-hooks + :group 'mh-letter) + +(defcustom mh-letter-mode-hook nil + "Invoked in `mh-letter-mode' on a new letter." + :type 'hook + :group 'mh-hooks + :group 'mh-letter) + +(defcustom mh-pick-mode-hook nil + "Invoked upon entry to `mh-pick-mode'." + :type 'hook + :group 'mh-hooks + :group 'mh-folder) + +(defcustom mh-quit-hook nil + "Invoked after \\<mh-folder-mode-map>`\\[mh-quit]' quits MH-E. +See also `mh-before-quit-hook'." + :type 'hook + :group 'mh-hooks + :group 'mh-folder) + +(defcustom mh-refile-msg-hook nil + "Invoked after marking each message for refiling." + :type 'hook + :group 'mh-hooks + :group 'mh-folder) + +(defcustom mh-show-hook nil + "Invoked after \\<mh-folder-mode-map>`\\[mh-show]' shows a message." + :type 'hook + :group 'mh-hooks + :group 'mh-show) + +(defcustom mh-show-mode-hook nil + "Invoked upon entry to `mh-show-mode'." + :type 'hook + :group 'mh-hooks + :group 'mh-show) + +(defcustom mh-unseen-updated-hook nil + "Invoked after the unseen sequence has been updated. +The variable `mh-seen-list' can be used to obtain the list of messages which +will be removed from the unseen sequence." + :type 'hook + :group 'mh-hooks + :group 'mh-folder) + + + +;;; Faces + +;;; Faces used in speedbar (:group mh-speed-faces) + +(defface mh-speedbar-folder-face + '((((class color) (background light)) + (:foreground "blue4")) + (((class color) (background dark)) + (:foreground "light blue"))) + "Face used for folders in the speedbar buffer." + :group 'mh-speed-faces) + +(defface mh-speedbar-selected-folder-face + '((((class color) (background light)) + (:foreground "red" :underline t)) + (((class color) (background dark)) + (:foreground "red" :underline t)) + (t (:underline t))) + "Face used for the current folder." + :group 'mh-speed-faces) + +(defface mh-speedbar-folder-with-unseen-messages-face + '((t (:inherit mh-speedbar-folder-face :bold t))) + "Face used for folders in the speedbar buffer which have unread messages." + :group 'mh-speed-faces) + +(defface mh-speedbar-selected-folder-with-unseen-messages-face + '((t (:inherit mh-speedbar-selected-folder-face :bold t))) + "Face used for the current folder when it has unread messages." + :group 'mh-speed-faces) + +;;; Faces used in scan listing (:group mh-folder-faces) + +(defvar mh-folder-body-face 'mh-folder-body-face + "Face for highlighting body text in MH-Folder buffers.") +(defface mh-folder-body-face + '((((type tty) (class color)) (:foreground "green")) + (((class grayscale) (background light)) (:foreground "DimGray" :italic t)) + (((class grayscale) (background dark)) (:foreground "LightGray" :italic t)) + (((class color) (background light)) (:foreground "RosyBrown")) + (((class color) (background dark)) (:foreground "LightSalmon")) + (t (:italic t))) + "Face for highlighting body text in MH-Folder buffers." + :group 'mh-folder-faces) + +(defvar mh-folder-cur-msg-face 'mh-folder-cur-msg-face + "Face for the current message line in MH-Folder buffers.") +(defface mh-folder-cur-msg-face + '((((type tty pc) (class color)) + (:background "LightGreen")) + (((class color) (background light)) + (:background "LightGreen") ;Use this for solid background colour + ;; (:underline t) ;Use this for underlining + ) + (((class color) (background dark)) + (:background "DarkOliveGreen4")) + (t (:underline t))) + "Face for the current message line in MH-Folder buffers." + :group 'mh-folder-faces) + +(defvar mh-folder-cur-msg-number-face 'mh-folder-cur-msg-number-face + "Face for highlighting the current message in MH-Folder buffers.") +(defface mh-folder-cur-msg-number-face + '((((type tty) (class color)) (:foreground "cyan" :weight bold)) + (((class grayscale) (background light)) (:foreground "LightGray" :bold t)) + (((class grayscale) (background dark)) (:foreground "DimGray" :bold t)) + (((class color) (background light)) (:foreground "Purple")) + (((class color) (background dark)) (:foreground "Cyan")) + (t (:bold t))) + "Face for highlighting the current message in MH-Folder buffers." + :group 'mh-folder-faces) + +(defvar mh-folder-date-face 'mh-folder-date-face + "Face for highlighting the date in MH-Folder buffers.") +(defface mh-folder-date-face + '((((class color) (background light)) + (:foreground "snow4")) + (((class color) (background dark)) + (:foreground "snow3")) + (t + (:bold t))) + "Face for highlighting the date in MH-Folder buffers." + :group 'mh-folder-faces) + +(defvar mh-folder-followup-face 'mh-folder-followup-face + "Face for highlighting Re: (followup) subject text in MH-Folder buffers.") +(defface mh-folder-followup-face + '((((class color) (background light)) + (:foreground "blue3")) + (((class color) (background dark)) + (:foreground "LightGoldenRod")) + (t + (:bold t))) + "Face for highlighting Re: (followup) subject text in MH-Folder buffers." + :group 'mh-folder-faces) + +(defvar mh-folder-msg-number-face 'mh-folder-msg-number-face + "Face for highlighting the message number in MH-Folder buffers.") +(defface mh-folder-msg-number-face + '((((class color) (background light)) + (:foreground "snow4")) + (((class color) (background dark)) + (:foreground "snow3")) + (t + (:bold t))) + "Face for highlighting the message number in MH-Folder buffers." + :group 'mh-folder-faces) + +(defvar mh-folder-deleted-face 'mh-folder-deleted-face + "Face for highlighting deleted messages in MH-Folder buffers.") +(copy-face 'mh-folder-msg-number-face 'mh-folder-deleted-face) + +(defvar mh-folder-refiled-face 'mh-folder-refiled-face + "Face for highlighting refiled messages in MH-Folder buffers.") +(defface mh-folder-refiled-face + '((((type tty) (class color)) (:foreground "yellow" :weight light)) + (((class grayscale) (background light)) + (:foreground "Gray90" :bold t :italic t)) + (((class grayscale) (background dark)) + (:foreground "DimGray" :bold t :italic t)) + (((class color) (background light)) (:foreground "DarkGoldenrod")) + (((class color) (background dark)) (:foreground "LightGoldenrod")) + (t (:bold t :italic t))) + "Face for highlighting refiled messages in MH-Folder buffers." + :group 'mh-folder-faces) + +(defvar mh-folder-subject-face 'mh-folder-subject-face + "Face for highlighting subject text in MH-Folder buffers.") +(if (boundp 'facemenu-unlisted-faces) + (add-to-list 'facemenu-unlisted-faces "^mh-folder")) +(defface mh-folder-subject-face + '((((class color) (background light)) + (:foreground "blue4")) + (((class color) (background dark)) + (:foreground "yellow")) + (t + (:bold t))) + "Face for highlighting subject text in MH-Folder buffers." + :group 'mh-folder-faces) + +(defvar mh-folder-address-face 'mh-folder-address-face + "Face for highlighting the address in MH-Folder buffers.") +(copy-face 'mh-folder-subject-face 'mh-folder-address-face) + +(defvar mh-folder-scan-format-face 'mh-folder-scan-format-face + "Face for highlighting `mh-scan-format-regexp' matches in MH-Folder buffers.") +(copy-face 'mh-folder-followup-face 'mh-folder-scan-format-face) + +(defvar mh-folder-to-face 'mh-folder-to-face + "Face for highlighting the To: string in MH-Folder buffers.") +(defface mh-folder-to-face + '((((type tty) (class color)) (:foreground "green")) + (((class grayscale) (background light)) (:foreground "DimGray" :italic t)) + (((class grayscale) (background dark)) (:foreground "LightGray" :italic t)) + (((class color) (background light)) (:foreground "RosyBrown")) + (((class color) (background dark)) (:foreground "LightSalmon")) + (t (:italic t))) + "Face for highlighting the To: string in MH-Folder buffers." + :group 'mh-folder-faces) + +;;; Faces used in message display (:group mh-show-faces) + +(defvar mh-show-cc-face 'mh-show-cc-face + "Face for highlighting cc header fields.") +(defface mh-show-cc-face + '((((type tty) (class color)) (:foreground "yellow" :weight light)) + (((class grayscale) (background light)) + (:foreground "Gray90" :bold t :italic t)) + (((class grayscale) (background dark)) + (:foreground "DimGray" :bold t :italic t)) + (((class color) (background light)) (:foreground "DarkGoldenrod")) + (((class color) (background dark)) (:foreground "LightGoldenrod")) + (t (:bold t :italic t))) + "Face for highlighting cc header fields." + :group 'mh-show-faces) + +(defvar mh-show-date-face 'mh-show-date-face + "Face for highlighting the Date header field.") +(defface mh-show-date-face + '((((type tty) (class color)) (:foreground "green")) + (((class grayscale) (background light)) (:foreground "Gray90" :bold t)) + (((class grayscale) (background dark)) (:foreground "DimGray" :bold t)) + (((class color) (background light)) (:foreground "ForestGreen")) + (((class color) (background dark)) (:foreground "PaleGreen")) + (t (:bold t :underline t))) + "Face for highlighting the Date header field." + :group 'mh-show-faces) + +(defvar mh-show-header-face 'mh-show-header-face + "Face used to deemphasize unspecified header fields.") +(defface mh-show-header-face + '((((type tty) (class color)) (:foreground "green")) + (((class grayscale) (background light)) (:foreground "DimGray" :italic t)) + (((class grayscale) (background dark)) (:foreground "LightGray" :italic t)) + (((class color) (background light)) (:foreground "RosyBrown")) + (((class color) (background dark)) (:foreground "LightSalmon")) + (t (:italic t))) + "Face used to deemphasize unspecified header fields." + :group 'mh-show-faces) + +(defvar mh-show-to-face 'mh-show-to-face + "Face for highlighting the To: header field.") +(if (boundp 'facemenu-unlisted-faces) + (add-to-list 'facemenu-unlisted-faces "^mh-show")) +(defface mh-show-to-face + '((((class grayscale) (background light)) + (:foreground "DimGray" :underline t)) + (((class grayscale) (background dark)) + (:foreground "LightGray" :underline t)) + (((class color) (background light)) (:foreground "SaddleBrown")) + (((class color) (background dark)) (:foreground "burlywood")) + (t (:underline t))) + "Face for highlighting the To: header field." + :group 'mh-show-faces) + +(defvar mh-show-from-face 'mh-show-from-face + "Face for highlighting the From: header field.") +(defface mh-show-from-face + '((((class color) (background light)) + (:foreground "red3")) + (((class color) (background dark)) + (:foreground "cyan")) + (t + (:bold t))) + "Face for highlighting the From: header field." + :group 'mh-show-faces) + +(defvar mh-show-subject-face 'mh-show-subject-face + "Face for highlighting the Subject header field.") +(copy-face 'mh-folder-subject-face 'mh-show-subject-face) + +;;; Faces used in indexed searches (:group mh-index-faces) + +(defvar mh-index-folder-face 'mh-index-folder-face + "Face for highlighting folders in MH-Index buffers.") +(defface mh-index-folder-face + '((((class color) (background light)) + (:foreground "dark green" :bold t)) + (((class color) (background dark)) + (:foreground "indian red" :bold t)) + (t + (:bold t))) + "Face for highlighting folders in MH-Index buffers." + :group 'mh-index-faces) + +(provide 'mh-customize) + +;;; Local Variables: +;;; indent-tabs-mode: nil +;;; sentence-end-double-space: nil +;;; End: + +;;; mh-customize.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mh-e/mh-e.el Sun Jan 26 02:38:37 2003 +0000 @@ -0,0 +1,2258 @@ +;;; mh-e.el --- GNU Emacs interface to the MH mail system + +;; Copyright (C) 1985,86,87,88,90,92,93,94,95,97,2000,2001,2002 Free Software Foundation, Inc. + +;; Author: Bill Wohler <wohler@newt.com> +;; Maintainer: Bill Wohler <wohler@newt.com> +;; Version: 7.1 +;; Keywords: mail + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; How to Use: +;; M-x mh-rmail to read mail. Type C-h m there for a list of commands. +;; C-u M-x mh-rmail to visit any folder. +;; M-x mh-smail to send mail. From within the mail reader, "m" works, too. + +;; Your .emacs might benefit from these bindings: +;; (global-set-key "\C-cr" 'mh-rmail) +;; (global-set-key "\C-xm" 'mh-smail) +;; (global-set-key "\C-x4m" 'mh-smail-other-window) + +;; MH (Message Handler) is a powerful mail reader. + +;; The MH newsgroup is comp.mail.mh; the mailing list is mh-users@ics.uci.edu +;; (send to mh-users-request to be added). See the monthly Frequently Asked +;; Questions posting there for information on getting MH and MH-E: +;; http://www.faqs.org/faqs/mail/mh-faq/part1/preamble.html + +;; N.B. MH must have been compiled with the MHE compiler flag or several +;; features necessary for MH-E will be missing from MH commands, specifically +;; the -build switch to repl and forw. + +;; MH-E is an Emacs interface to the MH mail system. + +;; MH-E is supported in GNU Emacs 20 and 21, with MH 6.8.4 and nmh 1.0.4. + +;; Mailing Lists: +;; mh-e-users@lists.sourceforge.net +;; mh-e-announce@lists.sourceforge.net +;; mh-e-devel@lists.sourceforge.net +;; +;; Subscribe by sending a "subscribe" message to +;; <list>-request@lists.sourceforge.net, or by using the web interface at +;; https://sourceforge.net/mail/?group_id=13357 + +;; Bug Reports: +;; https://sourceforge.net/tracker/?group_id=13357&atid=113357 +;; Include the output of M-x mh-version in any bug report. + +;; Feature Requests: +;; https://sourceforge.net/tracker/?atid=363357&group_id=13357&func=browse + +;; Support: +;; https://sourceforge.net/tracker/?group_id=13357&atid=213357 + +;;; Change Log: + +;; Original version for Gosling emacs by Brian Reid, Stanford, 1982. +;; Modified by James Larus, BBN, July 1984 and UCB, 1984 & 1985. +;; Rewritten for GNU Emacs, James Larus 1985. larus@ginger.berkeley.edu +;; Modified by Stephen Gildea 1988. gildea@lcs.mit.edu +;; Maintenance picked up by Bill Wohler <wohler@newt.com> and the +;; SourceForge Crew <http://mh-e.sourceforge.net/>. 2001. + +;; $Id: mh-e.el,v 1.34 2003/01/08 23:21:16 wohler Exp $ + +;;; Code: + +(require 'cl) + +(defvar recursive-load-depth-limit) +(eval-when (compile load eval) + (if (and (boundp 'recursive-load-depth-limit) + (integerp recursive-load-depth-limit) + (> 50 recursive-load-depth-limit)) + (setq recursive-load-depth-limit 50))) + +(require 'mh-utils) +(require 'gnus-util) +(require 'easymenu) +(if mh-xemacs-flag + (require 'mh-xemacs-compat)) + +;; Shush the byte-compiler +(defvar font-lock-auto-fontify) +(defvar font-lock-defaults) + +(defconst mh-version "7.1" "Version number of MH-E.") + +;;; Autoloads +(autoload 'Info-goto-node "info") + + + +(defvar mh-note-deleted "D" + "String whose first character is used to notate deleted messages.") + +(defvar mh-note-refiled "^" + "String whose first character is used to notate refiled messages.") + +(defvar mh-note-cur "+" + "String whose first character is used to notate the current message.") + +(defvar mh-partial-folder-mode-line-annotation "select" + "Annotation when displaying part of a folder. +The string is displayed after the folder's name. nil for no annotation.") + +;;; Parameterize MH-E to work with different scan formats. The defaults work +;;; with the standard MH scan listings, in which the first 4 characters on +;;; the line are the message number, followed by two places for notations. + +;; The following scan formats are passed to the scan program if the +;; setting of `mh-scan-format-file' above is nil. They are identical +;; except the later one makes use of the nmh `decode' function to +;; decode RFC 2047 encodings. If you just want to change the width of +;; the msg number, use the `mh-set-cmd-note' function. + +(defvar mh-scan-format-mh + (concat + "%4(msg)" + "%<(cur)+%| %>" + "%<{replied}-" + "%?(nonnull(comp{to}))%<(mymbox{to})t%>" + "%?(nonnull(comp{cc}))%<(mymbox{cc})c%>" + "%?(nonnull(comp{bcc}))%<(mymbox{bcc})b%>" + "%?(nonnull(comp{newsgroups}))n%>" + "%<(zero) %>" + "%02(mon{date})/%02(mday{date})%<{date} %|*%>" + "%<(mymbox{from})%<{to}To:%14(friendly{to})%>%>" + "%<(zero)%17(friendly{from})%> " + "%{subject}%<{body}<<%{body}%>") + "*Scan format string for MH, provided to the scan program via the -format arg. +This format is identical to the default except that additional hints for +fontification have been added to the fifth column (remember that in Emacs, the +first column is 0). + +The values of the fifth column, in priority order, are: `-' if the +message has been replied to, t if an address on the To: line matches +one of the mailboxes of the current user, `c' if the Cc: line matches, +`b' if the Bcc: line matches, and `n' if a non-empty Newsgroups: header +is present.") + +(defvar mh-scan-format-nmh + (concat + "%4(msg)" + "%<(cur)+%| %>" + "%<{replied}-" + "%?(nonnull(comp{to}))%<(mymbox{to})t%>" + "%?(nonnull(comp{cc}))%<(mymbox{cc})c%>" + "%?(nonnull(comp{bcc}))%<(mymbox{bcc})b%>" + "%?(nonnull(comp{newsgroups}))n%>" + "%<(zero) %>" + "%02(mon{date})/%02(mday{date})%<{date} %|*%>" + "%<(mymbox{from})%<{to}To:%14(decode(friendly{to}))%>%>" + "%<(zero)%17(decode(friendly{from}))%> " + "%(decode{subject})%<{body}<<%{body}%>") + "*Scan format string for nmh. +This string is passed to the scan program via the -format arg. +This format is identical to the default except that additional hints for +fontification have been added to the fifth column (remember that in Emacs, the +first column is 0). + +The values of the fifth column, in priority order, are: `-' if the +message has been replied to, t if an address on the To: line matches +one of the mailboxes of the current user, `c' if the Cc: line matches, +`b' if the Bcc: line matches, and `n' if a non-empty Newsgroups: header +is present.") + +(defvar mh-scan-good-msg-regexp "^\\( *[0-9]+\\)[^D^0-9]" + "Regexp specifying the scan lines that are 'good' messages. +The default `mh-folder-font-lock-keywords' expects this expression to contain +at least one parenthesized expression which matches the message number.") + +(defvar mh-scan-deleted-msg-regexp "^\\( *[0-9]+\\)D" + "Regexp matching scan lines of deleted messages. +The default `mh-folder-font-lock-keywords' expects this expression to contain +at least one parenthesized expression which matches the message number.") + +(defvar mh-scan-refiled-msg-regexp "^\\( *[0-9]+\\)\\^" + "Regexp matching scan lines of refiled messages. +The default `mh-folder-font-lock-keywords' expects this expression to contain +at least one parenthesized expression which matches the message number.") + +(defvar mh-scan-valid-regexp "^ *[0-9]" + "Regexp matching scan lines for messages (not error messages).") + +(defvar mh-scan-cur-msg-number-regexp "^\\( *[0-9]+\\+\\).*" + "Regexp matching scan line for the current message. +The default `mh-folder-font-lock-keywords' expects this expression to contain +at least one parenthesized expression which matches the message number. +Don't disable this regexp as it's needed by non fontifying functions.") + +(defvar mh-scan-cur-msg-regexp "^\\( *[0-9]+\\+DISABLED.*\\)" + "Regexp matching scan line for the current message. +The default `mh-folder-font-lock-keywords' expects this expression to contain +at least one parenthesized expression which matches the whole line. +To enable this feature, remove the string DISABLED from the regexp.") + +(defvar mh-scan-date-regexp "\\([0-9][0-9]/[0-9][0-9]\\)" + "Regexp matching a valid date in scan lines. +The default `mh-folder-font-lock-keywords' expects this expression to contain +only one parenthesized expression which matches the date field +\(see `mh-scan-format-regexp').") + +(defvar mh-scan-rcpt-regexp "\\(To:\\)\\(..............\\)" + "Regexp specifying the recipient in scan lines for messages we sent. +The default `mh-folder-font-lock-keywords' expects this expression to contain +two parenthesized expressions. The first is expected to match the To: +that the default scan format file generates. The second is expected to match +the recipient's name.") + +(defvar mh-scan-body-regexp "\\(<<\\([^\n]+\\)?\\)" + "Regexp matching the message body beginning displayed in scan lines. +The default `mh-folder-font-lock-keywords' expects this expression to contain +at least one parenthesized expression which matches the body text.") + +(defvar mh-scan-subject-regexp + ;;"^ *[0-9]+........[ ]*...................\\([Rr][Ee]:\\s-*\\)*\\([^<\n]*\\)" + "^ *[0-9]+........[ ]*...................\\([Rr][Ee]\\(\\[[0-9]+\\]\\)?:\\s-*\\)*\\([^<\n]*\\)" + "*Regexp matching the subject string in MH folder mode. +The default `mh-folder-font-lock-keywords' expects this expression to contain +at least tree parenthesized expressions. The first is expected to match the Re: +string, if any. The second matches an optional bracketed number after Re, +such as in Re[2]: and the third is expected to match the subject line itself.") + +(defvar mh-scan-format-regexp + (concat "\\([bct]\\)" mh-scan-date-regexp " *\\(..................\\)") + "Regexp matching the output of scan. +The default value is based upon the default values of either +`mh-scan-format-mh' or `mh-scan-format-nmh'. +The default `mh-folder-font-lock-keywords' expects this expression to contain +at least three parenthesized expressions. The first should match the +fontification hint, the second is found in `mh-scan-date-regexp', and the +third should match the user name.") + + + +(defvar mh-folder-font-lock-keywords + (list + ;; Folders when displaying index buffer + (list "^\\+.*" + '(0 mh-index-folder-face)) + ;; Marked for deletion + (list (concat mh-scan-deleted-msg-regexp ".*") + '(0 mh-folder-deleted-face)) + ;; Marked for refile + (list (concat mh-scan-refiled-msg-regexp ".*") + '(0 mh-folder-refiled-face)) + ;;after subj + (list mh-scan-body-regexp '(1 mh-folder-body-face nil t)) + '(mh-folder-font-lock-subject + (1 mh-folder-followup-face append t) + (2 mh-folder-subject-face append t)) + ;;current msg + (list mh-scan-cur-msg-number-regexp + '(1 mh-folder-cur-msg-number-face)) + (list mh-scan-good-msg-regexp + '(1 mh-folder-msg-number-face)) ;; Msg number + (list mh-scan-date-regexp '(1 mh-folder-date-face)) ;; Date + (list mh-scan-rcpt-regexp + '(1 mh-folder-to-face) ;; To: + '(2 mh-folder-address-face)) ;; address + ;; scan font-lock name + (list mh-scan-format-regexp + '(1 mh-folder-date-face) + '(3 mh-folder-scan-format-face)) + ;; Current message line + (list mh-scan-cur-msg-regexp + '(1 mh-folder-cur-msg-face prepend t)) + ;; Unseen messages in bold + '(mh-folder-font-lock-unseen (1 'bold append t))) + "Regexp keywords used to fontify the MH-Folder buffer.") + +(defvar mh-scan-cmd-note-width 1 + "Number of columns consumed by the cmd-note field in `mh-scan-format'. +This column will have one of the values: ` ', `D', `^', `+' and where +` ' is the default value, +`D' is the `mh-note-deleted' character, +`^' is the `mh-note-refiled' character, and +`+' is the `mh-note-cur' character.") + +(defvar mh-scan-destination-width 1 + "Number of columns consumed by the destination field in `mh-scan-format'. +This column will have one of ' ', '%', '-', 't', 'c', 'b', or `n' in it. +A ' ' blank space is the default character. +A '%' indicates that the message in in a named MH sequence. +A '-' indicates that the message has been annotated with a replied field. +A 't' indicates that the message contains mymbox in the To: field. +A 'c' indicates that the message contains mymbox in the Cc: field. +A 'b' indicates that the message contains mymbox in the Bcc: field. +A 'n' indicates that the message contains a Newsgroups: field.") + +(defvar mh-scan-date-width 5 + "Number of columns consumed by the date field in `mh-scan-format'. +This column will typically be of the form mm/dd.") + +(defvar mh-scan-date-flag-width 1 + "Number of columns consumed to flag (in)valid dates in `mh-scan-format'. +This column will have ` ' for valid and `*' for invalid or missing dates.") + +(defvar mh-scan-from-mbox-width 17 + "Number of columns consumed with the \"From:\" line in `mh-scan-format'. +This column will have a friendly name or e-mail address of the +originator, or a \"To: address\" for outgoing e-mail messages.") + +(defvar mh-scan-from-mbox-sep-width 2 + "Number of columns consumed by whitespace after from-mbox in `mh-scan-format'. +This column will only ever have spaces in it.") + +(defvar mh-scan-field-from-start-offset + (+ mh-scan-cmd-note-width + mh-scan-destination-width + mh-scan-date-width + mh-scan-date-flag-width) + "The offset from the `mh-cmd-note' to find the start of \"From:\" address.") + +(defvar mh-scan-field-from-end-offset + (+ mh-scan-field-from-start-offset mh-scan-from-mbox-width) + "The offset from the `mh-cmd-note' to find the end of \"From:\" address.") + +(defvar mh-scan-field-subject-start-offset + (+ mh-scan-cmd-note-width + mh-scan-destination-width + mh-scan-date-width + mh-scan-date-flag-width + mh-scan-from-mbox-width + mh-scan-from-mbox-sep-width) + "The offset from the `mh-cmd-note' to find the start of the subject.") + +(defun mh-folder-font-lock-subject (limit) + "Return MH-E scan subject strings to font-lock between point and LIMIT." + (if (not (re-search-forward mh-scan-subject-regexp limit t)) + nil + (if (match-beginning 1) + (set-match-data (list (match-beginning 1) (match-end 3) + (match-beginning 1) (match-end 3) nil nil)) + (set-match-data (list (match-beginning 3) (match-end 3) + nil nil (match-beginning 3) (match-end 3)))) + t)) + + + +;; Fontifify unseen mesages in bold. + +(defvar mh-folder-unseen-seq-name nil + "Name of unseen sequence. +The default for this is provided by the function `mh-folder-unseen-seq-name' +On nmh systems.") + +(defun mh-folder-unseen-seq-name () + "Provide name of unseen sequence from mhparam." + (or mh-progs (mh-find-path)) + (save-excursion + (let ((unseen-seq-name "unseen")) + (with-temp-buffer + (unwind-protect + (progn + (call-process (expand-file-name "mhparam" mh-progs) + nil '(t t) nil "-component" "Unseen-Sequence") + (goto-char (point-min)) + (if (re-search-forward "Unseen-Sequence: \\(.*\\)$" nil t) + (setq unseen-seq-name (match-string 1)))))) + unseen-seq-name))) + +(defun mh-folder-unseen-seq-list () + "Return a list of unseen message numbers for current folder." + (if (not mh-folder-unseen-seq-name) + (setq mh-folder-unseen-seq-name (mh-folder-unseen-seq-name))) + (cond + ((not mh-folder-unseen-seq-name) + nil) + (t + (let ((folder mh-current-folder)) + (save-excursion + (with-temp-buffer + (unwind-protect + (progn + (call-process (expand-file-name "mark" mh-progs) + nil '(t t) nil + folder "-seq" mh-folder-unseen-seq-name + "-list") + (goto-char (point-min)) + (sort (mh-read-msg-list) '<))))))))) + +(defvar mh-folder-unseen-seq-cache nil + "Internal cache variable used for font-lock in MH-E. +Should only be non-nil through font-lock stepping, and nil once font-lock +is done highlighting.") +(make-variable-buffer-local 'mh-folder-unseen-seq-cache) + +(defun mh-folder-font-lock-unseen (limit) + "Return unseen message lines to font-lock between point and LIMIT." + (if (not mh-folder-unseen-seq-cache) + (setq mh-folder-unseen-seq-cache (mh-folder-unseen-seq-list))) + (let ((cur-msg (mh-get-msg-num nil))) + (cond + ((not mh-folder-unseen-seq-cache) + nil) + ((not cur-msg) ;Presumably at end of buffer + (setq mh-folder-unseen-seq-cache nil) + nil) + ((member cur-msg mh-folder-unseen-seq-cache) + (let ((bpoint (progn (beginning-of-line)(point))) + (epoint (progn (forward-line 1)(point)))) + (if (<= limit (point)) + (setq mh-folder-unseen-seq-cache nil)) + (set-match-data (list bpoint epoint bpoint epoint)) + t)) + (t + ;; move forward one line at a time, checking each message number. + (while (and + (= 0 (forward-line 1)) + (> limit (point)) + (not (member (mh-get-msg-num nil) mh-folder-unseen-seq-cache)))) + ;; Examine how we must have exited the loop... + (let ((cur-msg (mh-get-msg-num nil))) + (cond + ((or (not cur-msg) + (<= limit (point)) + (not (member cur-msg mh-folder-unseen-seq-cache))) + (setq mh-folder-unseen-seq-cache nil) + nil) + ((member cur-msg mh-folder-unseen-seq-cache) + (let ((bpoint (progn (beginning-of-line)(point))) + (epoint (progn (forward-line 1)(point)))) + (if (<= limit (point)) + (setq mh-folder-unseen-seq-cache nil)) + (set-match-data (list bpoint epoint bpoint epoint)) + t)))))))) + + + +;;; Internal variables: + +(defvar mh-last-destination nil) ;Destination of last refile or write + ;command. +(defvar mh-last-destination-folder nil) ;Destination of last refile command. +(defvar mh-last-destination-write nil) ;Destination of last write command. + +(defvar mh-folder-mode-map (make-keymap) + "Keymap for MH folders.") + +(defvar mh-delete-list nil) ;List of msg numbers to delete. + +(defvar mh-refile-list nil) ;List of folder names in mh-seq-list. + +(defvar mh-next-direction 'forward) ;Direction to move to next message. + +(defvar mh-narrowed-to-seq nil) ;Sequence display is narrowed to or + ;nil if not narrowed. + +(defvar mh-view-ops ()) ;Stack of ops that change the folder + ;view (such as narrowing or threading). + +(defvar mh-index-data nil) ;Info about index search results +(defvar mh-index-previous-search nil) +(defvar mh-index-msg-checksum-map nil) +(defvar mh-index-checksum-origin-map nil) + +(defvar mh-first-msg-num nil) ;Number of first msg in buffer. + +(defvar mh-last-msg-num nil) ;Number of last msg in buffer. + +(defvar mh-mode-line-annotation nil) ;Message range displayed in buffer. + +;;; Macros and generic functions: + +(defun mh-mapc (function list) + "Apply FUNCTION to each element of LIST for side effects only." + (while list + (funcall function (car list)) + (setq list (cdr list)))) + +(defun mh-scan-format () + "Return \"-format\" argument for the scan program." + (if (equal mh-scan-format-file t) + (list "-format" (if mh-nmh-flag + (list (mh-update-scan-format + mh-scan-format-nmh mh-cmd-note)) + (list (mh-update-scan-format + mh-scan-format-mh mh-cmd-note)))) + (if (not (equal mh-scan-format-file nil)) + (list "-format" mh-scan-format-file)))) + + + +;;; Entry points: + +;;;###autoload +(defun mh-rmail (&optional arg) + "Inc(orporate) new mail with MH. +Scan an MH folder if ARG is non-nil. This function is an entry point to MH-E, +the Emacs front end to the MH mail system." + (interactive "P") + (mh-find-path) + (if arg + (call-interactively 'mh-visit-folder) + (mh-inc-folder))) + +;;;###autoload +(defun mh-nmail (&optional arg) + "Check for new mail in inbox folder. +Scan an MH folder if ARG is non-nil. This function is an entry point to MH-E, +the Emacs front end to the MH mail system." + (interactive "P") + (mh-find-path) ; init mh-inbox + (if arg + (call-interactively 'mh-visit-folder) + (mh-visit-folder mh-inbox))) + + + +;;; User executable MH-E commands: + +(defun mh-delete-msg (msg-or-seq) + "Mark the specified MSG-OR-SEQ for subsequent deletion and move to the next. + +Default is the displayed message. If optional prefix argument is given then +prompt for the message sequence. If variable `transient-mark-mode' is non-nil +and the mark is active, then the selected region is marked for deletion." + (interactive (list (cond + ((mh-mark-active-p t) + (mh-region-to-msg-list (region-beginning) (region-end))) + (current-prefix-arg + (mh-read-seq-default "Delete" t)) + (t + (mh-get-msg-num t))))) + (mh-delete-msg-no-motion msg-or-seq) + (mh-next-msg)) + +(defun mh-delete-msg-no-motion (msg-or-seq) + "Mark the specified MSG-OR-SEQ for subsequent deletion. +Default is the displayed message. If optional prefix argument is provided, +then prompt for the message sequence." + (interactive (list (if current-prefix-arg + (mh-read-seq-default "Delete" t) + (mh-get-msg-num t)))) + (if (numberp msg-or-seq) + (mh-delete-a-msg msg-or-seq) + (mh-map-to-seq-msgs 'mh-delete-a-msg msg-or-seq))) + +(defun mh-execute-commands () + "Process outstanding delete and refile requests." + (interactive) + (if mh-narrowed-to-seq (mh-widen)) + (mh-process-commands mh-current-folder) + (mh-set-scan-mode) + (mh-goto-cur-msg) ; after mh-set-scan-mode for efficiency + (mh-make-folder-mode-line) + t) ; return t for write-file-functions + +(defun mh-first-msg () + "Move to the first message." + (interactive) + (goto-char (point-min)) + (while (and (not (eobp)) (not (looking-at mh-scan-valid-regexp))) + (forward-line 1))) + +(defun mh-header-display () + "Show the current message with all its headers. +Displays headers that might have been suppressed by setting the +variables `mh-clean-message-header-flag' or `mhl-formfile', or by the fallback +behavior of scrolling uninteresting headers off the top of the window. +Type \"\\[mh-show]\" to show the message normally again." + (interactive) + (and (not mh-showing-with-headers) + (or mhl-formfile mh-clean-message-header-flag) + (mh-invalidate-show-buffer)) + (let ((mh-decode-mime-flag nil) + (mhl-formfile nil) + (mh-clean-message-header-flag nil)) + (mh-show-msg nil) + (mh-in-show-buffer (mh-show-buffer) + (goto-char (point-min)) + (mh-recenter 0)) + (setq mh-showing-with-headers t))) + +(defun mh-inc-folder (&optional maildrop-name) + "Inc(orporate)s new mail into the Inbox folder. +Optional argument MAILDROP-NAME specifies an alternate maildrop from the +default. If the prefix argument is given, incorporates mail into the current +folder, otherwise uses the folder named by `mh-inbox'. +The value of `mh-inc-folder-hook' is a list of functions to be called, with no +arguments, after incorporating new mail. +Do not call this function from outside MH-E; use \\[mh-rmail] instead." + (interactive (list (if current-prefix-arg + (expand-file-name + (read-file-name "inc mail from file: " + mh-user-path))))) + (let ((threading-needed-flag nil)) + (let ((config (current-window-configuration))) + (if (not maildrop-name) + (cond ((not (get-buffer mh-inbox)) + (mh-make-folder mh-inbox) + (setq threading-needed-flag mh-show-threads-flag) + (setq mh-previous-window-config config)) + ((not (eq (current-buffer) (get-buffer mh-inbox))) + (switch-to-buffer mh-inbox) + (setq mh-previous-window-config config))))) + (mh-get-new-mail maildrop-name) + (when (and threading-needed-flag + (save-excursion + (goto-char (point-min)) + (or (null mh-large-folder) + (not (equal (forward-line mh-large-folder) 0)) + (and (message "Not threading since the number of messages exceeds `mh-large-folder'") + nil)))) + (mh-toggle-threads)) + (if mh-showing-mode (mh-show)) + (run-hooks 'mh-inc-folder-hook))) + +(defun mh-last-msg () + "Move to the last message." + (interactive) + (goto-char (point-max)) + (while (and (not (bobp)) (not (looking-at mh-scan-valid-regexp))) + (forward-line -1)) + (mh-recenter nil)) + +(defun mh-next-undeleted-msg (&optional arg) + "Move to the next undeleted message ARG in window." + (interactive "p") + (setq mh-next-direction 'forward) + (forward-line 1) + (cond ((re-search-forward mh-scan-good-msg-regexp nil t arg) + (beginning-of-line) + (mh-maybe-show)) + (t (forward-line -1) + (message "No more undeleted messages")))) + +(defun mh-refile-msg (msg-or-seq folder) + "Refile MSG-OR-SEQ (default: displayed message) into FOLDER. +If optional prefix argument provided, then prompt for message sequence. +If variable `transient-mark-mode' is non-nil and the mark is active, then the +selected region is marked for refiling." + (interactive + (list (cond + ((mh-mark-active-p t) + (mh-region-to-msg-list (region-beginning) (region-end))) + (current-prefix-arg + (mh-read-seq-default "Refile" t)) + (t + (mh-get-msg-num t))) + (intern + (mh-prompt-for-folder + "Destination" + (or (and mh-default-folder-for-message-function + (let ((refile-file (mh-msg-filename (mh-get-msg-num t)))) + (save-excursion + (set-buffer (get-buffer-create mh-temp-buffer)) + (erase-buffer) + (insert-file-contents refile-file) + (let ((buffer-file-name refile-file)) + (funcall mh-default-folder-for-message-function))))) + (and (eq 'refile (car mh-last-destination-folder)) + (symbol-name (cdr mh-last-destination-folder))) + "") + t)))) + (setq mh-last-destination (cons 'refile folder) + mh-last-destination-folder mh-last-destination) + (if (numberp msg-or-seq) + (mh-refile-a-msg msg-or-seq folder) + (mh-map-to-seq-msgs 'mh-refile-a-msg msg-or-seq folder)) + (mh-next-msg)) + +(defun mh-refile-or-write-again (message) + "Re-execute the last refile or write command on the given MESSAGE. +Default is the displayed message. Use the same folder or file as the previous +refile or write command." + (interactive (list (mh-get-msg-num t))) + (if (null mh-last-destination) + (error "No previous refile or write")) + (cond ((eq (car mh-last-destination) 'refile) + (mh-refile-a-msg message (cdr mh-last-destination)) + (message "Destination folder: %s" (cdr mh-last-destination))) + (t + (apply 'mh-write-msg-to-file message (cdr mh-last-destination)) + (message "Destination: %s" (cdr mh-last-destination)))) + (mh-next-msg)) + +(defun mh-quit () + "Quit the current MH-E folder. +Restore the previous window configuration, if one exists. +The value of `mh-before-quit-hook' is a list of functions to be called, with +no arguments, immediately upon entry to this function. +The value of `mh-quit-hook' is a list of functions to be called, with no +arguments, upon exit of this function." + (interactive) + (run-hooks 'mh-before-quit-hook) + (let ((show-buffer (get-buffer mh-show-buffer))) + (when show-buffer + (kill-buffer show-buffer))) + (mh-update-sequences) + (mh-destroy-postponed-handles) + (bury-buffer (current-buffer)) + (if (get-buffer mh-temp-buffer) + (kill-buffer mh-temp-buffer)) + (if (get-buffer mh-temp-folders-buffer) + (kill-buffer mh-temp-folders-buffer)) + (if (get-buffer mh-temp-sequences-buffer) + (kill-buffer mh-temp-sequences-buffer)) + (if mh-previous-window-config + (set-window-configuration mh-previous-window-config)) + (run-hooks 'mh-quit-hook)) + +(defun mh-page-msg (&optional arg) + "Page the displayed message forwards. +Scrolls ARG lines or a full screen if no argument is supplied. Show buffer +first if not displayed. Show the next undeleted message if looking at the +bottom of the current message." + (interactive "P") + (if mh-showing-mode + (if mh-page-to-next-msg-flag + (if (equal mh-next-direction 'backward) + (mh-previous-undeleted-msg) + (mh-next-undeleted-msg)) + (if (mh-in-show-buffer (mh-show-buffer) + (pos-visible-in-window-p (point-max))) + (progn + (message (format + "End of message (Type %s to read %s undeleted message)" + (single-key-description last-input-event) + (if (equal mh-next-direction 'backward) + "previous" + "next"))) + (setq mh-page-to-next-msg-flag t)) + (scroll-other-window arg))) + (mh-show))) + +(defun mh-previous-page (&optional arg) + "Page the displayed message backwards. +Scrolls ARG lines or a full screen if no argument is supplied." + (interactive "P") + (mh-in-show-buffer (mh-show-buffer) + (scroll-down arg))) + +(defun mh-previous-undeleted-msg (&optional arg) + "Move to the previous undeleted message ARG in window." + (interactive "p") + (setq mh-next-direction 'backward) + (beginning-of-line) + (cond ((re-search-backward mh-scan-good-msg-regexp nil t arg) + (mh-maybe-show)) + (t (message "No previous undeleted message")))) + +(defun mh-previous-unread-msg (&optional count) + "Move to previous unread message. +With optional argument COUNT, COUNT-1 unread messages before current message +are skipped." + (interactive "p") + (unless (> count 0) + (error "The function mh-previous-unread-msg expects positive argument")) + (setq count (1- count)) + (let ((unread-sequence (cdr (assoc mh-unseen-seq mh-seq-list))) + (cur-msg (mh-get-msg-num nil))) + (cond ((and (not cur-msg) (not (bobp)) + ;; If we are at the end of the buffer back up one line and go + ;; to unread message after that. + (progn + (forward-line -1) + (setq cur-msg (mh-get-msg-num nil))) + nil)) + ((or (null unread-sequence) (not cur-msg)) + ;; No unread message or there aren't any messages in buffer... + (message "No more unread messages")) + ((progn + ;; Skip count messages... + (while (and unread-sequence (>= (car unread-sequence) cur-msg)) + (setq unread-sequence (cdr unread-sequence))) + (while (> count 0) + (setq unread-sequence (cdr unread-sequence)) + (setq count (1- count))) + (not (car unread-sequence))) + (message "No more unread messages")) + (t (mh-goto-msg (car unread-sequence)))))) + +(defun mh-goto-next-button (backward-flag &optional criterion) + "Search for next button satisfying criterion. +If BACKWARD-FLAG is non-nil search backward in the buffer for a mime button. If +CRITERION is a function or a symbol which has a function binding then that +function must return non-nil at the button we stop." + (unless (or (and (symbolp criterion) (fboundp criterion)) + (functionp criterion)) + (setq criterion (lambda (x) t))) + ;; Move to the next button in the buffer satisfying criterion + (goto-char (or (save-excursion + (beginning-of-line) + ;; Find point before current button + (let ((point-before-current-button + (save-excursion + (while (get-text-property (point) 'mh-data) + (unless (= (forward-line + (if backward-flag 1 -1)) + 0) + (if backward-flag + (goto-char (point-min)) + (goto-char (point-max))))) + (point)))) + ;; Skip over current button + (while (and (get-text-property (point) 'mh-data) + (not (if backward-flag (bobp) (eobp)))) + (forward-line (if backward-flag -1 1))) + ;; Stop at next MIME button if any exists. + (block loop + (while (/= (progn + (unless (= (forward-line + (if backward-flag -1 1)) + 0) + (if backward-flag + (goto-char (point-max)) + (goto-char (point-min))) + (beginning-of-line)) + (point)) + point-before-current-button) + (when (and (get-text-property (point) 'mh-data) + (funcall criterion (point))) + (return-from loop (point)))) + nil))) + (point)))) + +(defun mh-next-button (&optional backward-flag) + "Go to the next MIME button. +Advance point to the next MIME button in the show buffer. If the end +of buffer is reached then the search wraps over to the start of the +buffer. With prefix argument, BACKWARD-FLAG the point will move to the +previous MIME button." + (interactive (list current-prefix-arg)) + (unless mh-showing-mode + (mh-show)) + (mh-in-show-buffer (mh-show-buffer) + (mh-goto-next-button backward-flag))) + +(defun mh-prev-button () + "Go to the prev MIME button. +Move point to the previous MIME button in the show buffer. If the beginning +of the buffer is reached then the search wraps over to the end of the +buffer." + (interactive) + (mh-next-button t)) + +(defun mh-folder-mime-action (part-index action include-security-flag) + "Go to PART-INDEX and carry out ACTION. +If PART-INDEX is nil then go to the next part in the buffer. The search for +the next buffer wraps around if end of buffer is reached. If argument +INCLUDE-SECURITY-FLAG is non-nil then include security info buttons when +searching for a suitable parts." + (unless mh-showing-mode + (mh-show)) + (mh-in-show-buffer (mh-show-buffer) + (let ((criterion + (cond (part-index + (lambda (p) + (let ((part (get-text-property p 'mh-part))) + (and (integerp part) (= part part-index))))) + (t (lambda (p) + (if include-security-flag + (get-text-property p 'mh-data) + (integerp (get-text-property p 'mh-part))))))) + (point (point))) + (cond ((and (get-text-property point 'mh-part) + (or (null part-index) + (= (get-text-property point 'mh-part) part-index))) + (funcall action)) + ((and (get-text-property point 'mh-data) + include-security-flag + (null part-index)) + (funcall action)) + (t + (mh-goto-next-button nil criterion) + (if (= (point) point) + (message "No matching MIME part found") + (funcall action))))))) + +(defun mh-folder-toggle-mime-part (part-index) + "Toggle display of button. +If point in show buffer is at a button then that part is toggled. +If not at a button and PART-INDEX is non-nil point is moved to that part. +With nil PART-INDEX find the first button after point (search wraps around if +end of buffer is reached) and toggle it." + (interactive "P") + (when (consp part-index) (setq part-index (car part-index))) + (mh-folder-mime-action part-index #'mh-press-button t)) + +(defun mh-folder-inline-mime-part (part-index) + "Show the raw bytes of MIME part inline. +If point in show buffer is at a mime part then that part is inlined. +If not at a mime-part and PART-INDEX is non-nil point is moved to that part. +With nil PART-INDEX find the first button after point (search wraps around if +end of buffer is reached) and inline it." + (interactive "P") + (when (consp part-index) (setq part-index (car part-index))) + (mh-folder-mime-action part-index #'mh-mime-inline-part nil)) + +(defun mh-folder-save-mime-part (part-index) + "Save MIME part. +If point in show buffer is at a mime part then that part is saved. +If not at a mime-part and PART-INDEX is non-nil point is moved to that part. +With nil PART-INDEX find the first button after point (search wraps around if +end of buffer is reached) and save it." + (interactive "P") + (when (consp part-index) (setq part-index (car part-index))) + (mh-folder-mime-action part-index #'mh-mime-save-part nil)) + +(defun mh-reset-threads-and-narrowing () + "Reset all variables pertaining to threads and narrowing. +Also removes all content from the folder buffer." + (setq mh-view-ops ()) + (setq mh-narrowed-to-seq nil) + (let ((buffer-read-only nil)) (erase-buffer))) + +(defun mh-rescan-folder (&optional range dont-exec-pending) + "Rescan a folder after optionally processing the outstanding commands. +If optional prefix argument RANGE is provided, prompt for the range of +messages to display. Otherwise show the entire folder. +If optional argument DONT-EXEC-PENDING is non-nil then pending deletes and +refiles aren't carried out." + (interactive (list (if current-prefix-arg + (mh-read-msg-range mh-current-folder t) + nil))) + (setq mh-next-direction 'forward) + (let ((threaded-flag (memq 'unthread mh-view-ops))) + (mh-reset-threads-and-narrowing) + (mh-scan-folder mh-current-folder (or range "all") dont-exec-pending) + (cond (threaded-flag (mh-toggle-threads)) + (mh-index-data (mh-index-insert-folder-headers))))) + +(defun mh-write-msg-to-file (msg file no-headers) + "Append MSG to the end of a FILE. +If prefix argument NO-HEADERS is provided, write only the message body. +Otherwise send the entire message including the headers." + (interactive + (list (mh-get-msg-num t) + (let ((default-dir (if (eq 'write (car mh-last-destination-write)) + (file-name-directory + (car (cdr mh-last-destination-write))) + default-directory))) + (read-file-name (format "Save message%s in file: " + (if current-prefix-arg " body" "")) + default-dir + (if (eq 'write (car mh-last-destination-write)) + (car (cdr mh-last-destination-write)) + (expand-file-name "mail.out" default-dir)))) + current-prefix-arg)) + (let ((msg-file-to-output (mh-msg-filename msg)) + (output-file (mh-expand-file-name file))) + (setq mh-last-destination (list 'write file (if no-headers 'no-headers)) + mh-last-destination-write mh-last-destination) + (save-excursion + (set-buffer (get-buffer-create mh-temp-buffer)) + (erase-buffer) + (insert-file-contents msg-file-to-output) + (goto-char (point-min)) + (if no-headers (search-forward "\n\n")) + (append-to-file (point) (point-max) output-file)))) + +(defun mh-toggle-showing () + "Toggle the scanning mode/showing mode of displaying messages." + (interactive) + (if mh-showing-mode + (mh-set-scan-mode) + (mh-show))) + +(defun mh-undo (msg-or-seq) + "Undo the pending deletion or refile of the specified MSG-OR-SEQ. +Default is the displayed message. +If optional prefix argument is provided, then prompt for the message sequence. +If variable `transient-mark-mode' is non-nil and the mark is active, then the +selected region is unmarked." + (interactive (list (cond + ((mh-mark-active-p t) + (mh-region-to-msg-list (region-beginning) (region-end))) + (current-prefix-arg + (mh-read-seq-default "Undo" t)) + (t + (mh-get-msg-num t))))) + (cond ((numberp msg-or-seq) + (let ((original-position (point))) + (beginning-of-line) + (while (not (or (looking-at mh-scan-deleted-msg-regexp) + (looking-at mh-scan-refiled-msg-regexp) + (and (eq mh-next-direction 'forward) (bobp)) + (and (eq mh-next-direction 'backward) + (save-excursion (forward-line) (eobp))))) + (forward-line (if (eq mh-next-direction 'forward) -1 1))) + (if (or (looking-at mh-scan-deleted-msg-regexp) + (looking-at mh-scan-refiled-msg-regexp)) + (progn + (mh-undo-msg (mh-get-msg-num t)) + (mh-maybe-show)) + (goto-char original-position) + (error "Nothing to undo")))) + (t + (mh-map-to-seq-msgs 'mh-undo-msg msg-or-seq))) + (if (not (mh-outstanding-commands-p)) + (mh-set-folder-modified-p nil))) + +;;;###mh-autoload +(defun mh-folder-line-matches-show-buffer-p () + "Return t if the message under point in folder-mode is in the show buffer. +Return nil in any other circumstance (no message under point, no show buffer, +the message in the show buffer doesn't match." + (and (eq major-mode 'mh-folder-mode) + (mh-get-msg-num nil) + mh-show-buffer + (get-buffer mh-show-buffer) + (buffer-file-name (get-buffer mh-show-buffer)) + (string-match ".*/\\([0-9]+\\)$" + (buffer-file-name (get-buffer mh-show-buffer))) + (string-equal + (match-string 1 (buffer-file-name (get-buffer mh-show-buffer))) + (int-to-string (mh-get-msg-num nil))))) + +(eval-when-compile (require 'gnus)) + +(defmacro mh-macro-expansion-time-gnus-version () + "Return Gnus version available at macro expansion time. +The macro evaluates the Gnus version at macro expansion time. If MH-E was +compiled then macro expansion happens at compile time." + gnus-version) + +(defun mh-run-time-gnus-version () + "Return Gnus version available at run time." + (require 'gnus) + gnus-version) + +;;;###autoload +(defun mh-version () + "Display version information about MH-E and the MH mail handling system." + (interactive) + (mh-find-progs) + (set-buffer (get-buffer-create mh-temp-buffer)) + (erase-buffer) + ;; MH-E version. + (insert "MH-E " mh-version "\n\n") + ;; MH-E compilation details. + (insert "MH-E compilation details:\n") + (let* ((compiled-mhe (byte-code-function-p (symbol-function 'mh-version))) + (gnus-compiled-version (if compiled-mhe + (mh-macro-expansion-time-gnus-version) + "N/A"))) + (insert " Byte compiled:\t\t" (if compiled-mhe "yes" "no") "\n" + " Gnus (compile-time):\t" gnus-compiled-version "\n" + " Gnus (run-time):\t" (mh-run-time-gnus-version) "\n\n")) + ;; Emacs version. + (insert (emacs-version) "\n\n") + ;; MH version. + (let ((help-start (point))) + (condition-case err-data + (mh-exec-cmd-output "inc" nil (if mh-nmh-flag "-version" "-help")) + (file-error (insert (mapconcat 'concat (cdr err-data) ": ") "\n"))) + (goto-char help-start) + (if mh-nmh-flag + (search-forward "inc -- " nil t) + (search-forward "version: " nil t)) + (delete-region help-start (point))) + (goto-char (point-max)) + (insert " mh-progs:\t" mh-progs "\n" + " mh-lib:\t" mh-lib "\n" + " mh-lib-progs:\t" mh-lib-progs "\n\n") + ;; Linux version. + (condition-case () + (call-process "uname" nil t nil "-a") + (file-error)) + (goto-char (point-min)) + (display-buffer mh-temp-buffer)) + +(defun mh-parse-flist-output-line (line) + "Parse LINE to generate folder name, unseen messages and total messages." + (with-temp-buffer + (insert line) + (goto-char (point-max)) + (let (folder unseen total p) + (when (search-backward " out of " (point-min) t) + (setq total (read-from-string + (buffer-substring-no-properties + (match-end 0) (line-end-position)))) + (when (search-backward " in sequence " (point-min) t) + (setq p (point)) + (when (search-backward " has " (point-min) t) + (setq unseen (read-from-string (buffer-substring-no-properties + (match-end 0) p))) + (while (or (eq (char-after) ?+) (eq (char-after) ? )) + (backward-char)) + (setq folder (buffer-substring-no-properties + (point-min) (1+ (point)))) + (values (format "+%s" folder) (car unseen) (car total)))))))) + +(defun mh-folder-size (folder) + "Find size of FOLDER." + (with-temp-buffer + (call-process (expand-file-name "flist" mh-progs) nil t nil + "-norecurse" folder) + (goto-char (point-min)) + (multiple-value-bind (folder1 unseen total) + (mh-parse-flist-output-line + (buffer-substring (point) (line-end-position))) + (unless (equal folder folder1) + (error "Call to flist failed on folder %s" folder)) + (values total unseen)))) + +(defun mh-visit-folder (folder &optional range index-data) + "Visit FOLDER and display RANGE of messages. +Do not call this function from outside MH-E; see \\[mh-rmail] instead. + +If RANGE is nil (the default if it is omitted when called non-interactively), +then all messages in FOLDER are displayed. + +If an index buffer is being created then INDEX-DATA is used to initialize the +index buffer specific data structures." + (interactive (let ((folder-name (mh-prompt-for-folder "Visit" mh-inbox t))) + (list folder-name (mh-read-msg-range folder-name)))) + (let ((config (current-window-configuration)) + (threaded-view-flag mh-show-threads-flag)) + (save-excursion + (when (get-buffer folder) + (set-buffer folder) + (setq threaded-view-flag (memq 'unthread mh-view-ops)) + (mh-reset-threads-and-narrowing))) + (when index-data + (mh-make-folder folder) + (setq mh-index-data (car index-data) + mh-index-msg-checksum-map (make-hash-table :test #'equal) + mh-index-checksum-origin-map (make-hash-table :test #'equal)) + (mh-index-update-maps folder (cadr index-data))) + (mh-scan-folder folder (or range "all")) + (cond ((and threaded-view-flag + (save-excursion + (goto-char (point-min)) + (or (null mh-large-folder) + (not (equal (forward-line mh-large-folder) 0)) + (and (message "Not threading since the number of messages exceeds `mh-large-folder'") + nil)))) + (mh-toggle-threads)) + (mh-index-data + (mh-index-insert-folder-headers))) + (unless mh-showing-mode (delete-other-windows)) + (setq mh-previous-window-config config)) + nil) + +;;;###mh-autoload +(defun mh-update-sequences () + "Update MH's Unseen-Sequence and current folder and message. +Flush MH-E's state out to MH. The message at the cursor becomes current." + (interactive) + ;; mh-update-sequences is the opposite of mh-read-folder-sequences, + ;; which updates MH-E's state from MH. + (let ((folder-set (mh-update-unseen)) + (new-cur (mh-get-msg-num nil))) + (if new-cur + (let ((seq-entry (mh-find-seq 'cur))) + (mh-remove-cur-notation) + (setcdr seq-entry + (list new-cur)) ;delete-seq-locally, add-msgs-to-seq + (mh-define-sequence 'cur (list new-cur)) + (beginning-of-line) + (if (looking-at mh-scan-good-msg-regexp) + (mh-notate nil mh-note-cur mh-cmd-note))) + (or folder-set + (save-excursion + ;; psg - mh-current-folder is nil if mh-summary-height < 4 ! + ;; So I added this sanity check. + (if (stringp mh-current-folder) + (mh-exec-cmd-quiet t "folder" mh-current-folder "-fast") + (mh-exec-cmd-quiet t "folder" "-fast"))))))) + + + +;;; Support routines. + +(defun mh-delete-a-msg (msg) + "Delete the MSG. +The value of `mh-delete-msg-hook' is a list of functions to be called, with no +arguments, after the message has been deleted." + (save-excursion + (mh-goto-msg msg nil t) + (if (looking-at mh-scan-refiled-msg-regexp) + (error "Message %d is refiled. Undo refile before deleting" msg)) + (if (looking-at mh-scan-deleted-msg-regexp) + nil + (mh-set-folder-modified-p t) + (setq mh-delete-list (cons msg mh-delete-list)) + (mh-notate msg mh-note-deleted mh-cmd-note) + (run-hooks 'mh-delete-msg-hook)))) + +(defun mh-refile-a-msg (msg folder) + "Refile MSG in FOLDER. +Folder is a symbol, not a string. +The value of `mh-refile-msg-hook' is a list of functions to be called, with no +arguments, after the message has been refiled." + (save-excursion + (mh-goto-msg msg nil t) + (cond ((looking-at mh-scan-deleted-msg-regexp) + (error "Message %d is deleted. Undo delete before moving" msg)) + ((looking-at mh-scan-refiled-msg-regexp) + (if (y-or-n-p + (format "Message %d already refiled. Copy to %s as well? " + msg folder)) + (mh-exec-cmd "refile" (mh-get-msg-num t) "-link" + "-src" mh-current-folder + (symbol-name folder)) + (message "Message not copied."))) + (t + (mh-set-folder-modified-p t) + (cond ((null (assoc folder mh-refile-list)) + (push (list folder msg) mh-refile-list)) + ((not (member msg (cdr (assoc folder mh-refile-list)))) + (push msg (cdr (assoc folder mh-refile-list))))) + (mh-notate msg mh-note-refiled mh-cmd-note) + (run-hooks 'mh-refile-msg-hook))))) + +(defun mh-next-msg () + "Move backward or forward to the next undeleted message in the buffer." + (if (eq mh-next-direction 'forward) + (mh-next-undeleted-msg 1) + (mh-previous-undeleted-msg 1))) + +(defun mh-next-unread-msg (&optional count) + "Move to next unread message. +With optional argument COUNT, COUNT-1 unread messages are skipped." + (interactive "p") + (unless (> count 0) + (error "The function mh-next-unread-msg expects positive argument")) + (setq count (1- count)) + (let ((unread-sequence (reverse (cdr (assoc mh-unseen-seq mh-seq-list)))) + (cur-msg (mh-get-msg-num nil))) + (cond ((and (not cur-msg) (not (bobp)) + ;; If we are at the end of the buffer back up one line and go + ;; to unread message after that. + (progn + (forward-line -1) + (setq cur-msg (mh-get-msg-num nil))) + nil)) + ((or (null unread-sequence) (not cur-msg)) + ;; No unread message or there aren't any messages in buffer... + (message "No more unread messages")) + ((progn + ;; Skip messages + (while (and unread-sequence (>= cur-msg (car unread-sequence))) + (setq unread-sequence (cdr unread-sequence))) + (while (> count 0) + (setq unread-sequence (cdr unread-sequence)) + (setq count (1- count))) + (not (car unread-sequence))) + (message "No more unread messages")) + (t (mh-goto-msg (car unread-sequence)))))) + +(defun mh-set-scan-mode () + "Display the scan listing buffer, but do not show a message." + (if (get-buffer mh-show-buffer) + (delete-windows-on mh-show-buffer)) + (mh-showing-mode 0) + (force-mode-line-update) + (if mh-recenter-summary-flag + (mh-recenter nil))) + +(defun mh-undo-msg (msg) + "Undo the deletion or refile of one MSG." + (cond ((memq msg mh-delete-list) + (setq mh-delete-list (delq msg mh-delete-list))) + (t + (dolist (folder-msg-list mh-refile-list) + (setf (cdr folder-msg-list) (remove msg (cdr folder-msg-list)))) + (setq mh-refile-list (loop for x in mh-refile-list + unless (null (cdr x)) collect x)))) + (mh-notate msg ? mh-cmd-note)) + + + +;;; The folder data abstraction. + +(defun mh-make-folder (name) + "Create a new mail folder called NAME. +Make it the current folder." + (switch-to-buffer name) + (setq buffer-read-only nil) + (erase-buffer) + (if mh-adaptive-cmd-note-flag + (mh-set-cmd-note (mh-message-number-width name))) + (setq buffer-read-only t) + (mh-folder-mode) + (mh-set-folder-modified-p nil) + (setq buffer-file-name mh-folder-filename) + (mh-make-folder-mode-line)) + +;;; Ensure new buffers won't get this mode if default-major-mode is nil. +(put 'mh-folder-mode 'mode-class 'special) + + + +;;; Menu extracted from mh-menubar.el V1.1 (31 July 2001) +;;; Menus for folder mode: folder, message, sequence (in that order) +;;; folder-mode "Sequence" menu +(easy-menu-define + mh-folder-sequence-menu mh-folder-mode-map "Menu for MH-E folder-sequence." + '("Sequence" + ["Add Message to Sequence..." mh-put-msg-in-seq (mh-get-msg-num nil)] + ["List Sequences for Message" mh-msg-is-in-seq (mh-get-msg-num nil)] + ["Delete Message from Sequence..." mh-delete-msg-from-seq + (mh-get-msg-num nil)] + ["List Sequences in Folder..." mh-list-sequences t] + ["Delete Sequence..." mh-delete-seq t] + ["Narrow to Sequence..." mh-narrow-to-seq t] + ["Widen from Sequence" mh-widen mh-narrowed-to-seq] + "--" + ["Narrow to Subject Sequence" mh-narrow-to-subject t] + ["Delete Rest of Same Subject" mh-delete-subject t] + "--" + ["Push State Out to MH" mh-update-sequences t])) + +;;; folder-mode "Message" menu +(easy-menu-define + mh-folder-message-menu mh-folder-mode-map "Menu for MH-E folder-message." + '("Message" + ["Show Message" mh-show (mh-get-msg-num nil)] + ["Show Message with Header" mh-header-display (mh-get-msg-num nil)] + ["Next Message" mh-next-undeleted-msg t] + ["Previous Message" mh-previous-undeleted-msg t] + ["Go to First Message" mh-first-msg t] + ["Go to Last Message" mh-last-msg t] + ["Go to Message by Number..." mh-goto-msg t] + ["Modify Message" mh-modify] + ["Delete Message" mh-delete-msg (mh-get-msg-num nil)] + ["Refile Message" mh-refile-msg (mh-get-msg-num nil)] + ["Undo Delete/Refile" mh-undo t] + ["Process Delete/Refile" mh-execute-commands + (or mh-refile-list mh-delete-list)] + "--" + ["Compose a New Message" mh-send t] + ["Reply to Message..." mh-reply (mh-get-msg-num nil)] + ["Forward Message..." mh-forward (mh-get-msg-num nil)] + ["Redistribute Message..." mh-redistribute (mh-get-msg-num nil)] + ["Edit Message Again" mh-edit-again (mh-get-msg-num nil)] + ["Re-edit a Bounced Message" mh-extract-rejected-mail t] + "--" + ["Copy Message to Folder..." mh-copy-msg (mh-get-msg-num nil)] + ["Print Message" mh-print-msg (mh-get-msg-num nil)] + ["Write Message to File..." mh-write-msg-to-file + (mh-get-msg-num nil)] + ["Pipe Message to Command..." mh-pipe-msg (mh-get-msg-num nil)] + ["Unpack Uuencoded Message..." mh-store-msg (mh-get-msg-num nil)] + ["Burst Digest Message" mh-burst-digest (mh-get-msg-num nil)])) + +;;; folder-mode "Folder" menu +(easy-menu-define + mh-folder-folder-menu mh-folder-mode-map "Menu for MH-E folder." + '("Folder" + ["Incorporate New Mail" mh-inc-folder t] + ["Toggle Show/Folder" mh-toggle-showing t] + ["Execute Delete/Refile" mh-execute-commands + (or mh-refile-list mh-delete-list)] + ["Rescan Folder" mh-rescan-folder t] + ["Thread Folder" mh-toggle-threads + (not (memq 'unthread mh-view-ops))] + ["Pack Folder" mh-pack-folder t] + ["Sort Folder" mh-sort-folder t] + "--" + ["List Folders" mh-list-folders t] + ["Visit a Folder..." mh-visit-folder t] + ["Search a Folder..." mh-search-folder t] + ["Indexed Search..." mh-index-search t] + "--" + ["Quit MH-E" mh-quit t])) + + + +(defmacro mh-remove-xemacs-horizontal-scrollbar () + "Get rid of the horizontal scrollbar that XEmacs insists on putting in." + (when mh-xemacs-flag + `(if (and (featurep 'scrollbar) + (fboundp 'set-specifier)) + (set-specifier horizontal-scrollbar-visible-p nil + (cons (current-buffer) nil))))) + +(defmacro mh-write-file-functions-compat () + "Return `write-file-functions' if it exists. +Otherwise return `local-write-file-hooks'. This macro exists purely for +compatibility. The former symbol is used in Emacs 21.4 onward while the latter +is used in previous versions and XEmacs." + (if (boundp 'write-file-functions) + ''write-file-functions ;Emacs 21.4 + ''local-write-file-hooks)) ;<Emacs 21.4, XEmacs + +(define-derived-mode mh-folder-mode fundamental-mode "MH-Folder" + "Major MH-E mode for \"editing\" an MH folder scan listing.\\<mh-folder-mode-map> + +You can show the message the cursor is pointing to, and step through the +messages. Messages can be marked for deletion or refiling into another +folder; these commands are executed all at once with a separate command. + +A prefix argument (\\[universal-argument]) to delete, refile, list, or undo +applies the action to a message sequence. If `transient-mark-mode', +is non-nil, the action is applied to the region. + +Options that control this mode can be changed with \\[customize-group]; +specify the \"mh\" group. In particular, please see the `mh-scan-format-file' +option if you wish to modify scan's format. + +When a folder is visited, the hook `mh-folder-mode-hook' is run. + +\\{mh-folder-mode-map}" + + (make-local-variable 'font-lock-defaults) + (setq font-lock-defaults '(mh-folder-font-lock-keywords t)) + (mh-make-local-vars + 'mh-current-folder (buffer-name) ; Name of folder, a string + 'mh-show-buffer (format "show-%s" (buffer-name)) ; Buffer that displays msgs + 'mh-folder-filename ; e.g. "/usr/foobar/Mail/inbox/" + (file-name-as-directory (mh-expand-file-name (buffer-name))) + 'mh-showing-mode nil ; Show message also? + 'mh-delete-list nil ; List of msgs nums to delete + 'mh-refile-list nil ; List of folder names in mh-seq-list + 'mh-seq-list nil ; Alist of (seq . msgs) nums + 'mh-seen-list nil ; List of displayed messages + 'mh-next-direction 'forward ; Direction to move to next message + 'mh-narrowed-to-seq nil ; Sequence display is narrowed to + 'mh-view-ops () ; Stack that keeps track of the order + ; in which narrowing/threading has been + ; carried out. + 'mh-index-data nil ; If the folder was created by a call + ; to mh-index-search this contains info + ; about the search results. + 'mh-index-previous-search nil ; Previous folder and search-regexp + 'mh-index-msg-checksum-map nil ; msg -> checksum map + 'mh-index-checksum-origin-map nil ; checksum -> ( orig-folder, orig-msg ) + 'mh-first-msg-num nil ; Number of first msg in buffer + 'mh-last-msg-num nil ; Number of last msg in buffer + 'mh-msg-count nil ; Number of msgs in buffer + 'mh-mode-line-annotation nil ; Indicates message range + 'mh-previous-window-config nil) ; Previous window configuration + (mh-remove-xemacs-horizontal-scrollbar) + (setq truncate-lines t) + (auto-save-mode -1) + (setq buffer-offer-save t) + (add-hook (mh-write-file-functions-compat) 'mh-execute-commands nil t) + (make-local-variable 'revert-buffer-function) + (make-local-variable 'hl-line-mode) ; avoid pollution + (if (fboundp 'hl-line-mode) + (hl-line-mode 1)) + (setq revert-buffer-function 'mh-undo-folder) + (or (assq 'mh-showing-mode minor-mode-alist) + (setq minor-mode-alist + (cons '(mh-showing-mode " Show") minor-mode-alist))) + (easy-menu-add mh-folder-sequence-menu) + (easy-menu-add mh-folder-message-menu) + (easy-menu-add mh-folder-folder-menu) + (if (and (boundp 'tool-bar-mode) tool-bar-mode) + (set (make-local-variable 'tool-bar-map) mh-folder-tool-bar-map)) + (if (and mh-xemacs-flag + font-lock-auto-fontify) + (turn-on-font-lock))) ; Force font-lock in XEmacs. + +(defun mh-make-local-vars (&rest pairs) + "Initialize local variables according to the variable-value PAIRS." + + (while pairs + (set (make-local-variable (car pairs)) (car (cdr pairs))) + (setq pairs (cdr (cdr pairs))))) + +(defun mh-scan-folder (folder range &optional dont-exec-pending) + "Scan the FOLDER over the RANGE. +If the optional argument DONT-EXEC-PENDING is non-nil then pending deletes and +refiles aren't carried out. +Return in the folder's buffer." + (cond ((null (get-buffer folder)) + (mh-make-folder folder)) + (t + (or dont-exec-pending (mh-process-or-undo-commands folder)) + (switch-to-buffer folder))) + (mh-regenerate-headers range) + (if (zerop (buffer-size)) + (if (equal range "all") + (message "Folder %s is empty" folder) + (message "No messages in %s, range %s" folder range)) + (mh-goto-cur-msg)) + (save-excursion + (when dont-exec-pending + ;; Re-annotate messages to be refiled... + (dolist (folder-msg-list mh-refile-list) + (dolist (msg (cdr folder-msg-list)) + (mh-notate msg mh-note-refiled mh-cmd-note))) + ;; Re-annotate messages to be deleted... + (dolist (msg mh-delete-list) + (mh-notate msg mh-note-deleted mh-cmd-note))))) + +(defun mh-set-cmd-note (width) + "Set `mh-cmd-note' to WIDTH characters (minimum of 2). + +If `mh-scan-format-file' specifies nil or a filename, then this function +will NOT update `mh-cmd-note'." + ;; Add one to the width to always have whitespace in column zero. + (setq width (max (1+ width) 2)) + (if (and (equal mh-scan-format-file t) + (not (eq mh-cmd-note width))) + (setq mh-cmd-note width)) + mh-cmd-note) + +(defun mh-regenerate-headers (range &optional update) + "Scan folder over range RANGE. +If UPDATE, append the scan lines, otherwise replace." + (let ((folder mh-current-folder) + (range (if (and range (atom range)) (list range) range)) + scan-start) + (message "Scanning %s..." folder) + (with-mh-folder-updating (nil) + (if update + (goto-char (point-max)) + (delete-region (point-min) (point-max)) + (if mh-adaptive-cmd-note-flag + (mh-set-cmd-note (mh-message-number-width folder)))) + (setq scan-start (point)) + (apply #'mh-exec-cmd-output + mh-scan-prog nil + (mh-scan-format) + "-noclear" "-noheader" + "-width" (window-width) + folder range) + (goto-char scan-start) + (cond ((looking-at "scan: no messages in") + (keep-lines mh-scan-valid-regexp)) ; Flush random scan lines + ((looking-at "scan: bad message list ") + (keep-lines mh-scan-valid-regexp)) + ((looking-at "scan: ")) ; Keep error messages + (t + (keep-lines mh-scan-valid-regexp))) ; Flush random scan lines + (setq mh-seq-list (mh-read-folder-sequences folder nil)) + (mh-notate-user-sequences) + (or update + (setq mh-mode-line-annotation + (if (equal range '("all")) + nil + mh-partial-folder-mode-line-annotation))) + (mh-make-folder-mode-line)) + (message "Scanning %s...done" folder))) + +(defun mh-generate-new-cmd-note (folder) + "Fix the `mh-cmd-note' value for this FOLDER. + +After doing an `mh-get-new-mail' operation in this FOLDER, at least +one line that looks like a truncated message number was found. + +Remove the text added by the last `mh-inc' command. It should be the +messages cur-last. Call `mh-set-cmd-note' with the widest message number +in FOLDER. + +Reformat the message number width on each line in the buffer and trim +the line length to fit in the window. + +Rescan the FOLDER in the range cur-last in order to display the +messages that were removed earlier. They should all fit in the scan +line now with no message truncation." + (save-excursion + (let ((maxcol (1- (window-width))) + (old-cmd-note mh-cmd-note) + mh-cmd-note-fmt + msgnum) + ;; Nuke all of the lines just added by the last inc + (delete-char (- (point-max) (point))) + ;; Update the current buffer to reflect the new mh-cmd-note + ;; value needed to display messages. + (mh-set-cmd-note (mh-message-number-width folder)) + (setq mh-cmd-note-fmt (concat "%" (format "%d" mh-cmd-note) "d")) + ;; Cleanup the messages that are in the buffer right now + (goto-char (point-min)) + (cond ((memq 'unthread mh-view-ops) + (mh-thread-add-spaces (- mh-cmd-note old-cmd-note))) + (t (while (re-search-forward mh-scan-msg-number-regexp nil 0 1) + ;; reformat the number to fix in mh-cmd-note columns + (setq msgnum (string-to-number + (buffer-substring + (match-beginning 1) (match-end 1)))) + (replace-match (format mh-cmd-note-fmt msgnum)) + ;; trim the line to fix in the window + (end-of-line) + (let ((eol (point))) + (move-to-column maxcol) + (if (<= (point) eol) + (delete-char (- eol (point)))))))) + ;; now re-read the lost messages + (goto-char (point-max)) + (prog1 (point) + (mh-regenerate-headers "cur-last" t))))) + +(defun mh-get-new-mail (maildrop-name) + "Read new mail from MAILDROP-NAME into the current buffer. +Return in the current buffer." + (let ((point-before-inc (point)) + (folder mh-current-folder) + (new-mail-flag nil)) + (with-mh-folder-updating (t) + (if maildrop-name + (message "inc %s -file %s..." folder maildrop-name) + (message "inc %s..." folder)) + (setq mh-next-direction 'forward) + (goto-char (point-max)) + (let ((start-of-inc (point))) + (mh-remove-cur-notation) + (if maildrop-name + ;; I think MH 5 used "-ms-file" instead of "-file", + ;; which would make inc'ing from maildrops fail. + (mh-exec-cmd-output mh-inc-prog nil folder + (mh-scan-format) + "-file" (expand-file-name maildrop-name) + "-width" (window-width) + "-truncate") + (mh-exec-cmd-output mh-inc-prog nil + (mh-scan-format) + "-width" (window-width))) + (if maildrop-name + (message "inc %s -file %s...done" folder maildrop-name) + (message "inc %s...done" folder)) + (goto-char start-of-inc) + (cond ((save-excursion + (re-search-forward "^inc: no mail" nil t)) + (message "No new mail%s%s" (if maildrop-name " in " "") + (if maildrop-name maildrop-name ""))) + ((and (when mh-narrowed-to-seq + (let ((saved-text (buffer-substring-no-properties + start-of-inc (point-max)))) + (delete-region start-of-inc (point-max)) + (unwind-protect (mh-widen) + (goto-char (point-max)) + (setq start-of-inc (point)) + (insert saved-text) + (goto-char start-of-inc)))) + nil)) + ((re-search-forward "^inc:" nil t) ; Error messages + (error "Error incorporating mail")) + ((and + (equal mh-scan-format-file t) + mh-adaptive-cmd-note-flag + ;; Have we reached an edge condition? + (save-excursion + (re-search-forward mh-scan-msg-overflow-regexp nil 0 1)) + (setq start-of-inc (mh-generate-new-cmd-note folder)) + nil)) + (t + (setq new-mail-flag t))) + (keep-lines mh-scan-valid-regexp) ; Flush random scan lines + (setq mh-seq-list (mh-read-folder-sequences folder t)) + (when (equal (point-max) start-of-inc) + (mh-notate-seq 'cur mh-note-cur mh-cmd-note)) + (mh-notate-user-sequences) + (if new-mail-flag + (progn + (mh-make-folder-mode-line) + (when (memq 'unthread mh-view-ops) + (mh-thread-inc folder start-of-inc)) + (mh-goto-cur-msg)) + (goto-char point-before-inc)))))) + +(defun mh-make-folder-mode-line (&optional ignored) + "Set the fields of the mode line for a folder buffer. +The optional argument is now obsolete and IGNORED. It used to be used to pass +in what is now stored in the buffer-local variable `mh-mode-line-annotation'." + (save-excursion + (save-window-excursion + (mh-first-msg) + (let ((new-first-msg-num (mh-get-msg-num nil))) + (when (or (not (memq 'unthread mh-view-ops)) + (null mh-first-msg-num) + (null new-first-msg-num) + (< new-first-msg-num mh-first-msg-num)) + (setq mh-first-msg-num new-first-msg-num))) + (mh-last-msg) + (let ((new-last-msg-num (mh-get-msg-num nil))) + (when (or (not (memq 'unthread mh-view-ops)) + (null mh-last-msg-num) + (null new-last-msg-num) + (> new-last-msg-num mh-last-msg-num)) + (setq mh-last-msg-num new-last-msg-num))) + (setq mh-msg-count (if mh-first-msg-num + (count-lines (point-min) (point-max)) + 0)) + (setq mode-line-buffer-identification + (list (format "{%%b%s} %s msg%s" + (if mh-mode-line-annotation + (format "/%s" mh-mode-line-annotation) + "") + (if (zerop mh-msg-count) + "no" + (format "%d" mh-msg-count)) + (if (zerop mh-msg-count) + "s" + (cond ((> mh-msg-count 1) + (format "s (%d-%d)" mh-first-msg-num + mh-last-msg-num)) + (mh-first-msg-num + (format " (%d)" mh-first-msg-num)) + (""))))))))) + +(defun mh-unmark-all-headers (remove-all-flags) + "Remove all '+' flags from the folder listing. +With non-nil argument REMOVE-ALL-FLAGS, remove all 'D', '^' and '%' flags too. +Optimized for speed (i.e., no regular expressions)." + (save-excursion + (let ((case-fold-search nil) + (last-line (1- (point-max))) + char) + (mh-first-msg) + (while (<= (point) last-line) + (forward-char mh-cmd-note) + (setq char (following-char)) + (if (or (and remove-all-flags + (or (= char (aref mh-note-deleted 0)) + (= char (aref mh-note-refiled 0)))) + (= char (aref mh-note-cur 0))) + (progn + (delete-char 1) + (insert " "))) + (if remove-all-flags + (progn + (forward-char 1) + (if (= (following-char) (aref mh-note-seq 0)) + (progn + (delete-char 1) + (insert " "))))) + (forward-line))))) + +(defun mh-remove-cur-notation () + "Remove old cur notation." + (let ((cur-msg (car (mh-seq-to-msgs 'cur)))) + (save-excursion + (and cur-msg + (mh-goto-msg cur-msg t t) + (looking-at mh-scan-cur-msg-number-regexp) + (mh-notate nil ? mh-cmd-note))))) + +(defun mh-remove-all-notation () + "Remove all notations on all scan lines that MH-E introduces." + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (unless (or (equal (char-after) ?+) (eolp)) + (mh-notate nil ? mh-cmd-note) + (when (eq (char-after (+ (point) mh-cmd-note 1)) (elt mh-note-seq 0)) + (mh-notate nil ? (1+ mh-cmd-note)))) + (forward-line)))) + +;;;###mh-autoload +(defun mh-goto-cur-msg (&optional minimal-changes-flag) + "Position the cursor at the current message. +When optional argument MINIMAL-CHANGES-FLAG is non-nil, the function doesn't +recenter the folder buffer." + (let ((cur-msg (car (mh-seq-to-msgs 'cur)))) + (cond ((and cur-msg + (mh-goto-msg cur-msg t t)) + (unless minimal-changes-flag + (mh-notate nil mh-note-cur mh-cmd-note) + (mh-recenter 0) + (mh-maybe-show cur-msg))) + (t + (message "No current message"))))) + +(defun mh-process-or-undo-commands (folder) + "If FOLDER has outstanding commands, then either process or discard them. +Called by functions like `mh-sort-folder', so also invalidate show buffer." + (set-buffer folder) + (if (mh-outstanding-commands-p) + (if (or mh-do-not-confirm-flag + (y-or-n-p + "Process outstanding deletes and refiles (or lose them)? ")) + (mh-process-commands folder) + (mh-undo-folder))) + (mh-update-unseen) + (mh-invalidate-show-buffer)) + +(defun mh-process-commands (folder) + "Process outstanding commands for FOLDER. +The value of `mh-folder-updated-hook' is a list of functions to be called, +with no arguments, before the commands are processed." + (message "Processing deletes and refiles for %s..." folder) + (set-buffer folder) + (with-mh-folder-updating (nil) + ;; Run the hook while the lists are still valid + (run-hooks 'mh-folder-updated-hook) + + ;; Update the unseen sequence if it exists + (mh-update-unseen) + + (let ((redraw-needed-flag mh-index-data)) + ;; Remove invalid scan lines if we are in an index folder and then remove + ;; the real messages + (when mh-index-data + (mh-index-delete-folder-headers) + (mh-index-execute-commands)) + + ;; Then refile messages + (mh-mapc #'(lambda (folder-msg-list) + (let ((dest-folder (symbol-name (car folder-msg-list))) + (msgs (cdr folder-msg-list))) + (setq redraw-needed-flag t) + (apply #'mh-exec-cmd + "refile" "-src" folder dest-folder + (mh-coalesce-msg-list msgs)) + (mh-delete-scan-msgs msgs))) + mh-refile-list) + (setq mh-refile-list ()) + + ;; Now delete messages + (cond (mh-delete-list + (setq redraw-needed-flag t) + (apply 'mh-exec-cmd "rmm" folder + (mh-coalesce-msg-list mh-delete-list)) + (mh-delete-scan-msgs mh-delete-list) + (setq mh-delete-list nil))) + + ;; Don't need to remove sequences since delete and refile do so. + ;; Mark cur message + (if (> (buffer-size) 0) + (mh-define-sequence 'cur (list (or (mh-get-msg-num nil) "last")))) + + ;; Redraw folder buffer if needed + (when (and redraw-needed-flag) + (cond ((memq 'unthread mh-view-ops) (mh-thread-inc folder (point-max))) + (mh-index-data (mh-index-insert-folder-headers))))) + + (and (buffer-file-name (get-buffer mh-show-buffer)) + (not (file-exists-p (buffer-file-name (get-buffer mh-show-buffer)))) + ;; If "inc" were to put a new msg in this file, + ;; we would not notice, so mark it invalid now. + (mh-invalidate-show-buffer)) + + (setq mh-seq-list (mh-read-folder-sequences mh-current-folder nil)) + (mh-unmark-all-headers t) + (mh-notate-user-sequences) + (message "Processing deletes and refiles for %s...done" folder))) + +(defun mh-update-unseen () + "Synchronize the unseen sequence with MH. +Return non-nil iff the MH folder was set. +The value of `mh-unseen-updated-hook' is a list of functions to be called, +with no arguments, after the unseen sequence is updated." + (if mh-seen-list + (let* ((unseen-seq (mh-find-seq mh-unseen-seq)) + (unseen-msgs (mh-seq-msgs unseen-seq))) + (if unseen-msgs + (progn + (mh-undefine-sequence mh-unseen-seq mh-seen-list) + (run-hooks 'mh-unseen-updated-hook) + (while mh-seen-list + (setq unseen-msgs (delq (car mh-seen-list) unseen-msgs)) + (setq mh-seen-list (cdr mh-seen-list))) + (setcdr unseen-seq unseen-msgs) + t) ;since we set the folder + (setq mh-seen-list nil))))) + +(defun mh-delete-scan-msgs (msgs) + "Delete the scan listing lines for MSGS." + (save-excursion + (while msgs + (when (mh-goto-msg (car msgs) t t) + (when (memq 'unthread mh-view-ops) + (mh-thread-forget-message (car msgs))) + (mh-delete-line 1)) + (setq msgs (cdr msgs))))) + +(defun mh-outstanding-commands-p () + "Return non-nil if there are outstanding deletes or refiles." + (or mh-delete-list mh-refile-list)) + +(defun mh-coalesce-msg-list (messages) + "Give a list of MESSAGES, return a list of message number ranges. +Sort of the opposite of `mh-read-msg-list', which expands ranges. +Message lists passed to MH programs go through this so +command line arguments won't exceed system limits." + (let ((msgs (sort (copy-sequence messages) 'mh-greaterp)) + (range-high nil) + (prev -1) + (ranges nil)) + (while prev + (if range-high + (if (or (not (numberp prev)) + (not (equal (car msgs) (1- prev)))) + (progn ;non-sequential, flush old range + (if (eq prev range-high) + (setq ranges (cons range-high ranges)) + (setq ranges (cons (format "%s-%s" prev range-high) ranges))) + (setq range-high nil)))) + (or range-high + (setq range-high (car msgs))) ;start new or first range + (setq prev (car msgs)) + (setq msgs (cdr msgs))) + ranges)) + +(defun mh-greaterp (msg1 msg2) + "Return the greater of two message indicators MSG1 and MSG2. +Strings are \"smaller\" than numbers. +Legal values are things like \"cur\", \"last\", 1, and 1820." + (if (numberp msg1) + (if (numberp msg2) + (> msg1 msg2) + t) + (if (numberp msg2) + nil + (string-lessp msg2 msg1)))) + +(defun mh-lessp (msg1 msg2) + "Return the lesser of two message indicators MSG1 and MSG2. +Strings are \"smaller\" than numbers. +Legal values are things like \"cur\", \"last\", 1, and 1820." + (not (mh-greaterp msg1 msg2))) + + + +;;; Basic sequence handling + +(defun mh-delete-seq-locally (seq) + "Remove MH-E's record of SEQ." + (let ((entry (mh-find-seq seq))) + (setq mh-seq-list (delq entry mh-seq-list)))) + +(defun mh-read-folder-sequences (folder save-refiles) + "Read and return the predefined sequences for a FOLDER. +If SAVE-REFILES is non-nil, then keep the sequences +that note messages to be refiled." + (let ((seqs ())) + (cond (save-refiles + (mh-mapc (function (lambda (seq) ; Save the refiling sequences + (if (mh-folder-name-p (mh-seq-name seq)) + (setq seqs (cons seq seqs))))) + mh-seq-list))) + (save-excursion + (if (eq 0 (mh-exec-cmd-quiet nil "mark" folder "-list")) + (progn + ;; look for name in line of form "cur: 4" or "myseq (private): 23" + (while (re-search-forward "^[^: ]+" nil t) + (setq seqs (cons (mh-make-seq (intern (buffer-substring + (match-beginning 0) + (match-end 0))) + (mh-read-msg-list)) + seqs))) + (delete-region (point-min) (point))))) ; avoid race with + ; mh-process-daemon + seqs)) + +(defun mh-read-msg-list () + "Return a list of message numbers from point to the end of the line. +Expands ranges into set of individual numbers." + (let ((msgs ()) + (end-of-line (save-excursion (end-of-line) (point))) + num) + (while (re-search-forward "[0-9]+" end-of-line t) + (setq num (string-to-int (buffer-substring (match-beginning 0) + (match-end 0)))) + (cond ((looking-at "-") ; Message range + (forward-char 1) + (re-search-forward "[0-9]+" end-of-line t) + (let ((num2 (string-to-int (buffer-substring (match-beginning 0) + (match-end 0))))) + (if (< num2 num) + (error "Bad message range: %d-%d" num num2)) + (while (<= num num2) + (setq msgs (cons num msgs)) + (setq num (1+ num))))) + ((not (zerop num)) ;"pick" outputs "0" to mean no match + (setq msgs (cons num msgs))))) + msgs)) + +(defun mh-notate-user-sequences () + "Mark the scan listing of all messages in user-defined sequences." + (let ((seqs mh-seq-list) + name) + (while seqs + (setq name (mh-seq-name (car seqs))) + (if (not (mh-internal-seq name)) + (mh-notate-seq name mh-note-seq (1+ mh-cmd-note))) + (setq seqs (cdr seqs))))) + +(defun mh-internal-seq (name) + "Return non-nil if NAME is the name of an internal MH-E sequence." + (or (memq name '(answered cur deleted forwarded printed)) + (eq name mh-unseen-seq) + (eq name mh-previous-seq) + (mh-folder-name-p name))) + +(defun mh-delete-msg-from-seq (message sequence &optional internal-flag) + "Delete MESSAGE from SEQUENCE. +MESSAGE defaults to displayed message. From Lisp, optional third arg +INTERNAL-FLAG non-nil means do not inform MH of the change." + (interactive (list (mh-get-msg-num t) + (mh-read-seq-default "Delete from" t) + nil)) + (let ((entry (mh-find-seq sequence))) + (cond (entry + (mh-notate-if-in-one-seq message ? (1+ mh-cmd-note) sequence) + (if (not internal-flag) + (mh-undefine-sequence sequence (list message))) + (setcdr entry (delq message (mh-seq-msgs entry))))))) + +(defun mh-undefine-sequence (seq msgs) + "Remove from the SEQ the list of MSGS." + (mh-exec-cmd "mark" mh-current-folder "-delete" + "-sequence" (symbol-name seq) + (mh-coalesce-msg-list msgs))) + +(defun mh-define-sequence (seq msgs) + "Define the SEQ to contain the list of MSGS. +Do not mark pseudo-sequences or empty sequences. +Signals an error if SEQ is an illegal name." + (if (and msgs + (not (mh-folder-name-p seq))) + (save-excursion + (mh-exec-cmd-error nil "mark" mh-current-folder "-add" "-zero" + "-sequence" (symbol-name seq) + (mh-coalesce-msg-list msgs))))) + +(defun mh-map-over-seqs (function seq-list) + "Apply FUNCTION to each sequence in SEQ-LIST. +The sequence name and the list of messages are passed as arguments." + (while seq-list + (funcall function + (mh-seq-name (car seq-list)) + (mh-seq-msgs (car seq-list))) + (setq seq-list (cdr seq-list)))) + +(defun mh-notate-if-in-one-seq (msg character offset seq) + "Notate MSG. +The CHARACTER is placed at the given OFFSET from the beginning of the listing. +The notation is performed if the MSG is only in SEQ." + (let ((in-seqs (mh-seq-containing-msg msg nil))) + (if (and (eq seq (car in-seqs)) (null (cdr in-seqs))) + (mh-notate msg character offset)))) + +(defun mh-seq-containing-msg (msg &optional include-internal-flag) + "Return a list of the sequences containing MSG. +If INCLUDE-INTERNAL-FLAG non-nil, include MH-E internal sequences in list." + (let ((l mh-seq-list) + (seqs ())) + (while l + (and (memq msg (mh-seq-msgs (car l))) + (or include-internal-flag + (not (mh-internal-seq (mh-seq-name (car l))))) + (setq seqs (cons (mh-seq-name (car l)) seqs))) + (setq l (cdr l))) + seqs)) + + + +;;; User prompting commands. + +(defun mh-read-msg-range (folder &optional always-prompt-flag) + "Prompt for message range from FOLDER. +If optional second argument ALWAYS-PROMPT-FLAG is non-nil then always ask for +range." + (multiple-value-bind (total unseen) (mh-folder-size folder) + (cond + ((and (not always-prompt-flag) (numberp unseen) (> unseen 0)) + (list (symbol-name mh-unseen-seq))) + ((or (null mh-large-folder) (not (numberp total))) + (list "all")) + ((and (numberp total) (or always-prompt-flag (> total mh-large-folder))) + (let* ((prompt + (format "Range or number of messages to read (default: %s): " + total)) + (in (read-string prompt nil nil (number-to-string total)))) + (cond ((string-match "^[ \f\t\n\r\v]*[0-9]+[ \f\t\n\r\v]*$" in) + (list (format "last:%s" (car (read-from-string in))))) + ((equal in "") (list "all")) + (t (split-string in))))) + (t (list "all"))))) + + + +;;; Build the folder-mode keymap: + +(suppress-keymap mh-folder-mode-map) + +;; Use defalias to make sure the documented primary key bindings +;; appear in menu lists. +(defalias 'mh-alt-show 'mh-show) +(defalias 'mh-alt-refile-msg 'mh-refile-msg) +(defalias 'mh-alt-send 'mh-send) +(defalias 'mh-alt-visit-folder 'mh-visit-folder) + +;; Save the `b' binding for a future `back'. Maybe? +(gnus-define-keys mh-folder-mode-map + " " mh-page-msg + "!" mh-refile-or-write-again + "," mh-header-display + "." mh-alt-show + ">" mh-write-msg-to-file + "?" mh-help + "E" mh-extract-rejected-mail + "M" mh-modify + "\177" mh-previous-page + "\C-d" mh-delete-msg-no-motion + "\t" mh-index-next-folder + [backtab] mh-index-previous-folder + "\M-\t" mh-index-previous-folder + "\e<" mh-first-msg + "\e>" mh-last-msg + "\ed" mh-redistribute + "\r" mh-show + "^" mh-alt-refile-msg + "c" mh-copy-msg + "d" mh-delete-msg + "e" mh-edit-again + "f" mh-forward + "g" mh-goto-msg + "i" mh-inc-folder + "k" mh-delete-subject-or-thread + "l" mh-print-msg + "m" mh-alt-send + "n" mh-next-undeleted-msg + "\M-n" mh-next-unread-msg + "o" mh-refile-msg + "p" mh-previous-undeleted-msg + "\M-p" mh-previous-unread-msg + "q" mh-quit + "r" mh-reply + "s" mh-send + "t" mh-toggle-showing + "u" mh-undo + "v" mh-index-visit-folder + "x" mh-execute-commands + "|" mh-pipe-msg) + +(gnus-define-keys (mh-folder-map "F" mh-folder-mode-map) + "?" mh-prefix-help + "S" mh-sort-folder + "f" mh-alt-visit-folder + "i" mh-index-search + "k" mh-kill-folder + "l" mh-list-folders + "o" mh-alt-visit-folder + "p" mh-pack-folder + "r" mh-rescan-folder + "s" mh-search-folder + "u" mh-undo-folder + "v" mh-visit-folder) + +(gnus-define-keys (mh-sequence-map "S" mh-folder-mode-map) + "?" mh-prefix-help + "d" mh-delete-msg-from-seq + "k" mh-delete-seq + "l" mh-list-sequences + "n" mh-narrow-to-seq + "p" mh-put-msg-in-seq + "s" mh-msg-is-in-seq + "w" mh-widen) + +(gnus-define-keys (mh-thread-map "T" mh-folder-mode-map) + "?" mh-prefix-help + "u" mh-thread-ancestor + "p" mh-thread-previous-sibling + "n" mh-thread-next-sibling + "t" mh-toggle-threads + "d" mh-thread-delete + "o" mh-thread-refile) + +(gnus-define-keys (mh-limit-map "/" mh-folder-mode-map) + "?" mh-prefix-help + "s" mh-narrow-to-subject + "w" mh-widen) + +(gnus-define-keys (mh-extract-map "X" mh-folder-mode-map) + "?" mh-prefix-help + "s" mh-store-msg ;shar + "u" mh-store-msg) ;uuencode + +(gnus-define-keys (mh-digest-map "D" mh-folder-mode-map) + " " mh-page-digest + "?" mh-prefix-help + "\177" mh-page-digest-backwards + "b" mh-burst-digest) + +(gnus-define-keys (mh-mime-map "K" mh-folder-mode-map) + "?" mh-prefix-help + "a" mh-mime-save-parts + "i" mh-folder-inline-mime-part + "o" mh-folder-save-mime-part + "v" mh-folder-toggle-mime-part + "\t" mh-next-button + [backtab] mh-prev-button + "\M-\t" mh-prev-button) + +(cond + (mh-xemacs-flag + (define-key mh-folder-mode-map [button2] 'mh-show-mouse)) + (t + (define-key mh-folder-mode-map [mouse-2] 'mh-show-mouse))) + +;; "C-c /" prefix is used in mh-folder-mode by pgp.el and mailcrypt + + + +;;; Help Messages + +;;; If you add a new prefix, add appropriate text to the nil key. +;;; +;;; In general, messages are grouped logically. Taking the main commands for +;;; example, the first line is "ways to view messages," the second line is +;;; "things you can do with messages", and the third is "composing" messages. +;;; +;;; When adding a new prefix, ensure that the help message contains "what" the +;;; prefix is for. For example, if the word "folder" were not present in the +;;; `F' entry, it would not be clear what these commands operated upon. +(defvar mh-help-messages + '((nil "[i]nc, [.]show, [,]show all, [n]ext, [p]revious,\n" + "[d]elete, [o]refile, e[x]ecute,\n" + "[s]end, [r]eply.\n" + "Prefix characters:\n [F]older, [S]equence, MIME [K]eys, " + "[T]hread, / Limit, e[X]tract, [D]igest.") + + (?F "[l]ist, [v]isit folder;\n" + "[t]hread; [s]earch; [i]ndexed search;\n" + "[p]ack; [S]ort; [r]escan; [k]ill") + (?S "[p]ut message in sequence, [n]arrow, [w]iden,\n" + "[s]equences, [l]ist,\n" + "[d]elete message from sequence, [k]ill sequence") + (?T "[t]oggle, [d]elete, [o]refile thread") + (?/ "Limit to [s]ubject; [w]iden") + (?X "un[s]har, [u]udecode message") + (?D "[b]urst digest") + (?K "[v]iew, [i]nline, [o]utput/save MIME part; save [a]ll parts; \n" + "[TAB] next; [SHIFT-TAB] previous")) + "Key binding cheat sheet. + +This is an associative array which is used to show the most common commands. +The key is a prefix char. The value is one or more strings which are +concatenated together and displayed in the minibuffer if ? is pressed after +the prefix character. The special key nil is used to display the +non-prefixed commands. + +The substitutions described in `substitute-command-keys' are performed as +well.") + + + +(dolist (mess '("^Cursor not pointing to message$" + "^There is no other window$")) + (add-to-list 'debug-ignored-errors mess)) + +(provide 'mh-e) + +;;; Local Variables: +;;; indent-tabs-mode: nil +;;; sentence-end-double-space: nil +;;; End: + +;;; mh-e.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mh-e/mh-funcs.el Sun Jan 26 02:38:37 2003 +0000 @@ -0,0 +1,436 @@ +;;; mh-funcs.el --- MH-E functions not everyone will use right away + +;; Copyright (C) 1993, 1995, 2001, 2002 Free Software Foundation, Inc. + +;; Author: Bill Wohler <wohler@newt.com> +;; Maintainer: Bill Wohler <wohler@newt.com> +;; Keywords: mail +;; See: mh-e.el + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Internal support for MH-E package. +;; Putting these functions in a separate file lets MH-E start up faster, +;; since less Lisp code needs to be loaded all at once. + +;;; Change Log: + +;; $Id: mh-funcs.el,v 1.9 2003/01/08 23:21:16 wohler Exp $ + +;;; Code: + +(require 'mh-e) + +;;; Customization + +(defvar mh-sortm-args nil + "Extra arguments to have \\[mh-sort-folder] pass to the \"sortm\" command. +The arguments are passed to sortm if \\[mh-sort-folder] is given a +prefix argument. Normally default arguments to sortm are specified in the +MH profile. +For example, '(\"-nolimit\" \"-textfield\" \"subject\") is a useful setting.") + +(defvar mh-note-copied "C" + "String whose first character is used to notate copied messages.") + +(defvar mh-note-printed "P" + "String whose first character is used to notate printed messages.") + +;;; Functions + +;;;###mh-autoload +(defun mh-burst-digest () + "Burst apart the current message, which should be a digest. +The message is replaced by its table of contents and the messages from the +digest are inserted into the folder after that message." + (interactive) + (let ((digest (mh-get-msg-num t))) + (mh-process-or-undo-commands mh-current-folder) + (mh-set-folder-modified-p t) ; lock folder while bursting + (message "Bursting digest...") + (mh-exec-cmd "burst" mh-current-folder digest "-inplace") + (with-mh-folder-updating (t) + (beginning-of-line) + (delete-region (point) (point-max))) + (mh-regenerate-headers (format "%d-last" digest) t) + (mh-goto-cur-msg) + (message "Bursting digest...done"))) + +;;;###mh-autoload +(defun mh-copy-msg (msg-or-seq folder) + "Copy the specified MSG-OR-SEQ to another FOLDER without deleting them. +Default is the displayed message. If optional prefix argument is provided, +then prompt for the message sequence." + (interactive (list (cond + ((mh-mark-active-p t) + (mh-region-to-msg-list (region-beginning) (region-end))) + (current-prefix-arg + (mh-read-seq-default "Copy" t)) + (t + (mh-get-msg-num t))) + (mh-prompt-for-folder "Copy to" "" t))) + (mh-exec-cmd "refile" + (cond ((numberp msg-or-seq) msg-or-seq) + ((listp msg-or-seq) msg-or-seq) + (t (mh-coalesce-msg-list (mh-seq-to-msgs msg-or-seq)))) + "-link" "-src" mh-current-folder folder) + (if (numberp msg-or-seq) + (mh-notate msg-or-seq mh-note-copied mh-cmd-note) + (mh-notate-seq msg-or-seq mh-note-copied mh-cmd-note))) + +;;;###mh-autoload +(defun mh-kill-folder () + "Remove the current folder and all included messages. +Removes all of the messages (files) within the specified current folder, +and then removes the folder (directory) itself. +The value of `mh-folder-list-change-hook' is a list of functions to be called, +with no arguments, after the folders has been removed." + (interactive) + (if (yes-or-no-p (format "Remove folder %s (and all included messages)?" + mh-current-folder)) + (let ((folder mh-current-folder)) + (if (null mh-folder-list) + (mh-set-folder-list)) + (mh-set-folder-modified-p t) ; lock folder to kill it + (mh-exec-cmd-daemon "rmf" folder) + (setq mh-folder-list + (delq (assoc folder mh-folder-list) mh-folder-list)) + (when (boundp 'mh-speed-folder-map) + (mh-speed-invalidate-map folder)) + (run-hooks 'mh-folder-list-change-hook) + (message "Folder %s removed" folder) + (mh-set-folder-modified-p nil) ; so kill-buffer doesn't complain + (if (get-buffer mh-show-buffer) + (kill-buffer mh-show-buffer)) + (if (get-buffer folder) + (kill-buffer folder))) + (message "Folder not removed"))) + +;; Avoid compiler warning... +(defvar view-exit-action) + +;;;###mh-autoload +(defun mh-list-folders () + "List mail folders." + (interactive) + (let ((temp-buffer mh-temp-folders-buffer)) + (with-output-to-temp-buffer temp-buffer + (save-excursion + (set-buffer temp-buffer) + (erase-buffer) + (message "Listing folders...") + (mh-exec-cmd-output "folders" t (if mh-recursive-folders-flag + "-recurse" + "-norecurse")) + (goto-char (point-min)) + (view-mode 1) + (setq view-exit-action 'kill-buffer) + (message "Listing folders...done"))))) + +;;;###mh-autoload +(defun mh-pack-folder (range) + "Renumber the messages of a folder to be 1..n. +First, offer to execute any outstanding commands for the current folder. If +optional prefix argument provided, prompt for the RANGE of messages to display +after packing. Otherwise, show the entire folder." + (interactive (list (if current-prefix-arg + (mh-read-msg-range mh-current-folder t) + '("all")))) + (let ((threaded-flag (memq 'unthread mh-view-ops))) + (mh-pack-folder-1 range) + (mh-goto-cur-msg) + (when mh-index-data + (mh-index-update-maps mh-current-folder)) + (cond (threaded-flag (mh-toggle-threads)) + (mh-index-data (mh-index-insert-folder-headers)))) + (message "Packing folder...done")) + +(defun mh-pack-folder-1 (range) + "Close and pack the current folder. +Display the given RANGE of messages after packing. If RANGE is nil, show the +entire folder." + (mh-process-or-undo-commands mh-current-folder) + (message "Packing folder...") + (mh-set-folder-modified-p t) ; lock folder while packing + (save-excursion + (mh-exec-cmd-quiet t "folder" mh-current-folder "-pack" + "-norecurse" "-fast")) + (mh-reset-threads-and-narrowing) + (mh-regenerate-headers range)) + +;;;###mh-autoload +(defun mh-pipe-msg (command include-headers) + "Pipe the current message through the given shell COMMAND. +If INCLUDE-HEADERS (prefix argument) is provided, send the entire message. +Otherwise just send the message's body without the headers." + (interactive + (list (read-string "Shell command on message: ") current-prefix-arg)) + (let ((msg-file-to-pipe (mh-msg-filename (mh-get-msg-num t))) + (message-directory default-directory)) + (save-excursion + (set-buffer (get-buffer-create mh-temp-buffer)) + (erase-buffer) + (insert-file-contents msg-file-to-pipe) + (goto-char (point-min)) + (if (not include-headers) (search-forward "\n\n")) + (let ((default-directory message-directory)) + (shell-command-on-region (point) (point-max) command nil))))) + +;;;###mh-autoload +(defun mh-page-digest () + "Advance displayed message to next digested message." + (interactive) + (mh-in-show-buffer (mh-show-buffer) + ;; Go to top of screen (in case user moved point). + (move-to-window-line 0) + (let ((case-fold-search nil)) + ;; Search for blank line and then for From: + (or (and (search-forward "\n\n" nil t) + (re-search-forward "^From:" nil t)) + (error "No more messages in digest"))) + ;; Go back to previous blank line, then forward to the first non-blank. + (search-backward "\n\n" nil t) + (forward-line 2) + (mh-recenter 0))) + +;;;###mh-autoload +(defun mh-page-digest-backwards () + "Back up displayed message to previous digested message." + (interactive) + (mh-in-show-buffer (mh-show-buffer) + ;; Go to top of screen (in case user moved point). + (move-to-window-line 0) + (let ((case-fold-search nil)) + (beginning-of-line) + (or (and (search-backward "\n\n" nil t) + (re-search-backward "^From:" nil t)) + (error "No previous message in digest"))) + ;; Go back to previous blank line, then forward to the first non-blank. + (if (search-backward "\n\n" nil t) + (forward-line 2)) + (mh-recenter 0))) + +;;;###mh-autoload +(defun mh-print-msg (msg-or-seq) + "Print MSG-OR-SEQ (default: displayed message) on printer. +If optional prefix argument provided, then prompt for the message sequence. +The variable `mh-lpr-command-format' is used to generate the print command. +The messages are formatted by mhl. See the variable `mhl-formfile'." + (interactive (list (if current-prefix-arg + (reverse (mh-seq-to-msgs + (mh-read-seq-default "Print" t))) + (mh-get-msg-num t)))) + (if (numberp msg-or-seq) + (message "Printing message...") + (message "Printing sequence...")) + (let ((print-command + (if (numberp msg-or-seq) + (format "%s -nobell -clear %s %s | %s" + (expand-file-name "mhl" mh-lib-progs) + (mh-msg-filename msg-or-seq) + (if (stringp mhl-formfile) + (format "-form %s" mhl-formfile) + "") + (format mh-lpr-command-format + (if (numberp msg-or-seq) + (format "%s/%d" mh-current-folder + msg-or-seq) + (format "Sequence from %s" mh-current-folder)))) + (format "(scan -clear %s ; %s -nobell -clear %s %s) | %s" + (mapconcat (function (lambda (msg) msg)) msg-or-seq " ") + (expand-file-name "mhl" mh-lib-progs) + (if (stringp mhl-formfile) + (format "-form %s" mhl-formfile) + "") + (mh-msg-filenames msg-or-seq) + (format mh-lpr-command-format + (if (numberp msg-or-seq) + (format "%s/%d" mh-current-folder + msg-or-seq) + (format "Sequence from %s" + mh-current-folder))))))) + (if mh-print-background-flag + (mh-exec-cmd-daemon shell-file-name "-c" print-command) + (call-process shell-file-name nil nil nil "-c" print-command)) + (if (numberp msg-or-seq) + (mh-notate msg-or-seq mh-note-printed mh-cmd-note) + (mh-notate-seq msg-or-seq mh-note-printed mh-cmd-note)) + (mh-add-msgs-to-seq msg-or-seq 'printed t) + (if (numberp msg-or-seq) + (message "Printing message...done") + (message "Printing sequence...done")))) + +(defun mh-msg-filenames (msgs &optional folder) + "Return a list of file names for MSGS in FOLDER (default current folder)." + (mapconcat (function (lambda (msg) (mh-msg-filename msg folder))) msgs " ")) + +;;;###mh-autoload +(defun mh-sort-folder (&optional extra-args) + "Sort the messages in the current folder by date. +Calls the MH program sortm to do the work. +The arguments in the list `mh-sortm-args' are passed to sortm if the optional +argument EXTRA-ARGS is given." + (interactive "P") + (mh-process-or-undo-commands mh-current-folder) + (setq mh-next-direction 'forward) + (mh-set-folder-modified-p t) ; lock folder while sorting + (message "Sorting folder...") + (let ((threaded-flag (memq 'unthread mh-view-ops))) + (mh-exec-cmd "sortm" mh-current-folder (if extra-args mh-sortm-args)) + (when mh-index-data + (mh-index-update-maps mh-current-folder)) + (message "Sorting folder...done") + (mh-reset-threads-and-narrowing) + (mh-scan-folder mh-current-folder "all") + (cond (threaded-flag (mh-toggle-threads)) + (mh-index-data (mh-index-insert-folder-headers))))) + +;;;###mh-autoload +(defun mh-undo-folder (&rest ignore) + "Undo all pending deletes and refiles in current folder. +Argument IGNORE is deprecated." + (interactive) + (cond ((or mh-do-not-confirm-flag + (yes-or-no-p "Undo all commands in folder? ")) + (setq mh-delete-list nil + mh-refile-list nil + mh-seq-list nil + mh-next-direction 'forward) + (with-mh-folder-updating (nil) + (mh-unmark-all-headers t))) + (t + (message "Commands not undone.") + (sit-for 2)))) + +;;;###mh-autoload +(defun mh-store-msg (directory) + "Store the file(s) contained in the current message into DIRECTORY. +The message can contain a shar file or uuencoded file. +Default directory is the last directory used, or initially the value of +`mh-store-default-directory' or the current directory." + (interactive (list (let ((udir (or mh-store-default-directory + default-directory))) + (read-file-name "Store message in directory: " + udir udir nil)))) + (let ((msg-file-to-store (mh-msg-filename (mh-get-msg-num t)))) + (save-excursion + (set-buffer (get-buffer-create mh-temp-buffer)) + (erase-buffer) + (insert-file-contents msg-file-to-store) + (mh-store-buffer directory)))) + +;;;###mh-autoload +(defun mh-store-buffer (directory) + "Store the file(s) contained in the current buffer into DIRECTORY. +The buffer can contain a shar file or uuencoded file. +Default directory is the last directory used, or initially the value of +`mh-store-default-directory' or the current directory." + (interactive (list (let ((udir (or mh-store-default-directory + default-directory))) + (read-file-name "Store buffer in directory: " + udir udir nil)))) + (let ((store-directory (expand-file-name directory)) + (sh-start (save-excursion + (goto-char (point-min)) + (if (re-search-forward + "^#![ \t]*/bin/sh\\|^#\\|^: " nil t) + (progn + ;; The "cut here" pattern was removed from above + ;; because it seemed to hurt more than help. + ;; But keep this to make it easier to put it back. + (if (looking-at "^[^a-z0-9\"]*cut here\\b") + (forward-line 1)) + (beginning-of-line) + (if (looking-at "^[#:]....+\n\\( ?\n\\)?end$") + nil ;most likely end of a uuencode + (point)))))) + (log-buffer (get-buffer-create "*Store Output*")) + (command "sh") + (uudecode-filename "(unknown filename)")) + (if (not sh-start) + (save-excursion + (goto-char (point-min)) + (if (re-search-forward "^begin [0-7]+ " nil t) + (setq uudecode-filename + (buffer-substring (point) + (progn (end-of-line) (point))))))) + (save-excursion + (set-buffer log-buffer) + (erase-buffer) + (if (not (file-directory-p store-directory)) + (progn + (insert "mkdir " directory "\n") + (call-process "mkdir" nil log-buffer t store-directory))) + (insert "cd " directory "\n") + (setq mh-store-default-directory directory) + (if (not sh-start) + (progn + (setq command "uudecode") + (insert uudecode-filename " being uudecoded...\n")))) + (set-window-start (display-buffer log-buffer) 0) ;watch progress + (let (value) + (let ((default-directory (file-name-as-directory store-directory))) + (setq value (call-process-region sh-start (point-max) command + nil log-buffer t))) + (set-buffer log-buffer) + (mh-handle-process-error command value)) + (insert "\n(mh-store finished)\n"))) + + + +;;; Help Functions + +(defun mh-ephem-message (string) + "Display STRING in the minibuffer momentarily." + (message "%s" string) + (sit-for 5) + (message "")) + +;;;###mh-autoload +(defun mh-help () + "Display cheat sheet for the MH-Folder commands in minibuffer." + (interactive) + (mh-ephem-message + (substitute-command-keys + (mapconcat 'identity (cdr (assoc nil mh-help-messages)) "")))) + +;;;###mh-autoload +(defun mh-prefix-help () + "Display cheat sheet for the commands of the current prefix in minibuffer." + (interactive) + ;; We got here because the user pressed a `?', but he pressed a prefix key + ;; before that. Since the the key vector starts at index 0, the index of the + ;; last keystroke is length-1 and thus the second to last keystroke is at + ;; length-2. We use that information to obtain a suitable prefix character + ;; from the recent keys. + (let* ((keys (recent-keys)) + (prefix-char (elt keys (- (length keys) 2)))) + (mh-ephem-message + (substitute-command-keys + (mapconcat 'identity (cdr (assoc prefix-char mh-help-messages)) ""))))) + +(provide 'mh-funcs) + +;;; Local Variables: +;;; indent-tabs-mode: nil +;;; sentence-end-double-space: nil +;;; End: + +;;; mh-funcs.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mh-e/mh-identity.el Sun Jan 26 02:38:37 2003 +0000 @@ -0,0 +1,219 @@ +;;; mh-identity.el --- Multiple Identify support for MH-E. + +;; Copyright (C) 2002 Free Software Foundation, Inc. + +;; Author: Peter S. Galbraith <psg@debian.org> +;; Maintainer: Bill Wohler <wohler@newt.com> +;; Keywords: mail +;; See: mh-e.el + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Multiple identity support for MH-E. +;; +;; Used to easily set different fields such as From and Organization, as +;; well as different signature files. +;; +;; Customize the variable `mh-identity-list' and an Identity menu will +;; appear in mh-letter-mode. The command 'mh-insert-identity can be used +;; from the command line. + +;;; Change Log: + +;; $Id: mh-identity.el,v 1.1 2003/01/08 23:21:16 wohler Exp $ + +;;; Code: + + +(require 'cl) + +(eval-when (compile load eval) + (defvar mh-comp-loaded nil) + (unless mh-comp-loaded + (setq mh-comp-loaded t) + (require 'mh-comp))) ;Since we do this on sending + +(autoload 'mml-insert-tag "mml") + +;;;###mh-autoload +(defun mh-identity-make-menu () + "Build (or rebuild) the Identity menu (e.g. after the list is modified)." + (when (and mh-identity-list (boundp 'mh-letter-mode-map)) + (easy-menu-define mh-identity-menu mh-letter-mode-map + "mh-e identity menu" + (append + '("Identity") + ;; Dynamically render :type corresponding to `mh-identity-list' + ;; e.g.: + ;; ["home" (mh-insert-identity "home") + ;; :style radio :active (not (equal mh-identity-local "home")) + ;; :selected (equal mh-identity-local "home")] + (mapcar (function + (lambda (arg) + `[,arg (mh-insert-identity ,arg) :style radio + :active (not (equal mh-identity-local ,arg)) + :selected (equal mh-identity-local ,arg)])) + (mapcar 'car mh-identity-list)) + '("--" + ["none" (mh-insert-identity "none") mh-identity-local] + ["Set Default for Session" + (setq mh-identity-default mh-identity-local) t] + ["Save as Default" + (customize-save-variable + 'mh-identity-default mh-identity-local) t] + ))))) + +;;;###mh-autoload +(defun mh-identity-list-set (symbol value) + "Update the `mh-identity-list' variable, and rebuild the menu. +Sets the default for SYMBOL (e.g. `mh-identity-list') to VALUE (as set in +customization). This is called after 'customize is used to alter +`mh-identity-list'." + (set-default symbol value) + (mh-identity-make-menu)) + +(defvar mh-identity-local nil + "Buffer-local variable holding the identity currently in use.") +(make-variable-buffer-local 'mh-identity-local) + +(defun mh-header-field-delete (field value-only) + "Delete FIELD in the mail header, or only its value if VALUE-ONLY is t. +Return t if anything is deleted." + (when (mh-goto-header-field field) + (if (not value-only) + (beginning-of-line) + (forward-char)) + (delete-region (point) + (progn (mh-header-field-end) + (if (not value-only) (forward-char 1)) + (point))) + t)) + +(defvar mh-identity-signature-start nil + "Marker for the beginning of a signature inserted by `mh-insert-identity'.") +(defvar mh-identity-signature-end nil + "Marker for the end of a signature inserted by `mh-insert-identity'.") + +;;;###mh-autoload +(defun mh-insert-identity (identity) + "Insert proper fields for given IDENTITY. +Edit the `mh-identity-list' variable to define identity." + (interactive + (list (completing-read + "Identity: " + (if mh-identity-local + (cons '("none") + (mapcar 'list (mapcar 'car mh-identity-list))) + (mapcar 'list (mapcar 'car mh-identity-list))) + nil t))) + (save-excursion + ;;First remove old settings, if any. + (when mh-identity-local + (let ((pers-list (cadr (assoc mh-identity-local mh-identity-list)))) + (while pers-list + (let ((field (concat (caar pers-list) ":"))) + (cond + ((string-equal "signature:" field) + (when (and (boundp 'mh-identity-signature-start) + (markerp mh-identity-signature-start)) + (goto-char mh-identity-signature-start) + (forward-char -1) + (delete-region (point) mh-identity-signature-end))) + ((mh-header-field-delete field nil)))) + (setq pers-list (cdr pers-list))))) + ;; Then insert the replacement + (when (not (equal "none" identity)) + (let ((pers-list (cadr (assoc identity mh-identity-list)))) + (while pers-list + (let ((field (concat (caar pers-list) ":")) + (value (cdar pers-list))) + (cond + ;; No value, remove field + ((or (not value) + (string= value "")) + (mh-header-field-delete field nil)) + ;; Existing field, replace + ((mh-header-field-delete field t) + (insert value)) + ;; Handle "signature" special case. Insert file or call function. + ((and (string-equal "signature:" field) + (or (and (stringp value) + (file-readable-p value)) + (fboundp value))) + (goto-char (point-max)) + (if (not (looking-at "^$")) + (insert "\n")) + (insert "\n") + (save-restriction + (narrow-to-region (point) (point)) + (set (make-local-variable 'mh-identity-signature-start) + (make-marker)) + (set-marker mh-identity-signature-start (point)) + (cond + ;; If MIME composition done, insert signature at the end as + ;; an inline MIME part. + ((and (boundp 'mh-mhn-compose-insert-flag) + mh-mhn-compose-insert-flag) + (insert "#\n" "Content-Description: Signature\n")) + ((and (boundp 'mh-mml-compose-insert-flag) + mh-mml-compose-insert-flag) + (mml-insert-tag 'part 'type "text/plain" + 'disposition "inline" + 'description "Signature"))) + (if (stringp value) + (insert-file-contents value) + (funcall value)) + (goto-char (point-min)) + (when (not (re-search-forward "^--" nil t)) + (if (and (boundp 'mh-mhn-compose-insert-flag) + mh-mhn-compose-insert-flag) + (forward-line 2)) + (if (and (boundp 'mh-mml-compose-insert-flag) + mh-mml-compose-insert-flag) + (forward-line 1)) + (insert "-- \n")) + (set (make-local-variable 'mh-identity-signature-end) + (make-marker)) + (set-marker mh-identity-signature-end (point-max)))) + ;; Handle "From" field differently, adding it at the beginning. + ((string-equal "From:" field) + (goto-char (point-min)) + (insert "From: " value "\n")) + ;; Skip empty signature (Can't remove what we don't know) + ((string-equal "signature:" field)) + ;; Other field, add at end + (t ;Otherwise, add the end. + (goto-char (point-min)) + (mh-goto-header-end 0) + (mh-insert-fields field value)))) + (setq pers-list (cdr pers-list)))))) + ;; Remember what is in use in this buffer + (if (equal "none" identity) + (setq mh-identity-local nil) + (setq mh-identity-local identity))) + +(provide 'mh-identity) + +;;; Local Variables: +;;; indent-tabs-mode: nil +;;; sentence-end-double-space: nil +;;; End: + +;;; mh-identity.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mh-e/mh-index.el Sun Jan 26 02:38:37 2003 +0000 @@ -0,0 +1,948 @@ +;;; mh-index -- MH-E interface to indexing programs + +;; Copyright (C) 2002 Free Software Foundation, Inc. + +;; Author: Satyaki Das <satyaki@theforce.stanford.edu> +;; Maintainer: Bill Wohler <wohler@newt.com> +;; Keywords: mail +;; See: mh-e.el + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; (1) The following search engines are supported: +;;; swish++ +;;; swish-e +;;; namazu +;;; glimpse +;;; grep +;;; +;;; (2) To use this package, you first have to build an index. Please read +;;; the documentation for `mh-index-search' to get started. That +;;; documentation will direct you to the specific instructions for your +;;; particular indexer. + +;;; Change Log: + +;; $Id: mh-index.el,v 1.2 2003/01/08 23:21:16 wohler Exp $ + +;;; Code: + +(require 'cl) +(require 'mh-e) +(require 'mh-mime) + +(autoload 'gnus-local-map-property "gnus-util") +(autoload 'gnus-eval-format "gnus-spec") +(autoload 'widget-convert-button "wid-edit") +(autoload 'executable-find "executable") + +;; Support different indexing programs +(defvar mh-indexer-choices + '((swish++ + mh-swish++-binary mh-swish++-execute-search mh-swish++-next-result) + (swish + mh-swish-binary mh-swish-execute-search mh-swish-next-result) + (namazu + mh-namazu-binary mh-namazu-execute-search mh-namazu-next-result) + (glimpse + mh-glimpse-binary mh-glimpse-execute-search mh-glimpse-next-result) + (grep + mh-grep-binary mh-grep-execute-search mh-grep-next-result)) + "List of possible indexer choices.") +(defvar mh-indexer nil + "Chosen index program.") +(defvar mh-index-execute-search-function nil + "Function which executes the search program.") +(defvar mh-index-next-result-function nil + "Function to parse the next line of output.") + +;; FIXME: This should be a defcustom... +(defvar mh-index-folder "+mhe-index" + "Folder that contains the folders resulting from the index searches.") + +;; Temporary buffers for search results +(defvar mh-index-temp-buffer " *mh-index-temp*") +(defvar mh-checksum-buffer " *mh-checksum-buffer*") + + + +;;; A few different checksum programs are supported. The supported programs +;;; are: +;;; 1. md5sum +;;; 2. md5 +;;; 3. openssl +;;; +;;; To add support for your favorite checksum program add a clause to the cond +;;; statement in mh-checksum-choose. This should set the variable +;;; mh-checksum-cmd to the command line needed to run the checsum program and +;;; should set mh-checksum-parser to a function which returns a cons cell +;;; containing the message number and checksum string. + +(defvar mh-checksum-cmd) +(defvar mh-checksum-parser) + +(defun mh-checksum-choose () + "Check if a program to create a checksum is present." + (unless (boundp 'mh-checksum-cmd) + (let ((exec-path (append '("/sbin" "/usr/sbin") exec-path))) + (cond ((executable-find "md5sum") + (setq mh-checksum-cmd (list (executable-find "md5sum"))) + (setq mh-checksum-parser #'mh-md5sum-parser)) + ((executable-find "openssl") + (setq mh-checksum-cmd (list (executable-find "openssl") "md5")) + (setq mh-checksum-parser #'mh-openssl-parser)) + ((executable-find "md5") + (setq mh-checksum-cmd (list (executable-find "md5"))) + (setq mh-checksum-parser #'mh-md5-parser)) + (t (error "No suitable checksum program")))))) + +(defun mh-md5sum-parser () + "Parse md5sum output." + (let ((begin (line-beginning-position)) + (end (line-end-position)) + first-space last-slash) + (setq first-space (search-forward " " end t)) + (goto-char end) + (setq last-slash (search-backward "/" begin t)) + (cond ((and first-space last-slash) + (cons (car (read-from-string (buffer-substring-no-properties + (1+ last-slash) end))) + (buffer-substring-no-properties begin (1- first-space)))) + (t (cons nil nil))))) + +(defun mh-openssl-parser () + "Parse openssl output." + (let ((begin (line-beginning-position)) + (end (line-end-position)) + last-space last-slash) + (goto-char end) + (setq last-space (search-backward " " begin t)) + (setq last-slash (search-backward "/" begin t)) + (cond ((and last-slash last-space) + (cons (car (read-from-string (buffer-substring-no-properties + (1+ last-slash) (1- last-space)))) + (buffer-substring-no-properties (1+ last-space) end)))))) + +(defalias 'mh-md5-parser 'mh-openssl-parser) + + + +;;; Make sure that we don't produce too long a command line. + +(defvar mh-index-max-cmdline-args 500 + "Maximum number of command line args.") + +(defun mh-index-execute (cmd &rest args) + "Partial imitation of xargs. +The current buffer contains a list of strings, one on each line. The function +will execute CMD with ARGS and pass the first `mh-index-max-cmdline-args' +strings to it. This is repeated till all the strings have been used." + (goto-char (point-min)) + (let ((out (get-buffer-create " *mh-xargs-output*"))) + (save-excursion + (set-buffer out) + (erase-buffer)) + (while (not (eobp)) + (let ((arg-list (reverse args)) + (count 0)) + (while (and (not (eobp)) (< count mh-index-max-cmdline-args)) + (push (buffer-substring-no-properties (point) (line-end-position)) + arg-list) + (incf count) + (forward-line)) + (apply #'call-process cmd nil (list out nil) nil (nreverse arg-list)))) + (erase-buffer) + (insert-buffer-substring out))) + + + +(defun mh-index-update-single-msg (msg checksum origin-map) + "Update various maps for one message. +MSG is a index folder message, CHECKSUM its MD5 hash and ORIGIN-MAP, if +non-nil, a hashtable containing which maps each message in the index folder to +the folder and message that it was copied from. The function updates the hash +tables `mh-index-msg-checksum-map' and `mh-index-checksum-origin-map'. + +This function should only be called in the appropriate index folder buffer." + (cond ((and origin-map (gethash checksum mh-index-checksum-origin-map)) + (let* ((intermediate (gethash msg origin-map)) + (ofolder (car intermediate)) + (omsg (cdr intermediate))) + ;; This is most probably a duplicate. So eliminate it. + (call-process "rm" nil nil nil + (format "%s%s/%s" mh-user-path + (substring mh-current-folder 1) msg)) + (remhash omsg (gethash ofolder mh-index-data)))) + (t + (setf (gethash msg mh-index-msg-checksum-map) checksum) + (when origin-map + (setf (gethash checksum mh-index-checksum-origin-map) + (gethash msg origin-map)))))) + +;;;###mh-autoload +(defun mh-index-update-maps (folder &optional origin-map) + "Annotate all as yet unannotated messages in FOLDER with their MD5 hash. +As a side effect msg -> checksum map is updated. Optional argument ORIGIN-MAP +is a hashtable which maps each message in the index folder to the original +folder and message from whence it was copied. If present the +checksum -> (origin-folder, origin-index) map is updated too." + (clrhash mh-index-msg-checksum-map) + (save-excursion + ;; Clear temp buffer + (set-buffer (get-buffer-create mh-checksum-buffer)) + (erase-buffer) + ;; Run scan to check if any messages needs MD5 annotations at all + (with-temp-buffer + (mh-exec-cmd-output mh-scan-prog nil "-width" "80" + "-format" "%(msg)\n%{x-mhe-checksum}\n" + folder "all") + (goto-char (point-min)) + (let (msg checksum) + (while (not (eobp)) + (setq msg (buffer-substring-no-properties + (point) (line-end-position))) + (forward-line) + (save-excursion + (cond ((eolp) + ;; need to compute checksum + (set-buffer mh-checksum-buffer) + (insert mh-user-path (substring folder 1) "/" msg "\n")) + (t + ;; update maps + (setq checksum (buffer-substring-no-properties + (point) (line-end-position))) + (let ((msg (car (read-from-string msg)))) + (set-buffer folder) + (mh-index-update-single-msg msg checksum origin-map))))) + (forward-line)))) + ;; Run checksum program if needed + (unless (and (eobp) (bobp)) + (apply #'mh-index-execute mh-checksum-cmd) + (goto-char (point-min)) + (while (not (eobp)) + (let* ((intermediate (funcall mh-checksum-parser)) + (msg (car intermediate)) + (checksum (cdr intermediate))) + (when msg + ;; annotate + (mh-exec-cmd "anno" folder msg "-component" "X-MHE-Checksum" + "-nodate" "-text" checksum "-inplace") + ;; update maps + (save-excursion + (set-buffer folder) + (mh-index-update-single-msg msg checksum origin-map))) + (forward-line)))))) + +(defun mh-index-generate-pretty-name (string) + "Given STRING generate a name which is suitable for use as a folder name. +White space from the beginning and end are removed. All spaces in the name are +replaced with underscores and all / are replaced with $. If STRING is longer +than 20 it is truncated too." + (with-temp-buffer + (insert string) + (goto-char (point-min)) + (while (and (not (eobp)) (memq (char-after) '(? ?\t ?\n ?\r))) + (delete-char 1)) + (goto-char (point-max)) + (while (and (not (bobp)) (memq (char-before) '(? ?\t ?\n ?\r))) + (delete-backward-char 1)) + (subst-char-in-region (point-min) (point-max) ? ?_ t) + (subst-char-in-region (point-min) (point-max) ?\t ?_ t) + (subst-char-in-region (point-min) (point-max) ?\n ?_ t) + (subst-char-in-region (point-min) (point-max) ?\r ?_ t) + (subst-char-in-region (point-min) (point-max) ?/ ?$ t) + (truncate-string-to-width (buffer-substring (point-min) (point-max)) 20))) + +;;;###mh-autoload +(defun mh-index-search (redo-search-flag folder search-regexp) + "Perform an indexed search in an MH mail folder. + +If REDO-SEARCH-FLAG is non-nil and the current folder buffer was generated by a +index search, then the search is repeated. Otherwise, FOLDER is searched with +SEARCH-REGEXP and the results are presented in an MH-E folder. If FOLDER is +\"+\" then mail in all folders are searched. + +Four indexing programs are supported; if none of these are present, then grep +is used. This function picks the first program that is available on your +system. If you would prefer to use a different program, set the customization +variable `mh-index-program' accordingly. + +The documentation for the following functions describes how to generate the +index for each program: + + - `mh-swish++-execute-search' + - `mh-swish-execute-search' + - `mh-namazu-execute-search' + - `mh-glimpse-execute-search' + +This and related functions use an X-MHE-Checksum header to cache the MD5 +checksum of a message. This means that already present X-MHE-Checksum headers +in the incoming email could result in messages not being found. The following +procmail recipe should avoid this: + + :0 wf + | formail -R \"X-MHE-Checksum\" \"Old-X-MHE-Checksum\" + +This has the effect of renaming already present X-MHE-Checksum headers." + (interactive + (list current-prefix-arg + (progn + (unless mh-find-path-run (mh-find-path)) + (or (and current-prefix-arg (car mh-index-previous-search)) + (mh-prompt-for-folder "Search" "+" nil "all"))) + (progn + ;; Yes, we do want to call mh-index-choose every time in case the + ;; user has switched the indexer manually. + (unless (mh-index-choose) (error "No indexing program found")) + (or (and current-prefix-arg (cadr mh-index-previous-search)) + (read-string (format "%s regexp: " + (upcase-initials + (symbol-name mh-indexer)))))))) + (mh-checksum-choose) + (let ((result-count 0) + (old-window-config mh-previous-window-config) + (previous-search mh-index-previous-search) + (index-folder (format "%s/%s" mh-index-folder + (mh-index-generate-pretty-name search-regexp)))) + ;; Create a new folder for the search results or recreate the old one... + (if (and redo-search-flag mh-index-previous-search) + (let ((buffer-name (buffer-name (current-buffer)))) + (mh-process-or-undo-commands buffer-name) + (save-excursion (mh-exec-cmd-quiet nil "rmf" buffer-name)) + (mh-exec-cmd-quiet nil "folder" "-create" "-fast" buffer-name) + (setq index-folder buffer-name)) + (setq index-folder (mh-index-new-folder index-folder))) + + (let ((folder-path (format "%s%s" mh-user-path (substring folder 1))) + (folder-results-map (make-hash-table :test #'equal)) + (origin-map (make-hash-table :test #'equal))) + ;; Run search program... + (message "Executing %s... " mh-indexer) + (funcall mh-index-execute-search-function folder-path search-regexp) + + ;; Parse indexer output + (message "Processing %s output... " mh-indexer) + (goto-char (point-min)) + (loop for next-result = (funcall mh-index-next-result-function) + when (null next-result) return nil + do (unless (eq next-result 'error) + (unless (gethash (car next-result) folder-results-map) + (setf (gethash (car next-result) folder-results-map) + (make-hash-table :test #'equal))) + (setf (gethash (cadr next-result) + (gethash (car next-result) folder-results-map)) + t))) + + ;; Copy the search results over + (maphash #'(lambda (folder msgs) + (let ((msgs (sort (loop for msg being the hash-keys of msgs + collect msg) + #'<))) + (mh-exec-cmd "refile" msgs "-src" folder + "-link" index-folder) + (loop for msg in msgs + do (incf result-count) + (setf (gethash result-count origin-map) + (cons folder msg))))) + folder-results-map) + + ;; Generate scan lines for the hits. + (let ((mh-show-threads-flag nil)) + (mh-visit-folder index-folder () (list folder-results-map origin-map))) + + (goto-char (point-min)) + (forward-line) + (mh-update-sequences) + (mh-recenter nil) + + ;; Maintain history + (when (and redo-search-flag previous-search) + (setq mh-previous-window-config old-window-config)) + (setq mh-index-previous-search (list folder search-regexp)) + + (message "%s found %s matches in %s folders" + (upcase-initials (symbol-name mh-indexer)) + (loop for msg-hash being hash-values of mh-index-data + sum (hash-table-count msg-hash)) + (loop for msg-hash being hash-values of mh-index-data + count (> (hash-table-count msg-hash) 0)))))) + +;;;###mh-autoload +(defun mh-index-next-folder (&optional backward-flag) + "Jump to the next folder marker. +The function is only applicable to folders displaying index search results. +With non-nil optional argument BACKWARD-FLAG, jump to the previous group of +results." + (interactive "P") + (if (or (null mh-index-data) + (memq 'unthread mh-view-ops)) + (message "Only applicable in an unthreaded MH-E index search buffer") + (let ((point (point))) + (forward-line (if backward-flag -1 1)) + (cond ((if backward-flag + (re-search-backward "^+" (point-min) t) + (re-search-forward "^+" (point-max) t)) + (beginning-of-line)) + ((and (if backward-flag + (goto-char (point-max)) + (goto-char (point-min))) + nil)) + ((if backward-flag + (re-search-backward "^+" (point-min) t) + (re-search-forward "^+" (point-max) t)) + (beginning-of-line)) + (t (goto-char point)))))) + +;;;###mh-autoload +(defun mh-index-previous-folder () + "Jump to the previous folder marker." + (interactive) + (mh-index-next-folder t)) + +(defun mh-folder-exists-p (folder) + "Check if FOLDER exists." + (and (mh-folder-name-p folder) + (save-excursion + (with-temp-buffer + (mh-exec-cmd-output "folder" nil "-fast" "-nocreate" folder) + (goto-char (point-min)) + (not (eobp)))))) + +(defun mh-msg-exists-p (msg folder) + "Check if MSG exists in FOLDER." + (file-exists-p (format "%s%s/%s" mh-user-path (substring folder 1) msg))) + +(defun mh-index-new-folder (name) + "Create and return an MH folder name based on NAME. +If the folder NAME already exists then check if NAME<2> exists. If it doesn't +then it is created and returned. Otherwise try NAME<3>. This is repeated till +we find a new folder name." + (unless (mh-folder-name-p name) + (error "The argument should be a valid MH folder name")) + (let ((chosen-name name)) + (block unique-name + (unless (mh-folder-exists-p name) + (return-from unique-name)) + (loop for index from 2 + do (let ((new-name (format "%s<%s>" name index))) + (unless (mh-folder-exists-p new-name) + (setq chosen-name new-name) + (return-from unique-name))))) + (mh-exec-cmd-quiet nil "folder" "-create" "-fast" chosen-name) + (when (boundp 'mh-speed-folder-map) + (mh-speed-add-folder chosen-name)) + (push (list chosen-name) mh-folder-list) + chosen-name)) + +;;;###mh-autoload +(defun mh-index-insert-folder-headers () + "Annotate the search results with original folder names." + (let ((cur-msg (mh-get-msg-num nil)) + (old-buffer-modified-flag (buffer-modified-p)) + (buffer-read-only nil) + current-folder last-folder) + (goto-char (point-min)) + (while (not (eobp)) + (setq current-folder (car (gethash (gethash (mh-get-msg-num nil) + mh-index-msg-checksum-map) + mh-index-checksum-origin-map))) + (when (and current-folder (not (eq current-folder last-folder))) + (insert (if last-folder "\n" "") current-folder "\n") + (setq last-folder current-folder)) + (forward-line)) + (when cur-msg (mh-goto-msg cur-msg t)) + (set-buffer-modified-p old-buffer-modified-flag))) + +;;;###mh-autoload +(defun mh-index-delete-folder-headers () + "Delete the folder headers." + (let ((cur-msg (mh-get-msg-num nil)) + (old-buffer-modified-flag (buffer-modified-p)) + (buffer-read-only nil)) + (goto-char (point-min)) + (while (not (eobp)) + (if (or (char-equal (char-after) ?+) (char-equal (char-after) 10)) + (delete-region (point) (progn (forward-line) (point))) + (forward-line))) + (when cur-msg (mh-goto-msg cur-msg t t)) + (set-buffer-modified-p old-buffer-modified-flag))) + +;;;###mh-autoload +(defun mh-index-visit-folder () + "Visit original folder from where the message at point was found." + (interactive) + (unless mh-index-data + (error "Not in an index folder")) + (let (folder msg) + (save-excursion + (cond ((and (bolp) (eolp)) + (ignore-errors (forward-line -1)) + (setq msg (mh-get-msg-num t))) + ((equal (char-after (line-beginning-position)) ?+) + (setq folder (buffer-substring-no-properties + (line-beginning-position) (line-end-position)))) + (t (setq msg (mh-get-msg-num t))))) + (when (not folder) + (setq folder (car (gethash (gethash msg mh-index-msg-checksum-map) + mh-index-checksum-origin-map)))) + (mh-visit-folder + folder (loop for x being the hash-keys of (gethash folder mh-index-data) + when (mh-msg-exists-p x folder) collect x)))) + +(defun mh-index-match-checksum (msg folder checksum) + "Check if MSG in FOLDER has X-MHE-Checksum header value of CHECKSUM." + (with-temp-buffer + (mh-exec-cmd-output mh-scan-prog nil "-width" "80" + "-format" "%{x-mhe-checksum}\n" folder msg) + (goto-char (point-min)) + (string-equal (buffer-substring-no-properties (point) (line-end-position)) + checksum))) + +;;;###mh-autoload +(defun mh-index-execute-commands () + "Delete/refile the actual messages. +The copies in the searched folder are then deleted/refiled to get the desired +result. Before deleting the messages we make sure that the message being +deleted is identical to the one that the user has marked in the index buffer." + (let ((message-table (make-hash-table :test #'equal))) + (dolist (msg-list (cons mh-delete-list (mapcar #'cdr mh-refile-list))) + (dolist (msg msg-list) + (let* ((checksum (gethash msg mh-index-msg-checksum-map)) + (pair (gethash checksum mh-index-checksum-origin-map))) + (when (and checksum (car pair) (cdr pair) + (mh-index-match-checksum (cdr pair) (car pair) checksum)) + (push (cdr pair) (gethash (car pair) message-table)) + (remhash (cdr pair) (gethash (car pair) mh-index-data)))))) + (maphash (lambda (folder msgs) + (apply #'mh-exec-cmd "rmm" folder (mh-coalesce-msg-list msgs))) + message-table))) + + + +;; Glimpse interface + +(defvar mh-glimpse-binary (executable-find "glimpse")) +(defvar mh-glimpse-directory ".glimpse") + +;;;###mh-autoload +(defun mh-glimpse-execute-search (folder-path search-regexp) + "Execute glimpse and read the results. + +In the examples below, replace /home/user/Mail with the path to your MH +directory. + +First create the directory /home/user/Mail/.glimpse. Then create the file +/home/user/Mail/.glimpse/.glimpse_exclude with the following contents: + + */.* + */#* + */,* + */*~ + ^/home/user/Mail/.glimpse + ^/home/user/Mail/mhe-index + +If there are any directories you would like to ignore, append lines like the +following to .glimpse_exclude: + + ^/home/user/Mail/scripts + +You do not want to index the folders that hold the results of your searches +since they tend to be ephemeral and the original messages are indexed anyway. +The configuration file above assumes that the results are found in sub-folders +of `mh-index-folder' which is +mhe-index by default. + +Use the following command line to generate the glimpse index. Run this +daily from cron: + + glimpseindex -H /home/user/Mail/.glimpse /home/user/Mail + +FOLDER-PATH is the directory in which SEARCH-REGEXP is used to search." + (set-buffer (get-buffer-create mh-index-temp-buffer)) + (erase-buffer) + (call-process mh-glimpse-binary nil '(t nil) nil + ;(format "-%s" fuzz) + "-i" "-y" + "-H" (format "%s%s" mh-user-path mh-glimpse-directory) + "-F" (format "^%s" folder-path) + search-regexp) + (goto-char (point-min))) + +(defun mh-glimpse-next-result () + "Read the next result. +Parse it and return the message folder, message index and the match. If no +other matches left then return nil. If the current record is invalid return +'error." + (prog1 + (block nil + (when (eobp) + (return nil)) + (let ((eol-pos (line-end-position)) + (bol-pos (line-beginning-position)) + folder-start msg-end) + (goto-char bol-pos) + (unless (search-forward mh-user-path eol-pos t) + (return 'error)) + (setq folder-start (point)) + (unless (search-forward ": " eol-pos t) + (return 'error)) + (let ((match (buffer-substring-no-properties (point) eol-pos))) + (forward-char -2) + (setq msg-end (point)) + (unless (search-backward "/" folder-start t) + (return 'error)) + (list (format "+%s" (buffer-substring-no-properties + folder-start (point))) + (let ((val (ignore-errors (read-from-string + (buffer-substring-no-properties + (1+ (point)) msg-end))))) + (if (and (consp val) (integerp (car val))) + (car val) + (return 'error))) + match)))) + (forward-line))) + + + +;; Grep interface + +(defvar mh-grep-binary (executable-find "grep")) + +(defun mh-grep-execute-search (folder-path search-regexp) + "Execute grep and read the results. +FOLDER-PATH is the directory in which SEARCH-REGEXP is used to search." + (set-buffer (get-buffer-create mh-index-temp-buffer)) + (erase-buffer) + (call-process mh-grep-binary nil '(t nil) nil + "-i" "-r" search-regexp folder-path) + (goto-char (point-min))) + +(defun mh-grep-next-result () + "Read the next result. +Parse it and return the message folder, message index and the match. If no +other matches left then return nil. If the current record is invalid return +'error." + (prog1 + (block nil + (when (eobp) + (return nil)) + (let ((eol-pos (line-end-position)) + (bol-pos (line-beginning-position)) + folder-start msg-end) + (goto-char bol-pos) + (unless (search-forward mh-user-path eol-pos t) + (return 'error)) + (setq folder-start (point)) + (unless (search-forward ":" eol-pos t) + (return 'error)) + (let ((match (buffer-substring-no-properties (point) eol-pos))) + (forward-char -1) + (setq msg-end (point)) + (unless (search-backward "/" folder-start t) + (return 'error)) + (list (format "+%s" (buffer-substring-no-properties + folder-start (point))) + (let ((val (ignore-errors (read-from-string + (buffer-substring-no-properties + (1+ (point)) msg-end))))) + (if (and (consp val) (integerp (car val))) + (car val) + (return 'error))) + match)))) + (forward-line))) + + + +;; Swish interface + +(defvar mh-swish-binary (executable-find "swish-e")) +(defvar mh-swish-directory ".swish") +(defvar mh-swish-folder nil) + +;;;###mh-autoload +(defun mh-swish-execute-search (folder-path search-regexp) + "Execute swish-e and read the results. + +In the examples below, replace /home/user/Mail with the path to your MH +directory. + +First create the directory /home/user/Mail/.swish. Then create the file +/home/user/Mail/.swish/config with the following contents: + + IndexDir /home/user/Mail + IndexFile /home/user/Mail/.swish/index + IndexName \"Mail Index\" + IndexDescription \"Mail Index\" + IndexPointer \"http://nowhere\" + IndexAdmin \"nobody\" + #MetaNames automatic + IndexReport 3 + FollowSymLinks no + UseStemming no + IgnoreTotalWordCountWhenRanking yes + WordCharacters abcdefghijklmnopqrstuvwxyz0123456789- + BeginCharacters abcdefghijklmnopqrstuvwxyz + EndCharacters abcdefghijklmnopqrstuvwxyz0123456789 + IgnoreLimit 50 1000 + IndexComments 0 + FileRules pathname contains /home/user/Mail/.swish + FileRules pathname contains /home/user/Mail/mhe-index + FileRules filename is index + FileRules filename is \..* + FileRules filename is #.* + FileRules filename is ,.* + FileRules filename is .*~ + +If there are any directories you would like to ignore, append lines like the +following to config: + + FileRules pathname contains /home/user/Mail/scripts + +You do not want to index the folders that hold the results of your searches +since they tend to be ephemeral and the original messages are indexed anyway. +The configuration file above assumes that the results are found in sub-folders +of `mh-index-folder' which is +mhe-index by default. + +Use the following command line to generate the swish index. Run this +daily from cron: + + swish-e -c /home/user/Mail/.swish/config + +FOLDER-PATH is the directory in which SEARCH-REGEXP is used to search." + (set-buffer (get-buffer-create mh-index-temp-buffer)) + (erase-buffer) + (unless mh-swish-binary + (error "Set mh-swish-binary appropriately")) + (call-process mh-swish-binary nil '(t nil) nil + "-w" search-regexp + "-f" (format "%s%s/index" mh-user-path mh-swish-directory)) + (goto-char (point-min)) + (setq mh-swish-folder + (let ((last-char (substring folder-path (1- (length folder-path))))) + (if (equal last-char "/") + folder-path + (format "%s/" folder-path))))) + +(defun mh-swish-next-result () + "Get the next result from swish output." + (prog1 + (block nil + (when (or (eobp) (equal (char-after (point)) ?.)) + (return nil)) + (when (equal (char-after (point)) ?#) + (return 'error)) + (let* ((start (search-forward " " (line-end-position) t)) + (end (search-forward " " (line-end-position) t))) + (unless (and start end) + (return 'error)) + (setq end (1- end)) + (unless (file-exists-p (buffer-substring-no-properties start end)) + (return 'error)) + (unless (search-backward "/" start t) + (return 'error)) + (list (let* ((s (buffer-substring-no-properties start (1+ (point))))) + (unless (string-match mh-swish-folder s) + (return 'error)) + (if (string-match mh-user-path s) + (format "+%s" + (substring s (match-end 0) (1- (length s)))) + (return 'error))) + (let* ((s (buffer-substring-no-properties (1+ (point)) end)) + (val (ignore-errors (read-from-string s)))) + (if (and (consp val) (numberp (car val))) + (car val) + (return 'error))) + nil))) + (forward-line))) + + + +;; Swish++ interface + +(defvar mh-swish++-binary (or (executable-find "search++") + (executable-find "search"))) +(defvar mh-swish++-directory ".swish++") + +;;;###mh-autoload +(defun mh-swish++-execute-search (folder-path search-regexp) + "Execute swish++ and read the results. + +In the examples below, replace /home/user/Mail with the path to your MH +directory. + +First create the directory /home/user/Mail/.swish++. Then create the file +/home/user/Mail/.swish++/swish++.conf with the following contents: + + IncludeMeta Bcc Cc Comments Content-Description From Keywords + IncludeMeta Newsgroups Resent-To Subject To + IncludeMeta Message-Id References In-Reply-To + IncludeFile Mail * + IndexFile /home/user/Mail/.swish++/swish++.index + +Use the following command line to generate the swish index. Run this +daily from cron: + + find /home/user/Mail -path /home/user/Mail/mhe-index -prune \\ + -o -path /home/user/Mail/.swish++ -prune \\ + -o -name \"[0-9]*\" -print \\ + | index -c /home/user/Mail/.swish++/swish++.conf /home/user/Mail + +You do not want to index the folders that hold the results of your searches +since they tend to be ephemeral and the original messages are indexed anyway. +The command above assumes that the results are found in sub-folders of +`mh-index-folder' which is +mhe-index by default. + +On some systems (Debian GNU/Linux, for example), use index++ instead of index. + +FOLDER-PATH is the directory in which SEARCH-REGEXP is used to search." + (set-buffer (get-buffer-create mh-index-temp-buffer)) + (erase-buffer) + (unless mh-swish++-binary + (error "Set mh-swish++-binary appropriately")) + (call-process mh-swish++-binary nil '(t nil) nil + "-m" "10000" + (format "-i%s%s/swish++.index" + mh-user-path mh-swish++-directory) + search-regexp) + (goto-char (point-min)) + (setq mh-swish-folder + (let ((last-char (substring folder-path (1- (length folder-path))))) + (if (equal last-char "/") + folder-path + (format "%s/" folder-path))))) + +(defalias 'mh-swish++-next-result 'mh-swish-next-result) + + + +;; Namazu interface + +(defvar mh-namazu-binary (executable-find "namazu")) +(defvar mh-namazu-directory ".namazu") +(defvar mh-namazu-folder nil) + +;;;###mh-autoload +(defun mh-namazu-execute-search (folder-path search-regexp) + "Execute namazu and read the results. + +In the examples below, replace /home/user/Mail with the path to your MH +directory. + +First create the directory /home/user/Mail/.namazu. Then create the file +/home/user/Mail/.namazu/mknmzrc with the following contents: + + package conf; # Don't remove this line! + $ADDRESS = 'user@localhost'; + $ALLOW_FILE = \"[0-9]*\"; + $EXCLUDE_PATH = \"^/home/user/Mail/(mhe-index|spam)\"; + +In the above example configuration, none of the mail files contained in the +directories /home/user/Mail/mhe-index and /home/user/Mail/spam are indexed. + +You do not want to index the folders that hold the results of your searches +since they tend to be ephemeral and the original messages are indexed anyway. +The configuration file above assumes that the results are found in sub-folders +of `mh-index-folder' which is +mhe-index by default. + +Use the following command line to generate the namazu index. Run this +daily from cron: + + mknmz -f /home/user/Mail/.namazu/mknmzrc -O /home/user/Mail/.namazu \\ + /home/user/Mail + +FOLDER-PATH is the directory in which SEARCH-REGEXP is used to search." + (let ((namazu-index-directory + (format "%s%s" mh-user-path mh-namazu-directory))) + (unless (file-exists-p namazu-index-directory) + (error "Namazu directory %s not present" namazu-index-directory)) + (unless (executable-find mh-namazu-binary) + (error "Set mh-namazu-binary appropriately")) + (set-buffer (get-buffer-create mh-index-temp-buffer)) + (erase-buffer) + (call-process mh-namazu-binary nil '(t nil) nil + "-alR" search-regexp namazu-index-directory) + (goto-char (point-min)) + (setq mh-namazu-folder + (let ((last (substring folder-path (1- (length folder-path))))) + (if (equal last "/") + folder-path + (format "%s/" folder-path)))))) + +(defun mh-namazu-next-result () + "Get the next result from namazu output." + (prog1 + (block nil + (when (eobp) (return nil)) + (let ((file-name (buffer-substring-no-properties + (point) (line-end-position)))) + (unless (equal (string-match mh-namazu-folder file-name) 0) + (return 'error)) + (unless (file-exists-p file-name) + (return 'error)) + (string-match mh-user-path file-name) + (let* ((folder/msg (substring file-name (match-end 0))) + (mark (mh-search-from-end ?/ folder/msg))) + (unless mark (return 'error)) + (list (format "+%s" (substring folder/msg 0 mark)) + (let ((n (ignore-errors (read-from-string + (substring folder/msg (1+ mark)))))) + (if (and (consp n) (numberp (car n))) + (car n) + (return 'error))) + nil)))) + (forward-line))) + + + +(defun mh-index-choose () + "Choose an indexing function. +The side-effects of this function are that the variables `mh-indexer', +`mh-index-execute-search-function', and `mh-index-next-result-function' are +set according to the first indexer in `mh-indexer-choices' present on the +system." + (block nil + ;; The following favors the user's preference; otherwise, the last + ;; automatically chosen indexer is used for efficiency rather than going + ;; through the list. + (let ((program-alist (cond (mh-index-program + (list + (assoc mh-index-program mh-indexer-choices))) + (mh-indexer + (list (assoc mh-indexer mh-indexer-choices))) + (t mh-indexer-choices)))) + (while program-alist + (let* ((current (pop program-alist)) + (executable (symbol-value (cadr current)))) + (when executable + (setq mh-indexer (car current)) + (setq mh-index-execute-search-function (caddr current)) + (setq mh-index-next-result-function (cadddr current)) + (return mh-indexer)))) + nil))) + + + +(provide 'mh-index) + +;;; Local Variables: +;;; indent-tabs-mode: nil +;;; sentence-end-double-space: nil +;;; End: + +;;; mh-index ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mh-e/mh-loaddefs.el Sun Jan 26 02:38:37 2003 +0000 @@ -0,0 +1,880 @@ +;;; mh-loaddefs.el --- automatically extracted autoloads +;; +;;; Commentary: +;;; Code: + +;;;### (autoloads (mh-letter-complete mh-open-line mh-fully-kill-draft +;;;;;; mh-yank-cur-msg mh-insert-letter mh-send-letter mh-check-whom +;;;;;; mh-insert-signature mh-to-fcc mh-to-field mh-fill-paragraph-function +;;;;;; mh-send-other-window mh-send mh-reply mh-redistribute mh-forward +;;;;;; mh-extract-rejected-mail mh-edit-again) "mh-comp" "mh-comp.el" +;;;;;; (15899 19356)) +;;; Generated autoloads from mh-comp.el + +(autoload (quote mh-edit-again) "mh-comp" "\ +Clean up a draft or a message MSG previously sent and make it resendable. +Default is the current message. +The variable `mh-new-draft-cleaned-headers' specifies the headers to remove. +See also documentation for `\\[mh-send]' function." t nil) + +(autoload (quote mh-extract-rejected-mail) "mh-comp" "\ +Extract message MSG returned by the mail system and make it resendable. +Default is the current message. The variable `mh-new-draft-cleaned-headers' +gives the headers to clean out of the original message. +See also documentation for `\\[mh-send]' function." t nil) + +(autoload (quote mh-forward) "mh-comp" "\ +Forward one or more messages to the recipients TO and CC. + +Use the optional MSG-OR-SEQ to specify a message or sequence to forward. + +Default is the displayed message. If optional prefix argument is given then +prompt for the message sequence. If variable `transient-mark-mode' is non-nil +and the mark is active, then the selected region is forwarded. +See also documentation for `\\[mh-send]' function." t nil) + +(autoload (quote mh-redistribute) "mh-comp" "\ +Redistribute displayed message to recipients TO and CC. +Use optional argument MSG to redistribute another message. +Depending on how your copy of MH was compiled, you may need to change the +setting of the variable `mh-redist-full-contents'. See its documentation." t nil) + +(autoload (quote mh-reply) "mh-comp" "\ +Reply to MESSAGE (default: current message). +If the optional argument REPLY-TO is not given, prompts for type of addresses +to reply to: + from sender only, + to sender and primary recipients, + cc/all sender and all recipients. +If optional prefix argument INCLUDEP provided, then include the message +in the reply using filter `mhl.reply' in your MH directory. +If the file named by `mh-repl-formfile' exists, it is used as a skeleton +for the reply. See also documentation for `\\[mh-send]' function." t nil) + +(autoload (quote mh-send) "mh-comp" "\ +Compose and send a letter. + +Do not call this function from outside MH-E; use \\[mh-smail] instead. + +The file named by `mh-comp-formfile' will be used as the form. +The letter is composed in `mh-letter-mode'; see its documentation for more +details. +If `mh-compose-letter-function' is defined, it is called on the draft and +passed three arguments: TO, CC, and SUBJECT." t nil) + +(autoload (quote mh-send-other-window) "mh-comp" "\ +Compose and send a letter in another window. + +Do not call this function from outside MH-E; use \\[mh-smail-other-window] +instead. + +The file named by `mh-comp-formfile' will be used as the form. +The letter is composed in `mh-letter-mode'; see its documentation for more +details. +If `mh-compose-letter-function' is defined, it is called on the draft and +passed three arguments: TO, CC, and SUBJECT." t nil) + +(autoload (quote mh-fill-paragraph-function) "mh-comp" "\ +Fill paragraph at or after point. +Prefix ARG means justify as well. This function enables `fill-paragraph' to +work better in MH-Letter mode." t nil) + +(autoload (quote mh-to-field) "mh-comp" "\ +Move point to the end of a specified header field. +The field is indicated by the previous keystroke (the last keystroke +of the command) according to the list in the variable `mh-to-field-choices'. +Create the field if it does not exist. Set the mark to point before moving." t nil) + +(autoload (quote mh-to-fcc) "mh-comp" "\ +Insert an Fcc: FOLDER field in the current message. +Prompt for the field name with a completion list of the current folders." t nil) + +(autoload (quote mh-insert-signature) "mh-comp" "\ +Insert the file named by `mh-signature-file-name' at point. +The value of `mh-letter-insert-signature-hook' is a list of functions to be +called, with no arguments, before the signature is actually inserted." t nil) + +(autoload (quote mh-check-whom) "mh-comp" "\ +Verify recipients of the current letter, showing expansion of any aliases." t nil) + +(autoload (quote mh-send-letter) "mh-comp" "\ +Send the draft letter in the current buffer. +If optional prefix argument ARG is provided, monitor delivery. +The value of `mh-before-send-letter-hook' is a list of functions to be called, +with no arguments, before doing anything. +Run `\\[mh-edit-mhn]' if variable `mh-mhn-compose-insert-flag' is set. +Run `\\[mh-mml-to-mime]' if variable `mh-mml-compose-insert-flag' is set. +Insert X-Mailer field if variable `mh-insert-x-mailer-flag' is set. +Insert X-Face field if the file specified by `mh-x-face-file' exists." t nil) + +(autoload (quote mh-insert-letter) "mh-comp" "\ +Insert a message into the current letter. +Removes the header fields according to the variable `mh-invisible-headers'. +Prefixes each non-blank line with `mh-ins-buf-prefix', unless +`mh-yank-from-start-of-msg' is set for supercite in which case supercite is +used to format the message. +Prompts for FOLDER and MESSAGE. If prefix argument VERBATIM provided, do +not indent and do not delete headers. Leaves the mark before the letter +and point after it." t nil) + +(autoload (quote mh-yank-cur-msg) "mh-comp" "\ +Insert the current message into the draft buffer. +Prefix each non-blank line in the message with the string in +`mh-ins-buf-prefix'. If a region is set in the message's buffer, then +only the region will be inserted. Otherwise, the entire message will +be inserted if `mh-yank-from-start-of-msg' is non-nil. If this variable +is nil, the portion of the message following the point will be yanked. +If `mh-delete-yanked-msg-window-flag' is non-nil, any window displaying the +yanked message will be deleted." t nil) + +(autoload (quote mh-fully-kill-draft) "mh-comp" "\ +Kill the draft message file and the draft message buffer. +Use \\[kill-buffer] if you don't want to delete the draft message file." t nil) + +(autoload (quote mh-open-line) "mh-comp" "\ +Insert a newline and leave point after it. +In addition, insert newline and quoting characters before text after point. +This is useful in breaking up paragraphs in replies." t nil) + +(autoload (quote mh-letter-complete) "mh-comp" "\ +Perform completion on header field or word preceding point. +Alias completion is done within the mail header on selected fields and +by the function designated by `mh-letter-complete-function' elsewhere, +passing the prefix ARG if any." t nil) + +;;;*** + +;;;### (autoloads (mh-tool-bar-folder-set mh-tool-bar-letter-set +;;;;;; mh-customize) "mh-customize" "mh-customize.el" (15899 29873)) +;;; Generated autoloads from mh-customize.el + +(autoload (quote mh-customize) "mh-customize" "\ +Customize MH-E variables." t nil) + +(autoload (quote mh-tool-bar-letter-set) "mh-customize" "\ +Construct toolbar for `mh-letter-mode'." nil nil) + +(autoload (quote mh-tool-bar-folder-set) "mh-customize" "\ +Construct toolbar for `mh-folder-mode'." nil nil) + +;;;*** + +;;;### (autoloads (mh-goto-cur-msg mh-update-sequences mh-folder-line-matches-show-buffer-p) +;;;;;; "mh-e" "mh-e.el" (15899 29921)) +;;; Generated autoloads from mh-e.el + +(autoload (quote mh-folder-line-matches-show-buffer-p) "mh-e" "\ +Return t if the message under point in folder-mode is in the show buffer. +Return nil in any other circumstance (no message under point, no show buffer, +the message in the show buffer doesn't match." nil nil) + +(autoload (quote mh-update-sequences) "mh-e" "\ +Update MH's Unseen-Sequence and current folder and message. +Flush MH-E's state out to MH. The message at the cursor becomes current." t nil) + +(autoload (quote mh-goto-cur-msg) "mh-e" "\ +Position the cursor at the current message. +When optional argument MINIMAL-CHANGES-FLAG is non-nil, the function doesn't +recenter the folder buffer." nil nil) + +;;;*** + +;;;### (autoloads (mh-prefix-help mh-help mh-store-buffer mh-store-msg +;;;;;; mh-undo-folder mh-sort-folder mh-print-msg mh-page-digest-backwards +;;;;;; mh-page-digest mh-pipe-msg mh-pack-folder mh-list-folders +;;;;;; mh-kill-folder mh-copy-msg mh-burst-digest) "mh-funcs" "mh-funcs.el" +;;;;;; (15886 19303)) +;;; Generated autoloads from mh-funcs.el + +(autoload (quote mh-burst-digest) "mh-funcs" "\ +Burst apart the current message, which should be a digest. +The message is replaced by its table of contents and the messages from the +digest are inserted into the folder after that message." t nil) + +(autoload (quote mh-copy-msg) "mh-funcs" "\ +Copy the specified MSG-OR-SEQ to another FOLDER without deleting them. +Default is the displayed message. If optional prefix argument is provided, +then prompt for the message sequence." t nil) + +(autoload (quote mh-kill-folder) "mh-funcs" "\ +Remove the current folder and all included messages. +Removes all of the messages (files) within the specified current folder, +and then removes the folder (directory) itself. +The value of `mh-folder-list-change-hook' is a list of functions to be called, +with no arguments, after the folders has been removed." t nil) + +(autoload (quote mh-list-folders) "mh-funcs" "\ +List mail folders." t nil) + +(autoload (quote mh-pack-folder) "mh-funcs" "\ +Renumber the messages of a folder to be 1..n. +First, offer to execute any outstanding commands for the current folder. If +optional prefix argument provided, prompt for the RANGE of messages to display +after packing. Otherwise, show the entire folder." t nil) + +(autoload (quote mh-pipe-msg) "mh-funcs" "\ +Pipe the current message through the given shell COMMAND. +If INCLUDE-HEADERS (prefix argument) is provided, send the entire message. +Otherwise just send the message's body without the headers." t nil) + +(autoload (quote mh-page-digest) "mh-funcs" "\ +Advance displayed message to next digested message." t nil) + +(autoload (quote mh-page-digest-backwards) "mh-funcs" "\ +Back up displayed message to previous digested message." t nil) + +(autoload (quote mh-print-msg) "mh-funcs" "\ +Print MSG-OR-SEQ (default: displayed message) on printer. +If optional prefix argument provided, then prompt for the message sequence. +The variable `mh-lpr-command-format' is used to generate the print command. +The messages are formatted by mhl. See the variable `mhl-formfile'." t nil) + +(autoload (quote mh-sort-folder) "mh-funcs" "\ +Sort the messages in the current folder by date. +Calls the MH program sortm to do the work. +The arguments in the list `mh-sortm-args' are passed to sortm if the optional +argument EXTRA-ARGS is given." t nil) + +(autoload (quote mh-undo-folder) "mh-funcs" "\ +Undo all pending deletes and refiles in current folder. +Argument IGNORE is deprecated." t nil) + +(autoload (quote mh-store-msg) "mh-funcs" "\ +Store the file(s) contained in the current message into DIRECTORY. +The message can contain a shar file or uuencoded file. +Default directory is the last directory used, or initially the value of +`mh-store-default-directory' or the current directory." t nil) + +(autoload (quote mh-store-buffer) "mh-funcs" "\ +Store the file(s) contained in the current buffer into DIRECTORY. +The buffer can contain a shar file or uuencoded file. +Default directory is the last directory used, or initially the value of +`mh-store-default-directory' or the current directory." t nil) + +(autoload (quote mh-help) "mh-funcs" "\ +Display cheat sheet for the MH-Folder commands in minibuffer." t nil) + +(autoload (quote mh-prefix-help) "mh-funcs" "\ +Display cheat sheet for the commands of the current prefix in minibuffer." t nil) + +;;;*** + +;;;### (autoloads (mh-insert-identity mh-identity-list-set mh-identity-make-menu) +;;;;;; "mh-identity" "mh-identity.el" (15852 60439)) +;;; Generated autoloads from mh-identity.el + +(autoload (quote mh-identity-make-menu) "mh-identity" "\ +Build (or rebuild) the Identity menu (e.g. after the list is modified)." nil nil) + +(autoload (quote mh-identity-list-set) "mh-identity" "\ +Update the `mh-identity-list' variable, and rebuild the menu. +Sets the default for SYMBOL (e.g. `mh-identity-list') to VALUE (as set in +customization). This is called after 'customize is used to alter +`mh-identity-list'." nil nil) + +(autoload (quote mh-insert-identity) "mh-identity" "\ +Insert proper fields for given IDENTITY. +Edit the `mh-identity-list' variable to define identity." t nil) + +;;;*** + +;;;### (autoloads (mh-namazu-execute-search mh-swish++-execute-search +;;;;;; mh-swish-execute-search mh-glimpse-execute-search mh-index-execute-commands +;;;;;; mh-index-visit-folder mh-index-delete-folder-headers mh-index-insert-folder-headers +;;;;;; mh-index-previous-folder mh-index-next-folder mh-index-search +;;;;;; mh-index-update-maps) "mh-index" "mh-index.el" (15899 19358)) +;;; Generated autoloads from mh-index.el + +(autoload (quote mh-index-update-maps) "mh-index" "\ +Annotate all as yet unannotated messages in FOLDER with their MD5 hash. +As a side effect msg -> checksum map is updated. Optional argument ORIGIN-MAP +is a hashtable which maps each message in the index folder to the original +folder and message from whence it was copied. If present the +checksum -> (origin-folder, origin-index) map is updated too." nil nil) + +(autoload (quote mh-index-search) "mh-index" "\ +Perform an indexed search in an MH mail folder. + +If REDO-SEARCH-FLAG is non-nil and the current folder buffer was generated by a +index search, then the search is repeated. Otherwise, FOLDER is searched with +SEARCH-REGEXP and the results are presented in an MH-E folder. If FOLDER is +\"+\" then mail in all folders are searched. + +Four indexing programs are supported; if none of these are present, then grep +is used. This function picks the first program that is available on your +system. If you would prefer to use a different program, set the customization +variable `mh-index-program' accordingly. + +The documentation for the following functions describes how to generate the +index for each program: + + - `mh-swish++-execute-search' + - `mh-swish-execute-search' + - `mh-namazu-execute-search' + - `mh-glimpse-execute-search' + +This and related functions use an X-MHE-Checksum header to cache the MD5 +checksum of a message. This means that already present X-MHE-Checksum headers +in the incoming email could result in messages not being found. The following +procmail recipe should avoid this: + + :0 wf + | formail -R \"X-MHE-Checksum\" \"Old-X-MHE-Checksum\" + +This has the effect of renaming already present X-MHE-Checksum headers." t nil) + +(autoload (quote mh-index-next-folder) "mh-index" "\ +Jump to the next folder marker. +The function is only applicable to folders displaying index search results. +With non-nil optional argument BACKWARD-FLAG, jump to the previous group of +results." t nil) + +(autoload (quote mh-index-previous-folder) "mh-index" "\ +Jump to the previous folder marker." t nil) + +(autoload (quote mh-index-insert-folder-headers) "mh-index" "\ +Annotate the search results with original folder names." nil nil) + +(autoload (quote mh-index-delete-folder-headers) "mh-index" "\ +Delete the folder headers." nil nil) + +(autoload (quote mh-index-visit-folder) "mh-index" "\ +Visit original folder from where the message at point was found." t nil) + +(autoload (quote mh-index-execute-commands) "mh-index" "\ +Delete/refile the actual messages. +The copies in the searched folder are then deleted/refiled to get the desired +result. Before deleting the messages we make sure that the message being +deleted is identical to the one that the user has marked in the index buffer." nil nil) + +(autoload (quote mh-glimpse-execute-search) "mh-index" "\ +Execute glimpse and read the results. + +In the examples below, replace /home/user/Mail with the path to your MH +directory. + +First create the directory /home/user/Mail/.glimpse. Then create the file +/home/user/Mail/.glimpse/.glimpse_exclude with the following contents: + + */.* + */#* + */,* + */*~ + ^/home/user/Mail/.glimpse + ^/home/user/Mail/mhe-index + +If there are any directories you would like to ignore, append lines like the +following to .glimpse_exclude: + + ^/home/user/Mail/scripts + +You do not want to index the folders that hold the results of your searches +since they tend to be ephemeral and the original messages are indexed anyway. +The configuration file above assumes that the results are found in sub-folders +of `mh-index-folder' which is +mhe-index by default. + +Use the following command line to generate the glimpse index. Run this +daily from cron: + + glimpseindex -H /home/user/Mail/.glimpse /home/user/Mail + +FOLDER-PATH is the directory in which SEARCH-REGEXP is used to search." nil nil) + +(autoload (quote mh-swish-execute-search) "mh-index" "\ +Execute swish-e and read the results. + +In the examples below, replace /home/user/Mail with the path to your MH +directory. + +First create the directory /home/user/Mail/.swish. Then create the file +/home/user/Mail/.swish/config with the following contents: + + IndexDir /home/user/Mail + IndexFile /home/user/Mail/.swish/index + IndexName \"Mail Index\" + IndexDescription \"Mail Index\" + IndexPointer \"http://nowhere\" + IndexAdmin \"nobody\" + #MetaNames automatic + IndexReport 3 + FollowSymLinks no + UseStemming no + IgnoreTotalWordCountWhenRanking yes + WordCharacters abcdefghijklmnopqrstuvwxyz0123456789- + BeginCharacters abcdefghijklmnopqrstuvwxyz + EndCharacters abcdefghijklmnopqrstuvwxyz0123456789 + IgnoreLimit 50 1000 + IndexComments 0 + FileRules pathname contains /home/user/Mail/.swish + FileRules pathname contains /home/user/Mail/mhe-index + FileRules filename is index + FileRules filename is ..* + FileRules filename is #.* + FileRules filename is ,.* + FileRules filename is .*~ + +If there are any directories you would like to ignore, append lines like the +following to config: + + FileRules pathname contains /home/user/Mail/scripts + +You do not want to index the folders that hold the results of your searches +since they tend to be ephemeral and the original messages are indexed anyway. +The configuration file above assumes that the results are found in sub-folders +of `mh-index-folder' which is +mhe-index by default. + +Use the following command line to generate the swish index. Run this +daily from cron: + + swish-e -c /home/user/Mail/.swish/config + +FOLDER-PATH is the directory in which SEARCH-REGEXP is used to search." nil nil) + +(autoload (quote mh-swish++-execute-search) "mh-index" "\ +Execute swish++ and read the results. + +In the examples below, replace /home/user/Mail with the path to your MH +directory. + +First create the directory /home/user/Mail/.swish++. Then create the file +/home/user/Mail/.swish++/swish++.conf with the following contents: + + IncludeMeta Bcc Cc Comments Content-Description From Keywords + IncludeMeta Newsgroups Resent-To Subject To + IncludeMeta Message-Id References In-Reply-To + IncludeFile Mail * + IndexFile /home/user/Mail/.swish++/swish++.index + +Use the following command line to generate the swish index. Run this +daily from cron: + + find /home/user/Mail -path /home/user/Mail/mhe-index -prune \\ + -o -path /home/user/Mail/.swish++ -prune \\ + -o -name \"[0-9]*\" -print \\ + | index -c /home/user/Mail/.swish++/swish++.conf /home/user/Mail + +You do not want to index the folders that hold the results of your searches +since they tend to be ephemeral and the original messages are indexed anyway. +The command above assumes that the results are found in sub-folders of +`mh-index-folder' which is +mhe-index by default. + +On some systems (Debian GNU/Linux, for example), use index++ instead of index. + +FOLDER-PATH is the directory in which SEARCH-REGEXP is used to search." nil nil) + +(autoload (quote mh-namazu-execute-search) "mh-index" "\ +Execute namazu and read the results. + +In the examples below, replace /home/user/Mail with the path to your MH +directory. + +First create the directory /home/user/Mail/.namazu. Then create the file +/home/user/Mail/.namazu/mknmzrc with the following contents: + + package conf; # Don't remove this line! + $ADDRESS = 'user@localhost'; + $ALLOW_FILE = \"[0-9]*\"; + $EXCLUDE_PATH = \"^/home/user/Mail/(mhe-index|spam)\"; + +In the above example configuration, none of the mail files contained in the +directories /home/user/Mail/mhe-index and /home/user/Mail/spam are indexed. + +You do not want to index the folders that hold the results of your searches +since they tend to be ephemeral and the original messages are indexed anyway. +The configuration file above assumes that the results are found in sub-folders +of `mh-index-folder' which is +mhe-index by default. + +Use the following command line to generate the namazu index. Run this +daily from cron: + + mknmz -f /home/user/Mail/.namazu/mknmzrc -O /home/user/Mail/.namazu \\ + /home/user/Mail + +FOLDER-PATH is the directory in which SEARCH-REGEXP is used to search." nil nil) + +;;;*** + +;;;### (autoloads (mh-mime-inline-part mh-mime-save-part mh-push-button +;;;;;; mh-press-button mh-mime-display mh-mime-save-parts mh-display-emphasis +;;;;;; mh-display-smileys mh-add-missing-mime-version-header mh-destroy-postponed-handles +;;;;;; mh-mime-cleanup mh-mml-secure-message-encrypt-pgpmime mh-mml-secure-message-sign-pgpmime +;;;;;; mh-mml-attach-file mh-mml-forward-message mh-mml-to-mime +;;;;;; mh-revert-mhn-edit mh-edit-mhn mh-mhn-compose-forw mh-mhn-compose-external-compressed-tar +;;;;;; mh-mhn-compose-anon-ftp mh-mhn-compose-insertion mh-compose-forward +;;;;;; mh-compose-insertion) "mh-mime" "mh-mime.el" (15858 6046)) +;;; Generated autoloads from mh-mime.el + +(autoload (quote mh-compose-insertion) "mh-mime" "\ +Add a directive to insert a MIME part from a file, using mhn or gnus. +If the variable `mh-compose-insertion' is set to 'mhn, then that will be used. +If it is set to 'gnus, then that will be used instead. +Optional argument INLINE means make it an inline attachment." t nil) + +(autoload (quote mh-compose-forward) "mh-mime" "\ +Add a MIME directive to forward a message, using mhn or gnus. +If the variable `mh-compose-insertion' is set to 'mhn, then that will be used. +If it is set to 'gnus, then that will be used instead. +Optional argument DESCRIPTION is a description of the attachment. +Optional argument FOLDER is the folder from which the forwarded message should +come. +Optional argument MESSAGE is the message to forward. +If any of the optional arguments are absent, they are prompted for." t nil) + +(autoload (quote mh-mhn-compose-insertion) "mh-mime" "\ +Add a directive to insert a MIME message part from a file. +This is the typical way to insert non-text parts in a message. + +Arguments are FILENAME, which tells where to find the file, TYPE, the MIME +content type, DESCRIPTION, a line of text for the Content-Description field. +ATTRIBUTES is a comma separated list of name=value pairs that is appended to +the Content-Type field of the attachment. + +See also \\[mh-edit-mhn]." t nil) + +(autoload (quote mh-mhn-compose-anon-ftp) "mh-mime" "\ +Add a directive for a MIME anonymous ftp external body part. +This directive tells MH to include a reference to a message/external-body part +retrievable by anonymous FTP. + +Arguments are HOST and FILENAME, which tell where to find the file, TYPE, the +MIME content type, and DESCRIPTION, a line of text for the Content-description +header. + +See also \\[mh-edit-mhn]." t nil) + +(autoload (quote mh-mhn-compose-external-compressed-tar) "mh-mime" "\ +Add a directive to include a MIME reference to a compressed tar file. +The file should be available via anonymous ftp. This directive tells MH to +include a reference to a message/external-body part. + +Arguments are HOST and FILENAME, which tell where to find the file, and +DESCRIPTION, a line of text for the Content-description header. + +See also \\[mh-edit-mhn]." t nil) + +(autoload (quote mh-mhn-compose-forw) "mh-mime" "\ +Add a forw directive to this message, to forward a message with MIME. +This directive tells MH to include the named messages in this one. + +Arguments are DESCRIPTION, a line of text for the Content-description header, +and FOLDER and MESSAGES, which name the message(s) to be forwarded. + +See also \\[mh-edit-mhn]." t nil) + +(autoload (quote mh-edit-mhn) "mh-mime" "\ +Format the current draft for MIME, expanding any mhn directives. + +Process the current draft with the mhn program, which, using directives +already inserted in the draft, fills in all the MIME components and header +fields. + +This step should be done last just before sending the message. + +The `\\[mh-revert-mhn-edit]' command undoes this command. The arguments in the +list `mh-mhn-args' are passed to mhn if this function is passed an optional +prefix argument EXTRA-ARGS. + +For assistance with creating mhn directives to insert various types of +components in a message, see \\[mh-mhn-compose-insertion] (generic insertion +from a file), \\[mh-mhn-compose-anon-ftp] (external reference to file via +anonymous ftp), \\[mh-mhn-compose-external-compressed-tar] (reference to +compressed tar file via anonymous ftp), and \\[mh-mhn-compose-forw] (forward +message). If these helper functions are used, `mh-edit-mhn' is run +automatically when the draft is sent. + +The value of `mh-edit-mhn-hook' is a list of functions to be called, with no +arguments, after performing the conversion. + +The mhn program is part of MH version 6.8 or later." t nil) + +(autoload (quote mh-revert-mhn-edit) "mh-mime" "\ +Undo the effect of \\[mh-edit-mhn] by reverting to the backup file. +Optional non-nil argument NOCONFIRM means don't ask for confirmation." t nil) + +(autoload (quote mh-mml-to-mime) "mh-mime" "\ +Compose MIME message from mml directives." t nil) + +(autoload (quote mh-mml-forward-message) "mh-mime" "\ +Forward a message as attachment. +The function will prompt the user for a DESCRIPTION, a FOLDER and MESSAGE +number." nil nil) + +(autoload (quote mh-mml-attach-file) "mh-mime" "\ +Attach a file to the outgoing MIME message. +The file is not inserted or encoded until you send the message with +`\\[mh-send-letter]'. +Message disposition is \"inline\" or \"attachment\" and is prompted for if +DISPOSITION is nil. + +This is basically `mml-attach-file' from gnus, modified such that a prefix +argument yields an `inline' disposition and Content-Type is determined +automatically." nil nil) + +(autoload (quote mh-mml-secure-message-sign-pgpmime) "mh-mime" "\ +Add directive to encrypt/sign the entire message." t nil) + +(autoload (quote mh-mml-secure-message-encrypt-pgpmime) "mh-mime" "\ +Add directive to encrypt and sign the entire message. +If called with a prefix argument DONTSIGN, only encrypt (do NOT sign)." t nil) + +(autoload (quote mh-mime-cleanup) "mh-mime" "\ +Free the decoded MIME parts." nil nil) + +(autoload (quote mh-destroy-postponed-handles) "mh-mime" "\ +Free MIME data for externally displayed mime parts." nil nil) + +(autoload (quote mh-add-missing-mime-version-header) "mh-mime" "\ +Some mail programs don't put a MIME-Version header. +I have seen this only in spam, so maybe we shouldn't fix this ;-)" nil nil) + +(autoload (quote mh-display-smileys) "mh-mime" "\ +Function to display smileys." nil nil) + +(autoload (quote mh-display-emphasis) "mh-mime" "\ +Function to display graphical emphasis." nil nil) + +(autoload (quote mh-mime-save-parts) "mh-mime" "\ +Store the MIME parts of the current message. +If ARG, prompt for directory, else use that specified by the variable +`mh-mime-save-parts-default-directory'. These directories may be superseded by +mh_profile directives, since this function calls on mhstore or mhn to do the +actual storing." t nil) + +(autoload (quote mh-mime-display) "mh-mime" "\ +Display (and possibly decode) MIME handles. +Optional argument, PRE-DISSECTED-HANDLES is a list of MIME handles. If +present they are displayed otherwise the buffer is parsed and then +displayed." nil nil) + +(autoload (quote mh-press-button) "mh-mime" "\ +Press MIME button. +If the MIME part is visible then it is removed. Otherwise the part is +displayed." t nil) + +(autoload (quote mh-push-button) "mh-mime" "\ +Click MIME button for EVENT. +If the MIME part is visible then it is removed. Otherwise the part is +displayed. This function is called when the mouse is used to click the MIME +button." t nil) + +(autoload (quote mh-mime-save-part) "mh-mime" "\ +Save MIME part at point." t nil) + +(autoload (quote mh-mime-inline-part) "mh-mime" "\ +Toggle display of the raw MIME part." t nil) + +;;;*** + +;;;### (autoloads (mh-do-pick-search mh-search-folder) "mh-pick" +;;;;;; "mh-pick.el" (15854 20166)) +;;; Generated autoloads from mh-pick.el + +(autoload (quote mh-search-folder) "mh-pick" "\ +Search FOLDER for messages matching a pattern. +This function uses the MH command `pick' to do the work. +Add the messages found to the sequence named `search'." t nil) + +(autoload (quote mh-do-pick-search) "mh-pick" "\ +Find messages that match the qualifications in the current pattern buffer. +Messages are searched for in the folder named in `mh-searching-folder'. +Add the messages found to the sequence named `search'." t nil) + +;;;*** + +;;;### (autoloads (mh-thread-refile mh-thread-delete mh-thread-ancestor +;;;;;; mh-thread-previous-sibling mh-thread-next-sibling mh-thread-forget-message +;;;;;; mh-toggle-threads mh-thread-add-spaces mh-thread-inc mh-delete-subject-or-thread +;;;;;; mh-delete-subject mh-narrow-to-subject mh-region-to-msg-list +;;;;;; mh-add-to-sequence mh-notate-seq mh-map-to-seq-msgs mh-rename-seq +;;;;;; mh-widen mh-put-msg-in-seq mh-narrow-to-seq mh-msg-is-in-seq +;;;;;; mh-list-sequences mh-delete-seq) "mh-seq" "mh-seq.el" (15899 +;;;;;; 19358)) +;;; Generated autoloads from mh-seq.el + +(autoload (quote mh-delete-seq) "mh-seq" "\ +Delete the SEQUENCE." t nil) + +(autoload (quote mh-list-sequences) "mh-seq" "\ +List the sequences defined in the folder being visited." t nil) + +(autoload (quote mh-msg-is-in-seq) "mh-seq" "\ +Display the sequences that contain MESSAGE (default: current message)." t nil) + +(autoload (quote mh-narrow-to-seq) "mh-seq" "\ +Restrict display of this folder to just messages in SEQUENCE. +Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command." t nil) + +(autoload (quote mh-put-msg-in-seq) "mh-seq" "\ +Add MSG-OR-SEQ (default: displayed message) to SEQUENCE. +If optional prefix argument provided, then prompt for the message sequence. +If variable `transient-mark-mode' is non-nil and the mark is active, then +the selected region is added to the sequence." t nil) + +(autoload (quote mh-widen) "mh-seq" "\ +Remove restrictions from current folder, thereby showing all messages." t nil) + +(autoload (quote mh-rename-seq) "mh-seq" "\ +Rename SEQUENCE to have NEW-NAME." t nil) + +(autoload (quote mh-map-to-seq-msgs) "mh-seq" "\ +Invoke the FUNC at each message in the SEQ. +SEQ can either be a list of messages or a MH sequence. The remaining ARGS are +passed as arguments to FUNC." nil nil) + +(autoload (quote mh-notate-seq) "mh-seq" "\ +Mark the scan listing. +All messages in SEQ are marked with NOTATION at OFFSET from the beginning of +the line." nil nil) + +(autoload (quote mh-add-to-sequence) "mh-seq" "\ +The sequence SEQ is augmented with the messages in MSGS." nil nil) + +(autoload (quote mh-region-to-msg-list) "mh-seq" "\ +Return a list of messages within the region between BEGIN and END." nil nil) + +(autoload (quote mh-narrow-to-subject) "mh-seq" "\ +Narrow to a sequence containing all following messages with same subject." t nil) + +(autoload (quote mh-delete-subject) "mh-seq" "\ +Mark all following messages with same subject to be deleted. +This puts the messages in a sequence named subject. You can undo the last +deletion marks using `mh-undo' with a prefix argument and then specifying the +subject sequence." t nil) + +(autoload (quote mh-delete-subject-or-thread) "mh-seq" "\ +Mark messages for deletion intelligently. +If the folder is threaded then `mh-thread-delete' is used to mark the current +message and all its descendants for deletion. Otherwise `mh-delete-subject' is +used to mark the current message and all messages following it with the same +subject for deletion." t nil) + +(autoload (quote mh-thread-inc) "mh-seq" "\ +Update thread tree for FOLDER. +All messages after START-POINT are added to the thread tree." nil nil) + +(autoload (quote mh-thread-add-spaces) "mh-seq" "\ +Add COUNT spaces to each scan line in `mh-thread-scan-line-map'." nil nil) + +(autoload (quote mh-toggle-threads) "mh-seq" "\ +Toggle threaded view of folder. +The conversion of normal view to threaded view is exact, that is the same +messages are displayed in the folder buffer before and after threading. However +the conversion from threaded view to normal view is inexact. So more messages +than were originally present may be shown as a result." t nil) + +(autoload (quote mh-thread-forget-message) "mh-seq" "\ +Forget the message INDEX from the threading tables." nil nil) + +(autoload (quote mh-thread-next-sibling) "mh-seq" "\ +Jump to next sibling. +With non-nil optional argument PREVIOUS-FLAG jump to the previous sibling." t nil) + +(autoload (quote mh-thread-previous-sibling) "mh-seq" "\ +Jump to previous sibling." t nil) + +(autoload (quote mh-thread-ancestor) "mh-seq" "\ +Jump to the ancestor of current message. +If optional argument THREAD-ROOT-FLAG is non-nil then jump to the root of the +thread tree the message belongs to." t nil) + +(autoload (quote mh-thread-delete) "mh-seq" "\ +Mark current message and all its children for subsequent deletion." t nil) + +(autoload (quote mh-thread-refile) "mh-seq" "\ +Mark current message and all its children for refiling to FOLDER." t nil) + +;;;*** + +;;;### (autoloads (mh-speed-add-folder mh-speed-invalidate-map mh-speed-flists +;;;;;; mh-speed-view mh-speed-toggle mh-folder-speedbar-buttons) +;;;;;; "mh-speed" "mh-speed.el" (15899 19358)) +;;; Generated autoloads from mh-speed.el + +(autoload (quote mh-folder-speedbar-buttons) "mh-speed" "\ +Interface function to create MH-E speedbar buffer. +BUFFER is the MH-E buffer for which the speedbar buffer is to be created." nil nil) + +(defalias (quote mh-show-speedbar-buttons) (quote mh-folder-speedbar-buttons)) + +(defalias (quote mh-letter-speedbar-buttons) (quote mh-folder-speedbar-buttons)) + +(autoload (quote mh-speed-toggle) "mh-speed" "\ +Toggle the display of child folders. +The otional ARGS are ignored and there for compatibilty with speedbar." t nil) + +(autoload (quote mh-speed-view) "mh-speed" "\ +View folder on current line. +Optional ARGS are ignored." t nil) + +(autoload (quote mh-speed-flists) "mh-speed" "\ +Execute flists -recurse and update message counts. +If FORCE is non-nil the timer is reset." t nil) + +(autoload (quote mh-speed-invalidate-map) "mh-speed" "\ +Remove FOLDER from various optimization caches." t nil) + +(autoload (quote mh-speed-add-folder) "mh-speed" "\ +Add FOLDER since it is being created. +The function invalidates the latest ancestor that is present." nil nil) + +;;;*** + +;;;### (autoloads (mh-get-msg-num mh-goto-address-find-address-at-point) +;;;;;; "mh-utils" "mh-utils.el" (15899 28827)) +;;; Generated autoloads from mh-utils.el + +(autoload (quote mh-goto-address-find-address-at-point) "mh-utils" "\ +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." nil nil) + +(autoload (quote mh-get-msg-num) "mh-utils" "\ +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." nil nil) + +;;;*** + +;;;### (autoloads (mh-alias-add-address-under-point mh-alias-grab-from-field +;;;;;; mh-alias-add-alias mh-alias-from-has-no-alias-p mh-alias-letter-expand-alias +;;;;;; mh-alias-minibuffer-confirm-address mh-read-address mh-alias-reload) +;;;;;; "mh-alias" "mh-alias.el" (15899 29102)) +;;; Generated autoloads from mh-alias.el + +(autoload (quote mh-alias-reload) "mh-alias" "\ +Load MH aliases into `mh-alias-alist'." t nil) + +(autoload (quote mh-read-address) "mh-alias" "\ +Read an address from the minibuffer with PROMPT." nil nil) + +(autoload (quote mh-alias-minibuffer-confirm-address) "mh-alias" "\ +Display the alias expansion if `mh-alias-flash-on-comma' is non-nil." t nil) + +(autoload (quote mh-alias-letter-expand-alias) "mh-alias" "\ +Expand mail alias before point." nil nil) + +(autoload (quote mh-alias-from-has-no-alias-p) "mh-alias" "\ +Return t is From has no current alias set." nil nil) + +(autoload (quote mh-alias-add-alias) "mh-alias" "\ +*Add ALIAS for ADDRESS in personal alias file. +Prompts for confirmation if the address already has an alias. +If the alias is already is use, `mh-alias-add-alias-to-file' will prompt." t nil) + +(autoload (quote mh-alias-grab-from-field) "mh-alias" "\ +*Add ALIAS for ADDRESS in personal alias file. +Prompts for confirmation if the alias is already in use or if the address +already has an alias." t nil) + +(autoload (quote mh-alias-add-address-under-point) "mh-alias" "\ +Insert an alias for email address under point." t nil) + +;;;*** + +(provide 'mh-loaddefs) +;;; Local Variables: +;;; version-control: never +;;; no-byte-compile: t +;;; no-update-autoloads: t +;;; End: +;;; mh-loaddefs.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mh-e/mh-mime.el Sun Jan 26 02:38:37 2003 +0000 @@ -0,0 +1,1276 @@ +;;; mh-mime.el --- MH-E support for composing MIME messages + +;; Copyright (C) 1993, 1995, 2001, 2002 Free Software Foundation, Inc. + +;; Author: Bill Wohler <wohler@newt.com> +;; Maintainer: Bill Wohler <wohler@newt.com> +;; Keywords: mail +;; See: mh-e.el + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Internal support for MH-E package. +;; Support for generating an mhn composition file. +;; MIME is supported only by MH 6.8 or later. + +;;; Change Log: + +;; $Id: mh-mime.el,v 1.12 2003/01/08 23:21:16 wohler Exp $ + +;;; Code: + +(require 'cl) +(require 'mh-comp) +(require 'mh-utils) +(load "mm-decode" t t) ; Non-fatal dependency +(load "mm-uu" t t) ; Non-fatal dependency +(load "mailcap" t t) ; Non-fatal dependency +(load "smiley" t t) ; Non-fatal dependency +(require 'gnus-util) + +(autoload 'gnus-article-goto-header "gnus-art") +(autoload 'article-emphasize "gnus-art") +(autoload 'gnus-get-buffer-create "gnus") +(autoload 'gnus-eval-format "gnus-spec") +(autoload 'widget-convert-button "wid-edit") +(autoload 'message-options-set-recipient "message") +(autoload 'mml-secure-message-sign-pgpmime "mml-sec") +(autoload 'mml-secure-message-encrypt-pgpmime "mml-sec") +(autoload 'mml-minibuffer-read-file "mml") +(autoload 'mml-minibuffer-read-description "mml") +(autoload 'mml-insert-empty-tag "mml") +(autoload 'mml-to-mime "mml") +(autoload 'mml-attach-file "mml") + +;;;###mh-autoload +(defun mh-compose-insertion (&optional inline) + "Add a directive to insert a MIME part from a file, using mhn or gnus. +If the variable `mh-compose-insertion' is set to 'mhn, then that will be used. +If it is set to 'gnus, then that will be used instead. +Optional argument INLINE means make it an inline attachment." + (interactive "P") + (if (equal mh-compose-insertion 'gnus) + (if inline + (mh-mml-attach-file "inline") + (mh-mml-attach-file)) + (call-interactively 'mh-mhn-compose-insertion))) + +;;;###mh-autoload +(defun mh-compose-forward (&optional description folder message) + "Add a MIME directive to forward a message, using mhn or gnus. +If the variable `mh-compose-insertion' is set to 'mhn, then that will be used. +If it is set to 'gnus, then that will be used instead. +Optional argument DESCRIPTION is a description of the attachment. +Optional argument FOLDER is the folder from which the forwarded message should +come. +Optional argument MESSAGE is the message to forward. +If any of the optional arguments are absent, they are prompted for." + (interactive (list + (read-string "Forw Content-description: ") + (mh-prompt-for-folder "Message from" mh-sent-from-folder nil) + (read-string (format "Messages%s: " + (if mh-sent-from-msg + (format " [%d]" mh-sent-from-msg) + ""))))) + (if (equal mh-compose-insertion 'gnus) + (mh-mml-forward-message description folder message) + (mh-mhn-compose-forw description folder message))) + +;; To do: +;; paragraph code should not fill # lines if MIME enabled. +;; implement mh-auto-edit-mhn (if non-nil, \\[mh-send-letter] +;; invokes mh-edit-mhn automatically before sending.) +;; actually, instead of mh-auto-edit-mhn, +;; should read automhnproc from profile +;; MIME option to mh-forward +;; command to move to content-description insertion point + +(defvar mh-mhn-args nil + "Extra arguments to have \\[mh-edit-mhn] pass to the \"mhn\" command. +The arguments are passed to mhn if \\[mh-edit-mhn] is given a +prefix argument. Normally default arguments to mhn are specified in the +MH profile.") + +(defvar mh-media-type-regexp + (concat (regexp-opt '("text" "image" "audio" "video" "application" + "multipart" "message") t) + "/[-.+a-zA-Z0-9]+") + "Regexp matching valid media types used in MIME attachment compositions.") + +;; Just defvar the variable to avoid compiler warning... This doesn't bind +;; the variable, so things should work exactly as before. +(defvar mh-have-file-command) + +(defun mh-have-file-command () + "Return t if 'file' command is on the system. +'file -i' is used to get MIME type of composition insertion." + (when (not (boundp 'mh-have-file-command)) + (load "executable" t t) ; executable-find not autoloaded in emacs20 + (setq mh-have-file-command + (and (fboundp 'executable-find) + (executable-find "file") ; file command exists + ; and accepts -i and -b args. + (zerop (call-process "file" nil nil nil "-i" "-b" + (expand-file-name "inc" mh-progs)))))) + mh-have-file-command) + +(defvar mh-file-mime-type-substitutions + '(("application/msword" "\.xls" "application/ms-excel") + ("application/msword" "\.ppt" "application/ms-powerpoint")) + "Substitutions to make for Content-Type returned from file command. +The first element is the Content-Type returned by the file command. +The second element is a regexp matching the file name, usually the extension. +The third element is the Content-Type to replace with.") + +(defun mh-file-mime-type-substitute (content-type filename) + "Return possibly changed CONTENT-TYPE on the FILENAME. +Substitutions are made from the `mh-file-mime-type-substitutions' variable." + (let ((subst mh-file-mime-type-substitutions) + (type) (match) (answer content-type) + (case-fold-search t)) + (while subst + (setq type (car (car subst)) + match (elt (car subst) 1)) + (if (and (string-equal content-type type) + (string-match match filename)) + (setq answer (elt (car subst) 2) + subst nil) + (setq subst (cdr subst)))) + answer)) + +(defun mh-file-mime-type (filename) + "Return MIME type of FILENAME from file command. +Returns nil if file command not on system." + (cond + ((not (mh-have-file-command)) + nil) ;No file command, exit now. + ((not (and (file-exists-p filename)(file-readable-p filename))) + nil) + (t + (save-excursion + (let ((tmp-buffer (get-buffer-create mh-temp-buffer))) + (set-buffer tmp-buffer) + (unwind-protect + (progn + (call-process "file" nil '(t nil) nil "-b" "-i" + (expand-file-name filename)) + (goto-char (point-min)) + (if (not (re-search-forward mh-media-type-regexp nil t)) + nil + (mh-file-mime-type-substitute (match-string 0) filename))) + (kill-buffer tmp-buffer))))))) + +;;; This is needed for Emacs20 which doesn't have mailcap-mime-types. +(defvar mh-mime-content-types + '(("application/mac-binhex40") ("application/msword") + ("application/octet-stream") ("application/pdf") ("application/pgp-keys") + ("application/pgp-signature") ("application/pkcs7-signature") + ("application/postscript") ("application/rtf") + ("application/vnd.ms-excel") ("application/vnd.ms-powerpoint") + ("application/vnd.ms-project") ("application/vnd.ms-tnef") + ("application/wordperfect5.1") ("application/wordperfect6.0") + ("application/zip") + + ("audio/basic") ("audio/mpeg") + + ("image/gif") ("image/jpeg") ("image/png") + + ("message/delivery-status") + ("message/external-body") ("message/partial") ("message/rfc822") + + ("text/enriched") ("text/html") ("text/plain") ("text/rfc822-headers") + ("text/richtext") ("text/xml") + + ("video/mpeg") ("video/quicktime")) + "Legal MIME content types. +See documentation for \\[mh-edit-mhn].") + +;;;###mh-autoload +(defun mh-mhn-compose-insertion (filename type description attributes) + "Add a directive to insert a MIME message part from a file. +This is the typical way to insert non-text parts in a message. + +Arguments are FILENAME, which tells where to find the file, TYPE, the MIME +content type, DESCRIPTION, a line of text for the Content-Description field. +ATTRIBUTES is a comma separated list of name=value pairs that is appended to +the Content-Type field of the attachment. + +See also \\[mh-edit-mhn]." + (interactive (let ((filename (read-file-name "Insert contents of: "))) + (list + filename + (or (mh-file-mime-type filename) + (completing-read "Content-Type: " + (if (fboundp 'mailcap-mime-types) + (mapcar 'list (mailcap-mime-types)) + mh-mime-content-types))) + (read-string "Content-Description: ") + (read-string "Content-Attributes: " + (concat "name=\"" + (file-name-nondirectory filename) + "\""))))) + (mh-mhn-compose-type filename type description attributes )) + +(defun mh-mhn-compose-type (filename type + &optional description attributes comment) + "Insert a mhn directive to insert a file. + +The file specified by FILENAME is encoded as TYPE. An optional DESCRIPTION is +used as the Content-Description field, optional set of ATTRIBUTES and an +optional COMMENT can also be included." + (setq mh-mhn-compose-insert-flag t) + (beginning-of-line) + (insert "#" type) + (and attributes + (insert "; " attributes)) + (and comment + (insert " (" comment ")")) + (insert " [") + (and description + (insert description)) + (insert "] " (expand-file-name filename)) + (insert "\n")) + + +;;;###mh-autoload +(defun mh-mhn-compose-anon-ftp (host filename type description) + "Add a directive for a MIME anonymous ftp external body part. +This directive tells MH to include a reference to a message/external-body part +retrievable by anonymous FTP. + +Arguments are HOST and FILENAME, which tell where to find the file, TYPE, the +MIME content type, and DESCRIPTION, a line of text for the Content-description +header. + +See also \\[mh-edit-mhn]." + (interactive (list + (read-string "Remote host: ") + (read-string "Remote filename: ") + (completing-read "External Content-Type: " + (if (fboundp 'mailcap-mime-types) + (mapcar 'list (mailcap-mime-types)) + mh-mime-content-types)) + (read-string "External Content-Description: "))) + (mh-mhn-compose-external-type "anon-ftp" host filename + type description)) + +;;;###mh-autoload +(defun mh-mhn-compose-external-compressed-tar (host filename description) + "Add a directive to include a MIME reference to a compressed tar file. +The file should be available via anonymous ftp. This directive tells MH to +include a reference to a message/external-body part. + +Arguments are HOST and FILENAME, which tell where to find the file, and +DESCRIPTION, a line of text for the Content-description header. + +See also \\[mh-edit-mhn]." + (interactive (list + (read-string "Remote host: ") + (read-string "Remote filename: ") + (read-string "Tar file Content-description: "))) + (mh-mhn-compose-external-type "anon-ftp" host filename + "application/octet-stream" + description + "type=tar; conversions=x-compress" + "mode=image")) + + +(defun mh-mhn-compose-external-type (access-type host filename type + &optional description + attributes extra-params + comment) + "Add a directive to include a MIME reference to a remote file. +The file should be available via anonymous ftp. This directive tells MH to +include a reference to a message/external-body part. + +Arguments are ACCESS-TYPE, HOST and FILENAME, which tell where to find the +file and TYPE which is the MIME Content-Type. Optional arguments include +DESCRIPTION, a line of text for the Content-description header, ATTRIBUTES, +EXTRA-PARAMS, and COMMENT. + +See also \\[mh-edit-mhn]." + (setq mh-mhn-compose-insert-flag t) + (beginning-of-line) + (insert "#@" type) + (and attributes + (insert "; " attributes)) + (and comment + (insert " (" comment ") ")) + (insert " [") + (and description + (insert description)) + (insert "] ") + (insert "access-type=" access-type "; ") + (insert "site=" host) + (insert "; name=" (file-name-nondirectory filename)) + (insert "; directory=\"" (file-name-directory filename) "\"") + (and extra-params + (insert "; " extra-params)) + (insert "\n")) + +;;;###mh-autoload +(defun mh-mhn-compose-forw (&optional description folder messages) + "Add a forw directive to this message, to forward a message with MIME. +This directive tells MH to include the named messages in this one. + +Arguments are DESCRIPTION, a line of text for the Content-description header, +and FOLDER and MESSAGES, which name the message(s) to be forwarded. + +See also \\[mh-edit-mhn]." + (interactive (list + (read-string "Forw Content-description: ") + (mh-prompt-for-folder "Message from" mh-sent-from-folder nil) + (read-string (format "Messages%s: " + (if mh-sent-from-msg + (format " [%d]" mh-sent-from-msg) + ""))))) + (setq mh-mhn-compose-insert-flag t) + (beginning-of-line) + (insert "#forw [") + (and description + (not (string= description "")) + (insert description)) + (insert "]") + (and folder + (not (string= folder "")) + (insert " " folder)) + (if (and messages + (not (string= messages ""))) + (let ((start (point))) + (insert " " messages) + (subst-char-in-region start (point) ?, ? )) + (if mh-sent-from-msg + (insert " " (int-to-string mh-sent-from-msg)))) + (insert "\n")) + +;;;###mh-autoload +(defun mh-edit-mhn (&optional extra-args) + "Format the current draft for MIME, expanding any mhn directives. + +Process the current draft with the mhn program, which, using directives +already inserted in the draft, fills in all the MIME components and header +fields. + +This step should be done last just before sending the message. + +The `\\[mh-revert-mhn-edit]' command undoes this command. The arguments in the +list `mh-mhn-args' are passed to mhn if this function is passed an optional +prefix argument EXTRA-ARGS. + +For assistance with creating mhn directives to insert various types of +components in a message, see \\[mh-mhn-compose-insertion] (generic insertion +from a file), \\[mh-mhn-compose-anon-ftp] (external reference to file via +anonymous ftp), \\[mh-mhn-compose-external-compressed-tar] \ \(reference to +compressed tar file via anonymous ftp), and \\[mh-mhn-compose-forw] (forward +message). If these helper functions are used, `mh-edit-mhn' is run +automatically when the draft is sent. + +The value of `mh-edit-mhn-hook' is a list of functions to be called, with no +arguments, after performing the conversion. + +The mhn program is part of MH version 6.8 or later." + (interactive "*P") + (save-buffer) + (message "mhn editing...") + (cond + (mh-nmh-flag + (mh-exec-cmd-error nil + "mhbuild" (if extra-args mh-mhn-args) buffer-file-name)) + (t + (mh-exec-cmd-error (format "mhdraft=%s" buffer-file-name) + "mhn" (if extra-args mh-mhn-args) buffer-file-name))) + (setq mh-mhn-compose-insert-flag nil) + (revert-buffer t t) + (message "mhn editing...done") + (run-hooks 'mh-edit-mhn-hook)) + +;;;###mh-autoload +(defun mh-revert-mhn-edit (noconfirm) + "Undo the effect of \\[mh-edit-mhn] by reverting to the backup file. +Optional non-nil argument NOCONFIRM means don't ask for confirmation." + (interactive "*P") + (if (null buffer-file-name) + (error "Buffer does not seem to be associated with any file")) + (let ((backup-strings '("," "#")) + backup-file) + (while (and backup-strings + (not (file-exists-p + (setq backup-file + (concat (file-name-directory buffer-file-name) + (car backup-strings) + (file-name-nondirectory buffer-file-name) + ".orig"))))) + (setq backup-strings (cdr backup-strings))) + (or backup-strings + (error "Backup file for %s no longer exists!" buffer-file-name)) + (or noconfirm + (yes-or-no-p (format "Revert buffer from file %s? " + backup-file)) + (error "Revert not confirmed")) + (let ((buffer-read-only nil)) + (erase-buffer) + (insert-file-contents backup-file)) + (after-find-file nil))) + + + +;;; MIME composition functions + +;;;###mh-autoload +(defun mh-mml-to-mime () + "Compose MIME message from mml directives." + (interactive) + (when mh-gnus-pgp-support-flag ;; This is only needed for PGP + (message-options-set-recipient)) + (mml-to-mime) + (setq mh-mml-compose-insert-flag nil)) + +;;;###mh-autoload +(defun mh-mml-forward-message (description folder message) + "Forward a message as attachment. +The function will prompt the user for a DESCRIPTION, a FOLDER and MESSAGE +number." + (let ((msg (if (equal message "") + mh-sent-from-msg + (car (read-from-string message))))) + (cond ((integerp msg) + (if (string= "" description) + ;; Rationale: mml-attach-file constructs a malformed composition + ;; if the description string is empty. This fixes SF #625168. + (mml-attach-file (format "%s%s/%d" + mh-user-path (substring folder 1) msg) + "message/rfc822") + (mml-attach-file (format "%s%s/%d" + mh-user-path (substring folder 1) msg) + "message/rfc822" + description)) + (setq mh-mml-compose-insert-flag t)) + (t (error "The message number, %s is not a integer!" msg))))) + +;;;###mh-autoload +(defun mh-mml-attach-file (&optional disposition) + "Attach a file to the outgoing MIME message. +The file is not inserted or encoded until you send the message with +`\\[mh-send-letter]'. +Message disposition is \"inline\" or \"attachment\" and is prompted for if +DISPOSITION is nil. + +This is basically `mml-attach-file' from gnus, modified such that a prefix +argument yields an `inline' disposition and Content-Type is determined +automatically." + (let* ((file (mml-minibuffer-read-file "Attach file: ")) + (type (or (mh-file-mime-type file) + (completing-read "Content-Type: " + (if (fboundp 'mailcap-mime-types) + (mapcar 'list (mailcap-mime-types)) + mh-mime-content-types)))) + (description (mml-minibuffer-read-description)) + (dispos (or disposition + (completing-read "Disposition: [attachment] " + '(("attachment")("inline")) + nil t nil nil + "attachment")))) + (mml-insert-empty-tag 'part 'type type 'filename file + 'disposition dispos 'description description) + (setq mh-mml-compose-insert-flag t))) + +;;;###mh-autoload +(defun mh-mml-secure-message-sign-pgpmime () + "Add directive to encrypt/sign the entire message." + (interactive) + (if (not mh-gnus-pgp-support-flag) + (error "Sorry. Your version of gnus does not support PGP/GPG") + (mml-secure-message-sign-pgpmime) + (setq mh-mml-compose-insert-flag t))) + +;;;###mh-autoload +(defun mh-mml-secure-message-encrypt-pgpmime (&optional dontsign) + "Add directive to encrypt and sign the entire message. +If called with a prefix argument DONTSIGN, only encrypt (do NOT sign)." + (interactive "P") + (if (not mh-gnus-pgp-support-flag) + (error "Sorry. Your version of gnus does not support PGP/GPG") + (mml-secure-message-encrypt-pgpmime dontsign) + (setq mh-mml-compose-insert-flag t))) + + + +;;; MIME decoding + +(defmacro mh-defun-compat (function arg-list &rest body) + "This is a macro to define functions which are not defined. +It is used for Gnus utility functions which were added recently. If FUNCTION +is not defined then it is defined to have argument list, ARG-LIST and body, +BODY." + (let ((defined-p (fboundp function))) + (unless defined-p + `(defun ,function ,arg-list ,@body)))) +(put 'mh-defun-compat 'lisp-indent-function 'defun) + +;; Copy of original function from gnus-util.el +(mh-defun-compat gnus-local-map-property (map) + "Return a list suitable for a text property list specifying keymap MAP." + (cond (mh-xemacs-flag (list 'keymap map)) + ((>= emacs-major-version 21) (list 'keymap map)) + (t (list 'local-map map)))) + +;; Copy of original function from mm-decode.el +(mh-defun-compat mm-merge-handles (handles1 handles2) + (append (if (listp (car handles1)) handles1 (list handles1)) + (if (listp (car handles2)) handles2 (list handles2)))) + +;; Copy of function from mm-decode.el +(mh-defun-compat mm-set-handle-multipart-parameter (handle parameter value) + ;; HANDLE could be a CTL. + (if handle + (put-text-property 0 (length (car handle)) parameter value + (car handle)))) + +;; Copy of original macro is in mm-decode.el +(mh-defun-compat mm-handle-multipart-ctl-parameter (handle parameter) + (get-text-property 0 parameter (car handle))) + +;; Copy of original function in mm-decode.el +(mh-defun-compat mm-readable-p (handle) + "Say whether the content of HANDLE is readable." + (and (< (with-current-buffer (mm-handle-buffer handle) + (buffer-size)) 10000) + (mm-with-unibyte-buffer + (mm-insert-part handle) + (and (eq (mm-body-7-or-8) '7bit) + (not (mm-long-lines-p 76)))))) + +;; Copy of original function in mm-bodies.el +(mh-defun-compat mm-long-lines-p (length) + "Say whether any of the lines in the buffer is longer than LINES." + (save-excursion + (goto-char (point-min)) + (end-of-line) + (while (and (not (eobp)) + (not (> (current-column) length))) + (forward-line 1) + (end-of-line)) + (and (> (current-column) length) + (current-column)))) + +(mh-defun-compat mm-keep-viewer-alive-p (handle) + ;; Released Gnus doesn't keep handles associated with externally displayed + ;; MIME parts. So this will always return nil. + nil) + +(mh-defun-compat mm-destroy-parts (list) + "Older emacs don't have this function." + nil) + +;;; This is mm-save-part from gnus 5.10 since that function in emacs21.2 is +;;; buggy (the args to read-file-name are incorrect). When all supported +;;; versions of Emacs come with at least Gnus 5.10, we can delete this +;;; function and rename calls to mh-mm-save-part to mm-save-part. +(defun mh-mm-save-part (handle) + "Write HANDLE to a file." + (let ((name (mail-content-type-get (mm-handle-type handle) 'name)) + (filename (mail-content-type-get + (mm-handle-disposition handle) 'filename)) + file) + (when filename + (setq filename (file-name-nondirectory filename))) + (setq file (read-file-name "Save MIME part to: " + (or mm-default-directory + default-directory) + nil nil (or filename name ""))) + (setq mm-default-directory (file-name-directory file)) + (and (or (not (file-exists-p file)) + (yes-or-no-p (format "File %s already exists; overwrite? " + file))) + (mm-save-part-to-file handle file)))) + + + +;;; MIME cleanup + +;;;###mh-autoload +(defun mh-mime-cleanup () + "Free the decoded MIME parts." + (let ((mime-data (gethash (current-buffer) mh-globals-hash))) + ;; This is for Emacs, what about XEmacs? + (cond ((fboundp 'remove-images) + (remove-images (point-min) (point-max)))) + (when mime-data + (mm-destroy-parts (mh-mime-handles mime-data)) + (remhash (current-buffer) mh-globals-hash)))) + +;;;###mh-autoload +(defun mh-destroy-postponed-handles () + "Free MIME data for externally displayed mime parts." + (let ((mime-data (mh-buffer-data))) + (when mime-data + (mm-destroy-parts (mh-mime-handles mime-data))) + (remhash (current-buffer) mh-globals-hash))) + +(defun mh-handle-set-external-undisplayer (folder handle function) + "Replacement for `mm-handle-set-external-undisplayer'. +This is only called in recent versions of Gnus. The MIME handles are stored +in data structures corresponding to MH-E folder buffer FOLDER instead of in +Gnus (as in the original). The MIME part, HANDLE is associated with the +undisplayer FUNCTION." + (if (mm-keep-viewer-alive-p handle) + (let ((new-handle (copy-sequence handle))) + (mm-handle-set-undisplayer new-handle function) + (mm-handle-set-undisplayer handle nil) + (save-excursion + (set-buffer folder) + (push new-handle (mh-mime-handles (mh-buffer-data))))) + (mm-handle-set-undisplayer handle function))) + + + +;;; MIME transformations +(eval-when-compile (require 'font-lock)) + +;;;###mh-autoload +(defun mh-add-missing-mime-version-header () + "Some mail programs don't put a MIME-Version header. +I have seen this only in spam, so maybe we shouldn't fix this ;-)" + (save-excursion + (goto-char (point-min)) + (when (and (message-fetch-field "content-type") + (not (message-fetch-field "mime-version"))) + (when (search-forward "\n\n" nil t) + (forward-line -1) + (insert "MIME-Version: 1.0\n"))))) + +;;;###mh-autoload +(defun mh-display-smileys () + "Function to display smileys." + (when (and mh-graphical-smileys-flag + (fboundp 'smiley-region) + (boundp 'font-lock-maximum-size) + (>= (/ font-lock-maximum-size 8) (buffer-size))) + (smiley-region (point-min) (point-max)))) + +;;;###mh-autoload +(defun mh-display-emphasis () + "Function to display graphical emphasis." + (when (and mh-graphical-emphasis-flag + (boundp 'font-lock-maximum-size) + (>= (/ font-lock-maximum-size 8) (buffer-size))) + (flet ((article-goto-body ())) ; shadow this function to do nothing + (save-excursion + (goto-char (point-min)) + (article-emphasize))))) + +;; Copied from gnus-art.el (should be checked for other cool things that can +;; be added to the buttons) +(defvar mh-mime-button-commands + '((mh-press-button "\r" "Toggle Display"))) +(defvar mh-mime-button-map + (let ((map (make-sparse-keymap))) + (unless (>= (string-to-number emacs-version) 21) + ;; XEmacs doesn't care. + (set-keymap-parent map mh-show-mode-map)) + (define-key map [mouse-2] 'mh-push-button) + (dolist (c mh-mime-button-commands) + (define-key map (cadr c) (car c))) + map)) +(defvar mh-mime-button-line-format-alist + '((?T long-type ?s) + (?d description ?s) + (?p index ?s) + (?e dots ?s))) +(defvar mh-mime-button-line-format "%{%([%p. %d%T]%)%}%e\n") +(defvar mh-mime-security-button-pressed nil) +(defvar mh-mime-security-button-line-format "%{%([[%t:%i]%D]%)%}\n") +(defvar mh-mime-security-button-end-line-format "%{%([[End of %t]%D]%)%}\n") +(defvar mh-mime-security-button-line-format-alist + '((?t type ?s) + (?i info ?s) + (?d details ?s) + (?D pressed-details ?s))) +(defvar mh-mime-security-button-map + (let ((map (make-sparse-keymap))) + (unless (>= (string-to-number emacs-version) 21) + (set-keymap-parent map mh-show-mode-map)) + (define-key map "\r" 'mh-press-button) + (define-key map [mouse-2] 'mh-push-button) + map)) + +(defvar mh-mime-save-parts-directory nil + "Default to use for `mh-mime-save-parts-default-directory'. +Set from last use.") + +;;;###mh-autoload +(defun mh-mime-save-parts (arg) + "Store the MIME parts of the current message. +If ARG, prompt for directory, else use that specified by the variable +`mh-mime-save-parts-default-directory'. These directories may be superseded by +mh_profile directives, since this function calls on mhstore or mhn to do the +actual storing." + (interactive "P") + (let ((msg (if (eq major-mode 'mh-show-mode) + (mh-show-buffer-message-number) + (mh-get-msg-num t))) + (folder (if (eq major-mode 'mh-show-mode) + mh-show-folder-buffer + mh-current-folder)) + (command (if mh-nmh-flag "mhstore" "mhn")) + (directory + (cond + ((and (or arg + (equal nil mh-mime-save-parts-default-directory) + (equal t mh-mime-save-parts-default-directory)) + (not mh-mime-save-parts-directory)) + (read-file-name "Store in what directory? " nil nil t nil)) + ((and (or arg + (equal t mh-mime-save-parts-default-directory)) + mh-mime-save-parts-directory) + (read-file-name (format + "Store in what directory? [%s] " + mh-mime-save-parts-directory) + "" mh-mime-save-parts-directory t "")) + ((stringp mh-mime-save-parts-default-directory) + mh-mime-save-parts-default-directory) + (t + mh-mime-save-parts-directory)))) + (if (and (equal directory "") mh-mime-save-parts-directory) + (setq directory mh-mime-save-parts-directory)) + (if (not (file-directory-p directory)) + (message "No directory specified.") + (if (equal nil mh-mime-save-parts-default-directory) + (setq mh-mime-save-parts-directory directory)) + (save-excursion + (set-buffer (get-buffer-create " *mh-store*")) + (cd directory) + (setq mh-mime-save-parts-directory directory) + (erase-buffer) + (apply 'call-process + (expand-file-name command mh-progs) nil t nil + (mh-list-to-string (list folder msg "-auto"))) + (if (> (buffer-size) 0) + (save-window-excursion + (switch-to-buffer-other-window " *mh-store*") + (sit-for 3))))))) + +;; Avoid errors if gnus-sum isn't loaded yet... +(defvar gnus-newsgroup-charset nil) +(defvar gnus-newsgroup-name nil) + +;;;###mh-autoload +(defun mh-mime-display (&optional pre-dissected-handles) + "Display (and possibly decode) MIME handles. +Optional argument, PRE-DISSECTED-HANDLES is a list of MIME handles. If +present they are displayed otherwise the buffer is parsed and then +displayed." + (let ((handles ()) + (folder mh-show-folder-buffer)) + (flet ((mm-handle-set-external-undisplayer + (handle function) + (mh-handle-set-external-undisplayer folder handle function))) + ;; If needed dissect the current buffer + (if pre-dissected-handles + (setq handles pre-dissected-handles) + (setq handles (or (mm-dissect-buffer nil) (mm-uu-dissect))) + (setf (mh-mime-handles (mh-buffer-data)) + (mm-merge-handles handles (mh-mime-handles (mh-buffer-data))))) + + (when (and handles (or (not (stringp (car handles))) (cdr handles))) + ;; Goto start of message body + (goto-char (point-min)) + (or (search-forward "\n\n" nil t) (goto-char (point-max))) + + ;; Delete the body + (delete-region (point) (point-max)) + + ;; Display the MIME handles + (mh-mime-display-part handles))))) + +(defun mh-mime-display-part (handle) + "Decides the viewer to call based on the type of HANDLE." + (cond ((null handle) nil) + ((not (stringp (car handle))) + (mh-mime-display-single handle)) + ((equal (car handle) "multipart/alternative") + (mh-mime-display-alternative (cdr handle))) + ((and mh-gnus-pgp-support-flag + (or (equal (car handle) "multipart/signed") + (equal (car handle) "multipart/encrypted"))) + (mh-mime-display-security handle)) + (t (mh-mime-display-mixed (cdr handle))))) + +(defun mh-mime-display-alternative (handles) + "Choose among the alternatives, HANDLES the part that will be displayed. +If no part is preferred then all the parts are displayed." + (let ((preferred (mm-preferred-alternative handles))) + (cond ((and preferred (stringp (car preferred))) + (mh-mime-display-part preferred)) + (preferred + (save-restriction + (narrow-to-region (point) (if (eobp) (point) (1+ (point)))) + (mh-mime-display-single preferred) + (goto-char (point-max)))) + (t (mh-mime-display-mixed handles))))) + +(defun mh-mime-display-mixed (handles) + "Display the list of MIME parts, HANDLES recursively." + (mapcar #'mh-mime-display-part handles)) + +(defun mh-mime-part-index (handle) + "Generate the button number for MIME part, HANDLE. +Notice that a hash table is used to display the same number when buttons need +to be displayed multiple times (for instance when nested messages are +opened)." + (or (gethash handle (mh-mime-part-index-hash (mh-buffer-data))) + (setf (gethash handle (mh-mime-part-index-hash (mh-buffer-data))) + (incf (mh-mime-parts-count (mh-buffer-data)))))) + +;;; Avoid compiler warnings for XEmacs functions... +(eval-when (compile) + (loop for function in '(glyph-width window-pixel-width + glyph-height window-pixel-height) + do (or (fboundp function) (defalias function 'ignore)))) + +(defun mh-small-image-p (handle) + "Decide whether HANDLE is a \"small\" image that can be displayed inline. +This is only useful if a Content-Disposition header is not present." + (let ((media-test (caddr (assoc (car (mm-handle-type handle)) + mh-mm-inline-media-tests))) + (mm-inline-large-images t)) + (and media-test + (equal (mm-handle-media-supertype handle) "image") + (funcall media-test handle) ; Since mm-inline-large-images is T, + ; this only tells us if the image is + ; something that emacs can display + (let* ((image (mm-get-image handle))) + (cond ((fboundp 'glyph-width) + ;; XEmacs -- totally untested, copied from gnus + (and (< (glyph-width image) + (or mh-max-inline-image-width + (window-pixel-width))) + (< (glyph-height image) + (or mh-max-inline-image-height + (window-pixel-height))))) + ((fboundp 'image-size) + ;; Emacs21 -- copied from gnus + (let ((size (image-size image))) + (and (< (cdr size) + (or mh-max-inline-image-height + (1- (window-height)))) + (< (car size) + (or mh-max-inline-image-width (window-width)))))) + (t + ;; Can't show image inline + nil)))))) + +(defun mh-inline-vcard-p (handle) + "Decide if HANDLE is a vcard that must be displayed inline." + (let ((type (mm-handle-type handle))) + (and (consp type) + (equal (car type) "text/x-vcard") + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (not (re-search-forward "^-- $" nil t))))))) + +(defun mh-mime-display-single (handle) + "Display a leaf node, HANDLE in the MIME tree." + (let* ((type (mm-handle-media-type handle)) + (small-image-flag (mh-small-image-p handle)) + (attachmentp (equal (car (mm-handle-disposition handle)) + "attachment")) + (inlinep (and (equal (car (mm-handle-disposition handle)) "inline") + (mm-inlinable-p handle) + (mm-inlined-p handle))) + (displayp (or inlinep ; show if inline OR + (mh-inline-vcard-p handle); inline vcard OR + (and (not attachmentp) ; if not an attachment + (or small-image-flag ; and small image + ; and user wants inline + (and (not (equal + (mm-handle-media-supertype handle) + "image")) + (mm-inlinable-p handle) + (mm-inlined-p handle))))))) + (save-restriction + (narrow-to-region (point) (if (eobp) (point) (1+ (point)))) + (cond ((and mh-gnus-pgp-support-flag + (equal type "application/pgp-signature")) + nil) ; skip signatures as they are already handled... + ((not displayp) + (insert "\n") + (mh-insert-mime-button handle (mh-mime-part-index handle) nil)) + ((and displayp (not mh-display-buttons-for-inline-parts-flag)) + (or (mm-display-part handle) (mm-display-part handle))) + ((and displayp mh-display-buttons-for-inline-parts-flag) + (insert "\n") + (mh-insert-mime-button handle (mh-mime-part-index handle) nil) + (forward-line -1) + (mh-mm-display-part handle))) + (goto-char (point-max))))) + +(defun mh-insert-mime-button (handle index displayed) + "Insert MIME button for HANDLE. +INDEX is the part number that will be DISPLAYED. It is also used by commands +like \"K v\" which operate on individual MIME parts." + ;; The button could be displayed by a previous decode. In that case + ;; undisplay it if we need a hidden button. + (when (and (mm-handle-displayed-p handle) (not displayed)) + (mm-display-part handle)) + (let ((name (or (mail-content-type-get (mm-handle-type handle) 'name) + (mail-content-type-get (mm-handle-disposition handle) + 'filename) + (mail-content-type-get (mm-handle-type handle) 'url) + "")) + (type (mm-handle-media-type handle)) + (description (mail-decode-encoded-word-string + (or (mm-handle-description handle) ""))) + (dots (if (or displayed (mm-handle-displayed-p handle)) " " "...")) + long-type begin end) + (if (string-match ".*/" name) (setq name (substring name (match-end 0)))) + (setq long-type (concat type (and (not (equal name "")) + (concat "; " name)))) + (unless (equal description "") + (setq long-type (concat " --- " long-type))) + (unless (bolp) (insert "\n")) + (setq begin (point)) + (gnus-eval-format + mh-mime-button-line-format mh-mime-button-line-format-alist + `(,@(gnus-local-map-property mh-mime-button-map) + mh-callback mh-mm-display-part + mh-part ,index + mh-data ,handle)) + (setq end (point)) + (widget-convert-button + 'link begin end + :mime-handle handle + :action 'mh-widget-press-button + :button-keymap mh-mime-button-map + :help-echo + "Mouse-2 click or press RET (in show buffer) to toggle display"))) + +;; There is a bug in Gnus inline image display due to which an extra line +;; gets inserted every time it is viewed. To work around that problem we are +;; using an extra property 'mh-region to remember the region that is added +;; when the button is clicked. The region is then deleted to make sure that +;; no extra lines get inserted. +(defun mh-mm-display-part (handle) + "Toggle display of button for MIME part, HANDLE." + (beginning-of-line) + (let ((id (get-text-property (point) 'mh-part)) + (point (point)) + (window (selected-window)) + (mail-parse-charset 'nil) + (mail-parse-ignored-charsets nil) + region buffer-read-only) + (save-excursion + (unwind-protect + (let ((win (get-buffer-window (current-buffer) t))) + (when win + (select-window win)) + (goto-char point) + + (if (mm-handle-displayed-p handle) + ;; This will remove the part. + (progn + ;; Delete the button and displayed part (if any) + (let ((region (get-text-property point 'mh-region))) + (when region + (when (fboundp 'remove-images) + (remove-images (car region) (cdr region)))) + (mm-display-part handle) + (when region + (delete-region (car region) (cdr region)))) + ;; Delete button (if it still remains). This happens for + ;; externally displayed parts where the previous step does + ;; nothing. + (unless (eolp) + (delete-region (point) (progn (forward-line) (point))))) + (save-restriction + (delete-region (point) (progn (forward-line 1) (point))) + (narrow-to-region (point) (point)) + ;; Maybe we need another unwind-protect here. + (when (equal (mm-handle-media-supertype handle) "image") + (insert "\n")) + (when (and (not (eq (ignore-errors (mm-display-part handle)) + 'inline)) + (equal (mm-handle-media-supertype handle) + "image")) + (goto-char (point-min)) + (delete-char 1)) + (when (equal (mm-handle-media-supertype handle) "text") + (when (eq mh-highlight-citation-p 'gnus) + (mh-gnus-article-highlight-citation)) + (mh-display-smileys) + (mh-display-emphasis)) + (setq region (cons (progn (goto-char (point-min)) + (point-marker)) + (progn (goto-char (point-max)) + (point-marker))))))) + (when (window-live-p window) + (select-window window)) + (goto-char point) + (beginning-of-line) + (mh-insert-mime-button handle id (mm-handle-displayed-p handle)) + (goto-char point) + (when region + (add-text-properties (line-beginning-position) (line-end-position) + `(mh-region ,region))))))) + +;;;###mh-autoload +(defun mh-press-button () + "Press MIME button. +If the MIME part is visible then it is removed. Otherwise the part is +displayed." + (interactive) + (let ((mm-inline-media-tests mh-mm-inline-media-tests) + (data (get-text-property (point) 'mh-data)) + (function (get-text-property (point) 'mh-callback)) + (buffer-read-only nil) + (folder mh-show-folder-buffer)) + (flet ((mm-handle-set-external-undisplayer + (handle function) + (mh-handle-set-external-undisplayer folder handle function))) + (when (and function (eolp)) + (backward-char)) + (unwind-protect (and function (funcall function data)) + (set-buffer-modified-p nil))))) + +;;;###mh-autoload +(defun mh-push-button (event) + "Click MIME button for EVENT. +If the MIME part is visible then it is removed. Otherwise the part is +displayed. This function is called when the mouse is used to click the MIME +button." + (interactive "e") + (set-buffer (window-buffer (posn-window (event-start event)))) + (select-window (posn-window (event-start event))) + (let* ((pos (posn-point (event-start event))) + (folder mh-show-folder-buffer) + (mm-inline-media-tests mh-mm-inline-media-tests) + (data (get-text-property pos 'mh-data)) + (function (get-text-property pos 'mh-callback)) + (buffer-read-only nil)) + (flet ((mm-handle-set-external-undisplayer + (handle function) + (mh-handle-set-external-undisplayer folder handle function))) + (goto-char pos) + (unwind-protect (and function (funcall function data)) + (set-buffer-modified-p nil))))) + +;;;###mh-autoload +(defun mh-mime-save-part () + "Save MIME part at point." + (interactive) + (let ((data (get-text-property (point) 'mh-data))) + (when data + (let ((mm-default-directory mh-mime-save-parts-directory)) + (mh-mm-save-part data) + (setq mh-mime-save-parts-directory mm-default-directory))))) + +;;;###mh-autoload +(defun mh-mime-inline-part () + "Toggle display of the raw MIME part." + (interactive) + (let* ((buffer-read-only nil) + (data (get-text-property (point) 'mh-data)) + (inserted-flag (get-text-property (point) 'mh-mime-inserted)) + (displayed-flag (mm-handle-displayed-p data)) + (point (point)) + start end) + (cond ((and data (not inserted-flag) (not displayed-flag)) + (let ((contents (mm-get-part data))) + (add-text-properties (line-beginning-position) (line-end-position) + '(mh-mime-inserted t)) + (setq start (point-marker)) + (forward-line 1) + (mm-insert-inline data contents) + (setq end (point-marker)) + (add-text-properties + start (progn (goto-char start) (line-end-position)) + `(mh-region (,start . ,end))))) + ((and data (or inserted-flag displayed-flag)) + (mh-press-button) + (message "MIME part already inserted"))) + (goto-char point) + (set-buffer-modified-p nil))) + +(defun mh-widget-press-button (widget el) + "Callback for widget, WIDGET. +Parameter EL is unused." + (goto-char (widget-get widget :from)) + (mh-press-button)) + +(defun mh-mime-display-security (handle) + "Display PGP encrypted/signed message, HANDLE." + (insert "\n") + (save-restriction + (narrow-to-region (point) (point)) + (mh-insert-mime-security-button handle) + (mh-mime-display-mixed (cdr handle)) + (insert "\n") + (let ((mh-mime-security-button-line-format + mh-mime-security-button-end-line-format)) + (mh-insert-mime-security-button handle)) + (mm-set-handle-multipart-parameter + handle 'mh-region + (cons (set-marker (make-marker) (point-min)) + (set-marker (make-marker) (point-max)))))) + +;;; I rewrote the security part because Gnus doesn't seem to ever minimize +;;; the button. That is once the mime-security button is pressed there seems +;;; to be no way of getting rid of the inserted text. +(defun mh-mime-security-show-details (handle) + "Toggle display of detailed security info for HANDLE." + (let ((details (mm-handle-multipart-ctl-parameter handle 'gnus-details))) + (when details + (let ((mh-mime-security-button-pressed + (not (get-text-property (point) 'mh-button-pressed))) + (mh-mime-security-button-line-format + (get-text-property (point) 'mh-line-format))) + (forward-char -1) + (while (eq (get-text-property (point) 'mh-line-format) + mh-mime-security-button-line-format) + (forward-char -1)) + (forward-char) + (save-restriction + (narrow-to-region (point) (point)) + (mh-insert-mime-security-button handle)) + (delete-region + (point) + (or (text-property-not-all + (point) (point-max) + 'mh-line-format mh-mime-security-button-line-format) + (point-max))) + (forward-line -1))))) + +(defun mh-mime-security-press-button (handle) + "Callback from security button for part HANDLE." + (when (mm-handle-multipart-ctl-parameter handle 'gnus-info) + (mh-mime-security-show-details handle))) + +;; These variables should already be initialized in mm-decode.el if we have a +;; recent enough Gnus. The defvars are here to avoid compiler warnings. +(defvar mm-verify-function-alist nil) +(defvar mm-decrypt-function-alist nil) + +(defvar pressed-details) + +(defun mh-insert-mime-security-button (handle) + "Display buttons for PGP message, HANDLE." + (let* ((protocol (mm-handle-multipart-ctl-parameter handle 'protocol)) + (crypto-type (or (nth 2 (assoc protocol mm-verify-function-alist)) + (nth 2 (assoc protocol mm-decrypt-function-alist)) + "Unknown")) + (type (concat crypto-type + (if (equal (car handle) "multipart/signed") + " Signed" " Encrypted") + " Part")) + (info (or (mm-handle-multipart-ctl-parameter handle 'gnus-info) + "Undecided")) + (details (mm-handle-multipart-ctl-parameter handle 'gnus-details)) + pressed-details begin end) + (setq details (if details (concat "\n" details) "")) + (setq pressed-details (if mh-mime-security-button-pressed details "")) + (unless (bolp) (insert "\n")) + (setq begin (point)) + (gnus-eval-format + mh-mime-security-button-line-format + mh-mime-security-button-line-format-alist + `(,@(gnus-local-map-property mh-mime-security-button-map) + mh-button-pressed ,mh-mime-security-button-pressed + mh-callback mh-mime-security-press-button + mh-line-format ,mh-mime-security-button-line-format + mh-data ,handle)) + (setq end (point)) + (widget-convert-button 'link begin end + :mime-handle handle + :action 'mh-widget-press-button + :button-keymap mh-mime-security-button-map + :help-echo "Mouse-2 click or press RET (in show buffer) to see security details.") + (when (equal info "Failed") + (let* ((type (if (equal (car handle) "multipart/signed") + "verification" "decryption")) + (warning (if (equal type "decryption") + "(passphrase may be incorrect)" ""))) + (message "%s %s failed %s" crypto-type type warning))))) + +(defun mh-mm-inline-message (handle) + "Display message, HANDLE. +The function decodes the message and displays it. It avoids decoding the same +message multiple times." + (let ((b (point)) + (charset (mail-content-type-get (mm-handle-type handle) 'charset)) + (clean-message-header mh-clean-message-header-flag) + (invisible-headers mh-invisible-headers) + (visible-headers mh-visible-headers)) + (when (and charset (stringp charset)) + (setq charset (intern (downcase charset))) + (when (eq charset 'us-ascii) + (setq charset nil))) + (save-excursion + (save-restriction + (narrow-to-region b b) + (mm-insert-part handle) + (mh-mime-display + (or (gethash handle (mh-mime-handles-cache (mh-buffer-data))) + (setf (gethash handle (mh-mime-handles-cache (mh-buffer-data))) + (let ((handles (or (mm-dissect-buffer nil) + (mm-uu-dissect)))) + (setf (mh-mime-handles (mh-buffer-data)) + (mm-merge-handles + handles (mh-mime-handles (mh-buffer-data)))) + handles)))) + + (goto-char (point-min)) + (cond (clean-message-header + (mh-clean-msg-header (point-min) + invisible-headers + visible-headers) + (goto-char (point-min))) + (t + (mh-start-of-uncleaned-message))) + (mh-show-xface) + (mh-show-addr) + ;; The other highlighting types don't need anything special + (when (eq mh-highlight-citation-p 'gnus) + (mh-gnus-article-highlight-citation)) + (goto-char (point-min)) + (insert "\n------- Forwarded Message\n\n") + (mh-display-smileys) + (mh-display-emphasis) + (mm-handle-set-undisplayer + handle + `(lambda () + (let (buffer-read-only) + (if (fboundp 'remove-specifier) + ;; This is only valid on XEmacs. + (mapcar (lambda (prop) + (remove-specifier + (face-property 'default prop) (current-buffer))) + '(background background-pixmap foreground))) + (delete-region ,(point-min-marker) ,(point-max-marker))))))))) + +(provide 'mh-mime) + +;;; Local Variables: +;;; indent-tabs-mode: nil +;;; sentence-end-double-space: nil +;;; End: + +;;; mh-mime.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mh-e/mh-pick.el Sun Jan 26 02:38:37 2003 +0000 @@ -0,0 +1,239 @@ +;;; mh-pick.el --- make a search pattern and search for a message in MH-E + +;; Copyright (C) 1993, 1995, 2001 Free Software Foundation, Inc. + +;; Author: Bill Wohler <wohler@newt.com> +;; Maintainer: Bill Wohler <wohler@newt.com> +;; Keywords: mail +;; See: mh-e.el + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Internal support for MH-E package. + +;;; Change Log: + +;; $Id: mh-pick.el,v 1.10 2003/01/08 23:21:16 wohler Exp $ + +;;; Code: + +(require 'mh-e) +(require 'easymenu) +(require 'gnus-util) + +;;; Internal variables: + +(defvar mh-pick-mode-map (make-sparse-keymap) + "Keymap for searching folder.") + +(defvar mh-searching-folder nil) ;Folder this pick is searching. + +;;;###mh-autoload +(defun mh-search-folder (folder) + "Search FOLDER for messages matching a pattern. +This function uses the MH command `pick' to do the work. +Add the messages found to the sequence named `search'." + (interactive (list (mh-prompt-for-folder "Search" + mh-current-folder + t))) + (switch-to-buffer-other-window "pick-pattern") + (if (or (zerop (buffer-size)) + (not (y-or-n-p "Reuse pattern? "))) + (mh-make-pick-template) + (message "")) + (setq mh-searching-folder folder) + (message "%s" (substitute-command-keys + (concat "Type \\[mh-do-pick-search] to search messages, " + "\\[mh-help] for help.")))) + +(defun mh-make-pick-template () + "Initialize the current buffer with a template for a pick pattern." + (erase-buffer) + (insert "From: \n" + "To: \n" + "Cc: \n" + "Date: \n" + "Subject: \n" + "---------\n") + (mh-pick-mode) + (goto-char (point-min)) + (end-of-line)) + +;;; Menu extracted from mh-menubar.el V1.1 (31 July 2001) +(easy-menu-define + mh-pick-menu mh-pick-mode-map "Menu for MH-E pick-mode" + '("Pick" + ["Execute the Search" mh-do-pick-search t])) + + +;;; Help Messages +;;; Group messages logically, more or less. +(defvar mh-pick-mode-help-messages + '((nil + "Search messages: \\[mh-do-pick-search]\n" + "Move to a field by typing C-c C-f C-<field>\n" + "where <field> is the first letter of the desired field.")) + "Key binding cheat sheet. + +This is an associative array which is used to show the most common commands. +The key is a prefix char. The value is one or more strings which are +concatenated together and displayed in the minibuffer if ? is pressed after +the prefix character. The special key nil is used to display the +non-prefixed commands. + +The substitutions described in `substitute-command-keys' are performed as +well.") + +(put 'mh-pick-mode 'mode-class 'special) + +(define-derived-mode mh-pick-mode fundamental-mode "MH-Pick" + "Mode for creating search templates in MH-E.\\<mh-pick-mode-map> + +After each field name, enter the pattern to search for. If a field's +value does not matter for the search, leave it empty. To search the +entire message, supply the pattern in the \"body\" of the template. +Each non-empty field must be matched for a message to be selected. +To effect a logical \"or\", use \\[mh-search-folder] multiple times. +When you have finished, type \\[mh-do-pick-search] to do the search. + +The value of `mh-pick-mode-hook' is a list of functions to be called, +with no arguments, upon entry to this mode. + +\\{mh-pick-mode-map}" + + (make-local-variable 'mh-searching-folder) + (easy-menu-add mh-pick-menu) + (make-local-variable 'mh-help-messages) + (setq mh-help-messages mh-pick-mode-help-messages) + (run-hooks 'mh-pick-mode-hook)) + +;;;###mh-autoload +(defun mh-do-pick-search () + "Find messages that match the qualifications in the current pattern buffer. +Messages are searched for in the folder named in `mh-searching-folder'. +Add the messages found to the sequence named `search'." + (interactive) + (let ((pattern-buffer (buffer-name)) + (searching-buffer mh-searching-folder) + range + msgs + (pattern nil) + (new-buffer nil)) + (save-excursion + (cond ((get-buffer searching-buffer) + (set-buffer searching-buffer) + (setq range (list (format "%d-%d" + mh-first-msg-num mh-last-msg-num)))) + (t + (mh-make-folder searching-buffer) + (setq range '("all")) + (setq new-buffer t)))) + (message "Searching...") + (goto-char (point-min)) + (while (and range + (setq pattern (mh-next-pick-field pattern-buffer))) + (setq msgs (mh-seq-from-command searching-buffer + 'search + (mh-list-to-string + (list "pick" pattern searching-buffer + "-list" + (mh-coalesce-msg-list range))))) + (setq range msgs)) ;restrict the pick range for next pass + (message "Searching...done") + (if new-buffer + (mh-scan-folder searching-buffer msgs) + (switch-to-buffer searching-buffer)) + (mh-add-msgs-to-seq msgs 'search) + (delete-other-windows))) + +(defun mh-seq-from-command (folder seq command) + "In FOLDER, make a sequence named SEQ by executing COMMAND. +COMMAND is a list. The first element is a program name +and the subsequent elements are its arguments, all strings." + (let ((msg) + (msgs ()) + (case-fold-search t)) + (save-excursion + (save-window-excursion + (if (eq 0 (apply 'mh-exec-cmd-quiet nil command)) + ;; "pick" outputs one number per line + (while (setq msg (car (mh-read-msg-list))) + (setq msgs (cons msg msgs)) + (forward-line 1)))) + (set-buffer folder) + (setq msgs (nreverse msgs)) ;put in ascending order + msgs))) + +(defun mh-next-pick-field (buffer) + "Return the next piece of a pick argument extracted from BUFFER. +Return a list like (\"--fieldname\" \"pattern\") or (\"-search\" \"bodypat\") +or nil if no pieces remain." + (set-buffer buffer) + (let ((case-fold-search t)) + (cond ((eobp) + nil) + ((re-search-forward "^\\([a-z][^: \t\n]*\\):[ \t]*\\([a-z0-9].*\\)$" + nil t) + (let* ((component + (format "--%s" + (downcase (buffer-substring (match-beginning 1) + (match-end 1))))) + (pat (buffer-substring (match-beginning 2) (match-end 2)))) + (forward-line 1) + (list component pat))) + ((re-search-forward "^-*$" nil t) + (forward-char 1) + (let ((body (buffer-substring (point) (point-max)))) + (if (and (> (length body) 0) (not (equal body "\n"))) + (list "-search" body) + nil))) + (t + nil)))) + + + +;;; Build the pick-mode keymap: +;;; If this changes, modify mh-pick-mode-help-messages accordingly, above. +(gnus-define-keys mh-pick-mode-map + "\C-c?" mh-help + "\C-c\C-c" mh-do-pick-search + "\C-c\C-f\C-b" mh-to-field + "\C-c\C-f\C-c" mh-to-field + "\C-c\C-f\C-d" mh-to-field + "\C-c\C-f\C-f" mh-to-field + "\C-c\C-f\C-r" mh-to-field + "\C-c\C-f\C-s" mh-to-field + "\C-c\C-f\C-t" mh-to-field + "\C-c\C-fb" mh-to-field + "\C-c\C-fc" mh-to-field + "\C-c\C-fd" mh-to-field + "\C-c\C-ff" mh-to-field + "\C-c\C-fr" mh-to-field + "\C-c\C-fs" mh-to-field + "\C-c\C-ft" mh-to-field) + +(provide 'mh-pick) + +;;; Local Variables: +;;; indent-tabs-mode: nil +;;; sentence-end-double-space: nil +;;; End: + +;;; mh-pick.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mh-e/mh-seq.el Sun Jan 26 02:38:37 2003 +0000 @@ -0,0 +1,1277 @@ +;;; mh-seq.el --- MH-E sequences support + +;; Copyright (C) 1993, 1995, 2001, 2002 Free Software Foundation, Inc. + +;; Author: Bill Wohler <wohler@newt.com> +;; Maintainer: Bill Wohler <wohler@newt.com> +;; Keywords: mail +;; See: mh-e.el + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: +;; +;; This tries to implement the algorithm described at: +;; http://www.jwz.org/doc/threading.html +;; It is also a start to implementing the IMAP Threading extension RFC. The +;; implementation lacks the reference and subject canonicalization of the +;; RFC. +;; +;; In the presentation buffer, children messages are shown indented with +;; either [ ] or < > around them. Square brackets ([ ]) denote that the +;; algorithm can point out some headers which when taken together implies +;; that the unindented message is an ancestor of the indented message. If +;; no such proof exists then angles (< >) are used. +;; +;; Some issues and problems are as follows: +;; +;; (1) Scan truncates the fields at length 512. So longer references: +;; headers get mutilated. The same kind of MH format string works when +;; composing messages. Is there a way to avoid this? My scan command +;; is as follows: +;; scan +folder -width 10000 \ +;; -format "%(msg)\n%{message-id}\n%{references}\n%{subject}\n" +;; I would really appreciate it if someone would help me with this. +;; +;; (2) Implement heuristics to recognize message-id's in In-Reply-To: +;; header. Right now it just assumes that the last text between angles +;; (< and >) is the message-id. There is the chance that this will +;; incorrectly use an email address like a message-id. +;; +;; (3) Error checking of found message-id's should be done. +;; +;; (4) Since this breaks the assumption that message indices increase as +;; one goes down the buffer, the binary search based mh-goto-msg +;; doesn't work. I have a simpler replacement which may be less +;; efficient. +;; +;; (5) Better canonicalizing for message-id and subject strings. +;; + +;; Internal support for MH-E package. + +;;; Change Log: + +;; $Id: mh-seq.el,v 1.10 2003/01/08 23:21:16 wohler Exp $ + +;;; Code: + +(require 'cl) +(require 'mh-e) + +;; Shush the byte-compiler +(defvar tool-bar-mode) + +;;; Data structures (used in message threading)... +(defstruct (mh-thread-message (:conc-name mh-message-) + (:constructor mh-thread-make-message)) + (id nil) + (references ()) + (subject "") + (subject-re-p nil)) + +(defstruct (mh-thread-container (:conc-name mh-container-) + (:constructor mh-thread-make-container)) + message parent children + (real-child-p t)) + + +;;; Internal variables: +(defvar mh-last-seq-used nil + "Name of seq to which a msg was last added.") + +(defvar mh-non-seq-mode-line-annotation nil + "Saved value of `mh-mode-line-annotation' when narrowed to a seq.") + +;;; Maps and hashes... +(defvar mh-thread-id-hash nil + "Hashtable used to canonicalize message-id strings.") +(defvar mh-thread-subject-hash nil + "Hashtable used to canonicalize subject strings.") +(defvar mh-thread-id-table nil + "Thread ID table maps from message-id's to message containers.") +(defvar mh-thread-id-index-map nil + "Table to lookup message index number from message-id.") +(defvar mh-thread-index-id-map nil + "Table to lookup message-id from message index.") +(defvar mh-thread-scan-line-map nil + "Map of message index to various parts of the scan line.") +(defvar mh-thread-old-scan-line-map nil + "Old map of message index to various parts of the scan line. +This is the original map that is stored when the folder is narrowed.") +(defvar mh-thread-subject-container-hash nil + "Hashtable used to group messages by subject.") +(defvar mh-thread-duplicates nil + "Hashtable used to remember multiple messages with the same message-id.") +(defvar mh-thread-history () + "Variable to remember the transformations to the thread tree. +When new messages are added, these transformations are rewound, then the +links are added from the newly seen messages. Finally the transformations are +redone to get the new thread tree. This makes incremental threading easier.") +(defvar mh-thread-body-width nil + "Width of scan substring that contains subject and body of message.") + +(make-variable-buffer-local 'mh-thread-id-hash) +(make-variable-buffer-local 'mh-thread-subject-hash) +(make-variable-buffer-local 'mh-thread-id-table) +(make-variable-buffer-local 'mh-thread-id-index-map) +(make-variable-buffer-local 'mh-thread-index-id-map) +(make-variable-buffer-local 'mh-thread-scan-line-map) +(make-variable-buffer-local 'mh-thread-old-scan-line-map) +(make-variable-buffer-local 'mh-thread-subject-container-hash) +(make-variable-buffer-local 'mh-thread-duplicates) +(make-variable-buffer-local 'mh-thread-history) + +;;;###mh-autoload +(defun mh-delete-seq (sequence) + "Delete the SEQUENCE." + (interactive (list (mh-read-seq-default "Delete" t))) + (mh-map-to-seq-msgs 'mh-notate-if-in-one-seq sequence ? (1+ mh-cmd-note) + sequence) + (mh-undefine-sequence sequence '("all")) + (mh-delete-seq-locally sequence)) + +;; Avoid compiler warnings +(defvar view-exit-action) + +;;;###mh-autoload +(defun mh-list-sequences () + "List the sequences defined in the folder being visited." + (interactive) + (let ((folder mh-current-folder) + (temp-buffer mh-temp-sequences-buffer) + (seq-list mh-seq-list) + (max-len 0)) + (with-output-to-temp-buffer temp-buffer + (save-excursion + (set-buffer temp-buffer) + (erase-buffer) + (message "Listing sequences ...") + (insert "Sequences in folder " folder ":\n") + (let ((seq-list seq-list)) + (while seq-list + (setq max-len + (max (length (symbol-name (mh-seq-name (pop seq-list)))) + max-len))) + (setq max-len (+ 2 max-len))) + (while seq-list + (let ((name (mh-seq-name (car seq-list))) + (sorted-seq-msgs + (mh-coalesce-msg-list + (sort (copy-sequence (mh-seq-msgs (car seq-list))) '<))) + name-spec) + (insert (setq name-spec (format (format "%%%ss:" max-len) name))) + (while sorted-seq-msgs + (let ((next-element (format " %s" (pop sorted-seq-msgs)))) + (when (>= (+ (current-column) (length next-element)) + (window-width)) + (insert "\n") + (insert (format (format "%%%ss" (length name-spec)) ""))) + (insert next-element))) + (insert "\n")) + (setq seq-list (cdr seq-list))) + (goto-char (point-min)) + (view-mode 1) + (setq view-exit-action 'kill-buffer) + (message "Listing sequences...done"))))) + +;;;###mh-autoload +(defun mh-msg-is-in-seq (message) + "Display the sequences that contain MESSAGE (default: current message)." + (interactive (list (mh-get-msg-num t))) + (let* ((dest-folder (loop for seq in mh-refile-list + when (member message (cdr seq)) return (car seq))) + (deleted-flag (unless dest-folder (member message mh-delete-list)))) + (message "Message %d%s is in sequences: %s" + message + (cond (dest-folder (format " (to be refiled to %s)" dest-folder)) + (deleted-flag (format " (to be deleted)")) + (t "")) + (mapconcat 'concat + (mh-list-to-string (mh-seq-containing-msg message t)) + " ")))) + +;;;###mh-autoload +(defun mh-narrow-to-seq (sequence) + "Restrict display of this folder to just messages in SEQUENCE. +Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command." + (interactive (list (mh-read-seq "Narrow to" t))) + (with-mh-folder-updating (t) + (cond ((mh-seq-to-msgs sequence) + (mh-widen) + (mh-remove-all-notation) + (let ((eob (point-max)) + (msg-at-cursor (mh-get-msg-num nil))) + (setq mh-thread-old-scan-line-map mh-thread-scan-line-map) + (setq mh-thread-scan-line-map (make-hash-table :test #'eql)) + (mh-copy-seq-to-eob sequence) + (narrow-to-region eob (point-max)) + (mh-notate-user-sequences) + (mh-notate-deleted-and-refiled) + (mh-notate-seq 'cur mh-note-cur mh-cmd-note) + (when msg-at-cursor (mh-goto-msg msg-at-cursor t t)) + (make-variable-buffer-local 'mh-non-seq-mode-line-annotation) + (setq mh-non-seq-mode-line-annotation mh-mode-line-annotation) + (setq mh-mode-line-annotation (symbol-name sequence)) + (mh-make-folder-mode-line) + (mh-recenter nil) + (if (and (boundp 'tool-bar-mode) tool-bar-mode) + (set (make-local-variable 'tool-bar-map) + mh-folder-seq-tool-bar-map)) + (setq mh-narrowed-to-seq sequence) + (push 'widen mh-view-ops))) + (t + (error "No messages in sequence `%s'" (symbol-name sequence)))))) + +;;;###mh-autoload +(defun mh-put-msg-in-seq (msg-or-seq sequence) + "Add MSG-OR-SEQ (default: displayed message) to SEQUENCE. +If optional prefix argument provided, then prompt for the message sequence. +If variable `transient-mark-mode' is non-nil and the mark is active, then +the selected region is added to the sequence." + (interactive (list (cond + ((mh-mark-active-p t) + (mh-region-to-msg-list (region-beginning) (region-end))) + (current-prefix-arg + (mh-read-seq-default "Add messages from" t)) + (t + (mh-get-msg-num t))) + (mh-read-seq-default "Add to" nil))) + (if (not (mh-internal-seq sequence)) + (setq mh-last-seq-used sequence)) + (mh-add-msgs-to-seq (cond ((numberp msg-or-seq) (list msg-or-seq)) + ((listp msg-or-seq) msg-or-seq) + (t (mh-seq-to-msgs msg-or-seq))) + sequence)) + +(defun mh-valid-view-change-operation-p (op) + "Check if the view change operation can be performed. +OP is one of 'widen and 'unthread." + (cond ((eq (car mh-view-ops) op) + (pop mh-view-ops)) + (t nil))) + +;;;###mh-autoload +(defun mh-widen () + "Remove restrictions from current folder, thereby showing all messages." + (interactive) + (let ((msg (mh-get-msg-num nil))) + (when mh-narrowed-to-seq + (cond ((mh-valid-view-change-operation-p 'widen) nil) + ((memq 'widen mh-view-ops) + (while (not (eq (car mh-view-ops) 'widen)) + (setq mh-view-ops (cdr mh-view-ops))) + (pop mh-view-ops)) + (t (error "Widening is not applicable"))) + (when (memq 'unthread mh-view-ops) + (setq mh-thread-scan-line-map mh-thread-old-scan-line-map)) + (with-mh-folder-updating (t) + (delete-region (point-min) (point-max)) + (widen) + (setq mh-mode-line-annotation mh-non-seq-mode-line-annotation) + (mh-make-folder-mode-line)) + (if msg + (mh-goto-msg msg t t)) + (mh-notate-deleted-and-refiled) + (mh-notate-user-sequences) + (mh-notate-seq 'cur mh-note-cur mh-cmd-note) + (mh-recenter nil))) + (if (and (boundp 'tool-bar-mode) tool-bar-mode) + (set (make-local-variable 'tool-bar-map) mh-folder-tool-bar-map)) + (setq mh-narrowed-to-seq nil)) + +;; FIXME? We may want to clear all notations and add one for current-message +;; and process user sequences. +(defun mh-notate-deleted-and-refiled () + "Notate messages marked for deletion or refiling. +Messages to be deleted are given by `mh-delete-list' while messages to be +refiled are present in `mh-refile-list'." + (mh-mapc #'(lambda (msg) (mh-notate msg mh-note-deleted mh-cmd-note)) + mh-delete-list) + (mh-mapc #'(lambda (dest-msg-list) + ;; foreach folder name, get the keyed sequence from mh-seq-list + (let ((msg-list (cdr dest-msg-list))) + (mh-mapc #'(lambda (msg) + (mh-notate msg mh-note-refiled mh-cmd-note)) + msg-list))) + mh-refile-list)) + + + +;;; Commands to manipulate sequences. Sequences are stored in an alist +;;; of the form: +;;; ((seq-name msgs ...) (seq-name msgs ...) ...) + +(defun mh-read-seq-default (prompt not-empty) + "Read and return sequence name with default narrowed or previous sequence. +PROMPT is the prompt to use when reading. If NOT-EMPTY is non-nil then a +non-empty sequence is read." + (mh-read-seq prompt not-empty + (or mh-narrowed-to-seq + mh-last-seq-used + (car (mh-seq-containing-msg (mh-get-msg-num nil) nil))))) + +(defun mh-read-seq (prompt not-empty &optional default) + "Read and return a sequence name. +Prompt with PROMPT, raise an error if the sequence is empty and the NOT-EMPTY +flag is non-nil, and supply an optional DEFAULT sequence. A reply of '%' +defaults to the first sequence containing the current message." + (let* ((input (completing-read (format "%s %s %s" prompt "sequence:" + (if default + (format "[%s] " default) + "")) + (mh-seq-names mh-seq-list))) + (seq (cond ((equal input "%") + (car (mh-seq-containing-msg (mh-get-msg-num t) nil))) + ((equal input "") default) + (t (intern input)))) + (msgs (mh-seq-to-msgs seq))) + (if (and (null msgs) not-empty) + (error "No messages in sequence `%s'" seq)) + seq)) + +(defun mh-seq-names (seq-list) + "Return an alist containing the names of the SEQ-LIST." + (mapcar (lambda (entry) (list (symbol-name (mh-seq-name entry)))) + seq-list)) + +;;;###mh-autoload +(defun mh-rename-seq (sequence new-name) + "Rename SEQUENCE to have NEW-NAME." + (interactive (list (mh-read-seq "Old" t) + (intern (read-string "New sequence name: ")))) + (let ((old-seq (mh-find-seq sequence))) + (or old-seq + (error "Sequence %s does not exist" sequence)) + ;; create new sequence first, since it might raise an error. + (mh-define-sequence new-name (mh-seq-msgs old-seq)) + (mh-undefine-sequence sequence (mh-seq-msgs old-seq)) + (rplaca old-seq new-name))) + +;;;###mh-autoload +(defun mh-map-to-seq-msgs (func seq &rest args) + "Invoke the FUNC at each message in the SEQ. +SEQ can either be a list of messages or a MH sequence. The remaining ARGS are +passed as arguments to FUNC." + (save-excursion + (let ((msgs (if (listp seq) seq (mh-seq-to-msgs seq)))) + (while msgs + (if (mh-goto-msg (car msgs) t t) + (apply func (car msgs) args)) + (setq msgs (cdr msgs)))))) + +;;;###mh-autoload +(defun mh-notate-seq (seq notation offset) + "Mark the scan listing. +All messages in SEQ are marked with NOTATION at OFFSET from the beginning of +the line." + (mh-map-to-seq-msgs 'mh-notate seq notation offset)) + +;;;###mh-autoload +(defun mh-add-to-sequence (seq msgs) + "The sequence SEQ is augmented with the messages in MSGS." + ;; Add to a SEQUENCE each message the list of MSGS. + (if (not (mh-folder-name-p seq)) + (if msgs + (apply 'mh-exec-cmd "mark" mh-current-folder "-add" + "-sequence" (symbol-name seq) + (mh-coalesce-msg-list msgs))))) + +;; This has a tricky bug. mh-map-to-seq-msgs uses mh-goto-msg, which assumes +;; that the folder buffer is sorted. However in this case that assumption +;; doesn't hold. So we will do this the dumb way. +;(defun mh-copy-seq-to-point (seq location) +; ;; Copy the scan listing of the messages in SEQUENCE to after the point +; ;; LOCATION in the current buffer. +; (mh-map-to-seq-msgs 'mh-copy-line-to-point seq location)) + +(defun mh-copy-seq-to-eob (seq) + "Copy SEQ to the end of the buffer." + ;; It is quite involved to write something which will work at any place in + ;; the buffer, so we will write something which works only at the end of + ;; the buffer. If we ever need to insert sequences in the middle of the + ;; buffer, this will need to be fixed. + (save-excursion + (let* ((msgs (mh-seq-to-msgs seq)) + (coalesced-msgs (mh-coalesce-msg-list msgs))) + (goto-char (point-max)) + (save-restriction + (narrow-to-region (point) (point)) + (mh-regenerate-headers coalesced-msgs t) + (cond ((memq 'unthread mh-view-ops) + ;; Populate restricted scan-line map + (goto-char (point-min)) + (while (not (eobp)) + (let ((msg (mh-get-msg-num nil))) + (when (numberp msg) + (setf (gethash msg mh-thread-scan-line-map) + (mh-thread-parse-scan-line)))) + (forward-line)) + ;; Remove scan lines and read results from pre-computed tree + (delete-region (point-min) (point-max)) + (let ((thread-tree (mh-thread-generate mh-current-folder ())) + (mh-thread-body-width + (- (window-width) mh-cmd-note + (1- mh-scan-field-subject-start-offset))) + (mh-thread-last-ancestor nil)) + (mh-thread-generate-scan-lines thread-tree -2))) + (mh-index-data + (mh-index-insert-folder-headers))))))) + +(defun mh-copy-line-to-point (msg location) + "Copy current message line to a specific location. +The argument MSG is not used. The message in the current line is copied to +LOCATION." + ;; msg is not used? + ;; Copy the current line to the LOCATION in the current buffer. + (beginning-of-line) + (save-excursion + (let ((beginning-of-line (point)) + end) + (forward-line 1) + (setq end (point)) + (goto-char location) + (insert-buffer-substring (current-buffer) beginning-of-line end)))) + +;;;###mh-autoload +(defun mh-region-to-msg-list (begin end) + "Return a list of messages within the region between BEGIN and END." + (save-excursion + ;; If end is end of buffer back up one position + (setq end (if (equal end (point-max)) (1- end) end)) + (goto-char begin) + (let ((result ())) + (while (<= (point) end) + (let ((index (mh-get-msg-num nil))) + (when (numberp index) (push index result))) + (forward-line 1)) + result))) + + + +;;; Commands to handle new 'subject sequence. +;;; Or "Poor man's threading" by psg. + +(defun mh-subject-to-sequence (all) + "Put all following messages with same subject in sequence 'subject. +If arg ALL is t, move to beginning of folder buffer to collect all messages. +If arg ALL is nil, collect only messages fron current one on forward. + +Return number of messages put in the sequence: + + nil -> there was no subject line. + 0 -> there were no later messages with the same subject (sequence not made) + >1 -> the total number of messages including current one." + (if (not (eq major-mode 'mh-folder-mode)) + (error "Not in a folder buffer")) + (save-excursion + (beginning-of-line) + (if (or (not (looking-at mh-scan-subject-regexp)) + (not (match-string 3)) + (string-equal "" (match-string 3))) + (progn (message "No subject line.") + nil) + (let ((subject (match-string-no-properties 3)) + (list)) + (if (> (length subject) 41) + (setq subject (substring subject 0 41))) + (save-excursion + (if all + (goto-char (point-min))) + (while (re-search-forward mh-scan-subject-regexp nil t) + (let ((this-subject (match-string-no-properties 3))) + (if (> (length this-subject) 41) + (setq this-subject (substring this-subject 0 41))) + (if (string-equal this-subject subject) + (setq list (cons (mh-get-msg-num t) list)))))) + (cond + (list + ;; If we created a new sequence, add the initial message to it too. + (if (not (member (mh-get-msg-num t) list)) + (setq list (cons (mh-get-msg-num t) list))) + (if (member '("subject") (mh-seq-names mh-seq-list)) + (mh-delete-seq 'subject)) + ;; sort the result into a sequence + (let ((sorted-list (sort (copy-sequence list) 'mh-lessp))) + (while sorted-list + (mh-add-msgs-to-seq (car sorted-list) 'subject nil) + (setq sorted-list (cdr sorted-list))) + (safe-length list))) + (t + 0)))))) + +;;;###mh-autoload +(defun mh-narrow-to-subject () + "Narrow to a sequence containing all following messages with same subject." + (interactive) + (let ((num (mh-get-msg-num nil)) + (count (mh-subject-to-sequence t))) + (cond + ((not count) ; No subject line, delete msg anyway + nil) + ((= 0 count) ; No other msgs, delete msg anyway. + (message "No other messages with same Subject following this one.") + nil) + (t ; We have a subject sequence. + (message "Found %d messages for subject sequence." count) + (mh-narrow-to-seq 'subject) + (if (numberp num) + (mh-goto-msg num t t)))))) + +;;;###mh-autoload +(defun mh-delete-subject () + "Mark all following messages with same subject to be deleted. +This puts the messages in a sequence named subject. You can undo the last +deletion marks using `mh-undo' with a prefix argument and then specifying the +subject sequence." + (interactive) + (let ((count (mh-subject-to-sequence nil))) + (cond + ((not count) ; No subject line, delete msg anyway + (mh-delete-msg (mh-get-msg-num t))) + ((= 0 count) ; No other msgs, delete msg anyway. + (message "No other messages with same Subject following this one.") + (mh-delete-msg (mh-get-msg-num t))) + (t ; We have a subject sequence. + (message "Marked %d messages for deletion" count) + (mh-delete-msg 'subject))))) + +;;;###mh-autoload +(defun mh-delete-subject-or-thread () + "Mark messages for deletion intelligently. +If the folder is threaded then `mh-thread-delete' is used to mark the current +message and all its descendants for deletion. Otherwise `mh-delete-subject' is +used to mark the current message and all messages following it with the same +subject for deletion." + (interactive) + (if (memq 'unthread mh-view-ops) + (mh-thread-delete) + (mh-delete-subject))) + +;;; Message threading: + +(defun mh-thread-initialize () + "Make hash tables, otherwise clear them." + (cond + (mh-thread-id-hash + (clrhash mh-thread-id-hash) + (clrhash mh-thread-subject-hash) + (clrhash mh-thread-id-table) + (clrhash mh-thread-id-index-map) + (clrhash mh-thread-index-id-map) + (clrhash mh-thread-scan-line-map) + (clrhash mh-thread-subject-container-hash) + (clrhash mh-thread-duplicates) + (setq mh-thread-history ())) + (t (setq mh-thread-id-hash (make-hash-table :test #'equal)) + (setq mh-thread-subject-hash (make-hash-table :test #'equal)) + (setq mh-thread-id-table (make-hash-table :test #'eq)) + (setq mh-thread-id-index-map (make-hash-table :test #'eq)) + (setq mh-thread-index-id-map (make-hash-table :test #'eql)) + (setq mh-thread-scan-line-map (make-hash-table :test #'eql)) + (setq mh-thread-subject-container-hash (make-hash-table :test #'eq)) + (setq mh-thread-duplicates (make-hash-table :test #'eq)) + (setq mh-thread-history ())))) + +(defsubst mh-thread-id-container (id) + "Given ID, return the corresponding container in `mh-thread-id-table'. +If no container exists then a suitable container is created and the id-table +is updated." + (when (not id) + (error "1")) + (or (gethash id mh-thread-id-table) + (setf (gethash id mh-thread-id-table) + (let ((message (mh-thread-make-message :id id))) + (mh-thread-make-container :message message))))) + +(defsubst mh-thread-remove-parent-link (child) + "Remove parent link of CHILD if it exists." + (let* ((child-container (if (mh-thread-container-p child) + child (mh-thread-id-container child))) + (parent-container (mh-container-parent child-container))) + (when parent-container + (setf (mh-container-children parent-container) + (loop for elem in (mh-container-children parent-container) + unless (eq child-container elem) collect elem)) + (setf (mh-container-parent child-container) nil)))) + +(defsubst mh-thread-add-link (parent child &optional at-end-p) + "Add links so that PARENT becomes a parent of CHILD. +Doesn't make any changes if CHILD is already an ancestor of PARENT. If +optional argument AT-END-P is non-nil, the CHILD is added to the end of the +children list of PARENT." + (let ((parent-container (cond ((null parent) nil) + ((mh-thread-container-p parent) parent) + (t (mh-thread-id-container parent)))) + (child-container (if (mh-thread-container-p child) + child (mh-thread-id-container child)))) + (when (and parent-container + (not (mh-thread-ancestor-p child-container parent-container)) + (not (mh-thread-ancestor-p parent-container child-container))) + (mh-thread-remove-parent-link child-container) + (cond ((not at-end-p) + (push child-container (mh-container-children parent-container))) + ((null (mh-container-children parent-container)) + (push child-container (mh-container-children parent-container))) + (t (let ((last-child (mh-container-children parent-container))) + (while (cdr last-child) + (setq last-child (cdr last-child))) + (setcdr last-child (cons child-container nil))))) + (setf (mh-container-parent child-container) parent-container)) + (unless parent-container + (mh-thread-remove-parent-link child-container)))) + +(defun mh-thread-ancestor-p (ancestor successor) + "Return t if ANCESTOR is really an ancestor of SUCCESSOR and nil otherwise. +In the limit, the function returns t if ANCESTOR and SUCCESSOR are the same +containers." + (block nil + (while successor + (when (eq ancestor successor) (return t)) + (setq successor (mh-container-parent successor))) + nil)) + +(defsubst mh-thread-get-message-container (message) + "Return container which has MESSAGE in it. +If there is no container present then a new container is allocated." + (let* ((id (mh-message-id message)) + (container (gethash id mh-thread-id-table))) + (cond (container (setf (mh-container-message container) message) + container) + (t (setf (gethash id mh-thread-id-table) + (mh-thread-make-container :message message)))))) + +(defsubst mh-thread-get-message (id subject-re-p subject refs) + "Return appropriate message. +Otherwise update message already present to have the proper ID, SUBJECT-RE-P, +SUBJECT and REFS fields." + (let* ((container (gethash id mh-thread-id-table)) + (message (if container (mh-container-message container) nil))) + (cond (message + (setf (mh-message-subject-re-p message) subject-re-p) + (setf (mh-message-subject message) subject) + (setf (mh-message-id message) id) + (setf (mh-message-references message) refs) + message) + (container + (setf (mh-container-message container) + (mh-thread-make-message :subject subject + :subject-re-p subject-re-p + :id id :references refs))) + (t (let ((message (mh-thread-make-message + :subject subject + :subject-re-p subject-re-p + :id id :references refs))) + (prog1 message + (mh-thread-get-message-container message))))))) + +(defsubst mh-thread-canonicalize-id (id) + "Produce canonical string representation for ID. +This allows cheap string comparison with EQ." + (or (and (equal id "") (copy-sequence "")) + (gethash id mh-thread-id-hash) + (setf (gethash id mh-thread-id-hash) id))) + +(defsubst mh-thread-prune-subject (subject) + "Prune leading Re:'s, Fwd:'s etc. and trailing (fwd)'s from SUBJECT. +If the result after pruning is not the empty string then it is canonicalized +so that subjects can be tested for equality with eq. This is done so that all +the messages without a subject are not put into a single thread." + (let ((case-fold-search t) + (subject-pruned-flag nil)) + ;; Prune subject leader + (while (or (string-match "^[ \t]*\\(re\\|fwd?\\)\\(\\[[0-9]*\\]\\)?:[ \t]*" + subject) + (string-match "^[ \t]*\\[[^\\]][ \t]*" subject)) + (setq subject-pruned-flag t) + (setq subject (substring subject (match-end 0)))) + ;; Prune subject trailer + (while (or (string-match "(fwd)$" subject) + (string-match "[ \t]+$" subject)) + (setq subject-pruned-flag t) + (setq subject (substring subject 0 (match-beginning 0)))) + ;; Canonicalize subject only if it is non-empty + (cond ((equal subject "") (values subject subject-pruned-flag)) + (t (values + (or (gethash subject mh-thread-subject-hash) + (setf (gethash subject mh-thread-subject-hash) subject)) + subject-pruned-flag))))) + +(defun mh-thread-container-subject (container) + "Return the subject of CONTAINER. +If CONTAINER is empty return the subject info of one of its children." + (cond ((and (mh-container-message container) + (mh-message-id (mh-container-message container))) + (mh-message-subject (mh-container-message container))) + (t (block nil + (dolist (kid (mh-container-children container)) + (when (and (mh-container-message kid) + (mh-message-id (mh-container-message kid))) + (let ((kid-message (mh-container-message kid))) + (return (mh-message-subject kid-message))))) + (error "This can't happen!"))))) + +(defun mh-thread-rewind-pruning () + "Restore the thread tree to its state before pruning." + (while mh-thread-history + (let ((action (pop mh-thread-history))) + (cond ((eq (car action) 'DROP) + (mh-thread-remove-parent-link (cadr action)) + (mh-thread-add-link (caddr action) (cadr action))) + ((eq (car action) 'PROMOTE) + (let ((node (cadr action)) + (parent (caddr action)) + (children (cdddr action))) + (dolist (child children) + (mh-thread-remove-parent-link child) + (mh-thread-add-link node child)) + (mh-thread-add-link parent node))) + ((eq (car action) 'SUBJECT) + (let ((node (cadr action))) + (mh-thread-remove-parent-link node) + (setf (mh-container-real-child-p node) t))))))) + +(defun mh-thread-prune-containers (roots) + "Prune empty containers in the containers ROOTS." + (let ((dfs-ordered-nodes ()) + (work-list roots)) + (while work-list + (let ((node (pop work-list))) + (dolist (child (mh-container-children node)) + (push child work-list)) + (push node dfs-ordered-nodes))) + (while dfs-ordered-nodes + (let ((node (pop dfs-ordered-nodes))) + (cond ((gethash (mh-message-id (mh-container-message node)) + mh-thread-id-index-map) + ;; Keep it + (setf (mh-container-children node) + (mh-thread-sort-containers (mh-container-children node)))) + ((and (mh-container-children node) + (or (null (cdr (mh-container-children node))) + (mh-container-parent node))) + ;; Promote kids + (let ((children ())) + (dolist (kid (mh-container-children node)) + (mh-thread-remove-parent-link kid) + (mh-thread-add-link (mh-container-parent node) kid) + (push kid children)) + (push `(PROMOTE ,node ,(mh-container-parent node) ,@children) + mh-thread-history) + (mh-thread-remove-parent-link node))) + ((mh-container-children node) + ;; Promote the first orphan to parent and add the other kids as + ;; his children + (setf (mh-container-children node) + (mh-thread-sort-containers (mh-container-children node))) + (let ((new-parent (car (mh-container-children node))) + (other-kids (cdr (mh-container-children node)))) + (mh-thread-remove-parent-link new-parent) + (dolist (kid other-kids) + (mh-thread-remove-parent-link kid) + (setf (mh-container-real-child-p kid) nil) + (mh-thread-add-link new-parent kid t)) + (push `(PROMOTE ,node ,(mh-container-parent node) + ,new-parent ,@other-kids) + mh-thread-history) + (mh-thread-remove-parent-link node))) + (t + ;; Drop it + (push `(DROP ,node ,(mh-container-parent node)) + mh-thread-history) + (mh-thread-remove-parent-link node))))) + (let ((results ())) + (maphash #'(lambda (k v) + (declare (ignore k)) + (when (and (null (mh-container-parent v)) + (gethash (mh-message-id (mh-container-message v)) + mh-thread-id-index-map)) + (push v results))) + mh-thread-id-table) + (mh-thread-sort-containers results)))) + +(defun mh-thread-sort-containers (containers) + "Sort a list of message CONTAINERS to be in ascending order wrt index." + (sort containers + #'(lambda (x y) + (when (and (mh-container-message x) (mh-container-message y)) + (let* ((id-x (mh-message-id (mh-container-message x))) + (id-y (mh-message-id (mh-container-message y))) + (index-x (gethash id-x mh-thread-id-index-map)) + (index-y (gethash id-y mh-thread-id-index-map))) + (and (integerp index-x) (integerp index-y) + (< index-x index-y))))))) + +(defsubst mh-thread-group-by-subject (roots) + "Group the set of message containers, ROOTS based on subject. +Bug: Check for and make sure that something without Re: is made the parent in +preference to something that has it." + (clrhash mh-thread-subject-container-hash) + (let ((results ())) + (dolist (root roots) + (let* ((subject (mh-thread-container-subject root)) + (parent (gethash subject mh-thread-subject-container-hash))) + (cond (parent (mh-thread-remove-parent-link root) + (mh-thread-add-link parent root t) + (setf (mh-container-real-child-p root) nil) + (push `(SUBJECT ,root) mh-thread-history)) + (t + (setf (gethash subject mh-thread-subject-container-hash) root) + (push root results))))) + (nreverse results))) + +(defsubst mh-thread-process-in-reply-to (reply-to-header) + "Extract message id's from REPLY-TO-HEADER. +Ideally this should have some regexp which will try to guess if a string +between < and > is a message id and not an email address. For now it will +take the last string inside angles." + (let ((end (mh-search-from-end ?> reply-to-header))) + (when (numberp end) + (let ((begin (mh-search-from-end ?< (substring reply-to-header 0 end)))) + (when (numberp begin) + (list (substring reply-to-header begin (1+ end)))))))) + +(defun mh-thread-set-tables (folder) + "Use the tables of FOLDER in current buffer." + (flet ((mh-get-table (symbol) + (save-excursion + (set-buffer folder) + (symbol-value symbol)))) + (setq mh-thread-id-hash (mh-get-table 'mh-thread-id-hash)) + (setq mh-thread-subject-hash (mh-get-table 'mh-thread-subject-hash)) + (setq mh-thread-id-table (mh-get-table 'mh-thread-id-table)) + (setq mh-thread-id-index-map (mh-get-table 'mh-thread-id-index-map)) + (setq mh-thread-index-id-map (mh-get-table 'mh-thread-index-id-map)) + (setq mh-thread-scan-line-map (mh-get-table 'mh-thread-scan-line-map)) + (setq mh-thread-subject-container-hash + (mh-get-table 'mh-thread-subject-container-hash)) + (setq mh-thread-duplicates (mh-get-table 'mh-thread-duplicates)) + (setq mh-thread-history (mh-get-table 'mh-thread-history)))) + +(defsubst mh-thread-update-id-index-maps (id index) + "Message with id, ID is the message in INDEX. +The function also checks for duplicate messages (that is multiple messages +with the same ID). These messages are put in the `mh-thread-duplicates' hash +table." + (let ((old-index (gethash id mh-thread-id-index-map))) + (when old-index (push old-index (gethash id mh-thread-duplicates))) + (setf (gethash id mh-thread-id-index-map) index) + (setf (gethash index mh-thread-index-id-map) id))) + + + +;;; Generate Threads... + +(defun mh-thread-generate (folder msg-list) + "Scan FOLDER to get info for threading. +Only information about messages in MSG-LIST are added to the tree." + (save-excursion + (set-buffer (get-buffer-create "*mh-thread*")) + (mh-thread-set-tables folder) + (erase-buffer) + (when msg-list + (apply + #'call-process (expand-file-name mh-scan-prog mh-progs) nil '(t nil) nil + "-width" "10000" "-format" + "%(msg)\n%{message-id}\n%{references}\n%{in-reply-to}\n%{subject}\n" + folder (mapcar #'(lambda (x) (format "%s" x)) msg-list))) + (goto-char (point-min)) + (let ((roots ()) + (case-fold-search t)) + (block nil + (while (not (eobp)) + (block process-message + (let* ((index-line + (prog1 (buffer-substring (point) (line-end-position)) + (forward-line))) + (index (car (read-from-string index-line))) + (id (prog1 (buffer-substring (point) (line-end-position)) + (forward-line))) + (refs (prog1 (buffer-substring (point) (line-end-position)) + (forward-line))) + (in-reply-to (prog1 (buffer-substring (point) + (line-end-position)) + (forward-line))) + (subject (prog1 + (buffer-substring (point) (line-end-position)) + (forward-line))) + (subject-re-p nil)) + (unless (gethash index mh-thread-scan-line-map) + (return-from process-message)) + (unless (integerp index) (return)) ;Error message here + (multiple-value-setq (subject subject-re-p) + (mh-thread-prune-subject subject)) + (setq in-reply-to (mh-thread-process-in-reply-to in-reply-to)) + (setq refs (append (split-string refs) in-reply-to)) + (setq id (mh-thread-canonicalize-id id)) + (mh-thread-update-id-index-maps id index) + (setq refs (mapcar #'mh-thread-canonicalize-id refs)) + (mh-thread-get-message id subject-re-p subject refs) + (do ((ancestors refs (cdr ancestors))) + ((null (cdr ancestors)) + (when (car ancestors) + (mh-thread-remove-parent-link id) + (mh-thread-add-link (car ancestors) id))) + (mh-thread-add-link (car ancestors) (cadr ancestors))))))) + (maphash #'(lambda (k v) + (declare (ignore k)) + (when (null (mh-container-parent v)) + (push v roots))) + mh-thread-id-table) + (setq roots (mh-thread-prune-containers roots)) + (prog1 (setq roots (mh-thread-group-by-subject roots)) + (let ((history mh-thread-history)) + (set-buffer folder) + (setq mh-thread-history history)))))) + +;;;###mh-autoload +(defun mh-thread-inc (folder start-point) + "Update thread tree for FOLDER. +All messages after START-POINT are added to the thread tree." + (mh-thread-rewind-pruning) + (goto-char start-point) + (let ((msg-list ())) + (while (not (eobp)) + (let ((index (mh-get-msg-num nil))) + (when (numberp index) + (push index msg-list) + (setf (gethash index mh-thread-scan-line-map) + (mh-thread-parse-scan-line))) + (forward-line))) + (let ((thread-tree (mh-thread-generate folder msg-list)) + (buffer-read-only nil) + (old-buffer-modified-flag (buffer-modified-p))) + (delete-region (point-min) (point-max)) + (let ((mh-thread-body-width (- (window-width) mh-cmd-note + (1- mh-scan-field-subject-start-offset))) + (mh-thread-last-ancestor nil)) + (mh-thread-generate-scan-lines thread-tree -2)) + (mh-notate-user-sequences) + (mh-notate-deleted-and-refiled) + (mh-notate-seq 'cur mh-note-cur mh-cmd-note) + (set-buffer-modified-p old-buffer-modified-flag)))) + +(defvar mh-thread-last-ancestor) + +(defun mh-thread-generate-scan-lines (tree level) + "Generate scan lines. +TREE is the hierarchical tree of messages, SCAN-LINE-MAP maps message indices +to the corresponding scan lines and LEVEL used to determine indentation of +the message." + (cond ((null tree) nil) + ((mh-thread-container-p tree) + (let* ((message (mh-container-message tree)) + (id (mh-message-id message)) + (index (gethash id mh-thread-id-index-map)) + (duplicates (gethash id mh-thread-duplicates)) + (new-level (+ level 2)) + (dupl-flag t) + (force-angle-flag nil) + (increment-level-flag nil)) + (dolist (scan-line (mapcar (lambda (x) + (gethash x mh-thread-scan-line-map)) + (reverse (cons index duplicates)))) + (when scan-line + (when (and dupl-flag (equal level 0) + (mh-thread-ancestor-p mh-thread-last-ancestor tree)) + (setq level (+ level 2) + new-level (+ new-level 2) + force-angle-flag t)) + (when (equal level 0) + (setq mh-thread-last-ancestor tree) + (while (mh-container-parent mh-thread-last-ancestor) + (setq mh-thread-last-ancestor + (mh-container-parent mh-thread-last-ancestor)))) + (insert (car scan-line) + (format (format "%%%ss" + (if dupl-flag level new-level)) "") + (if (and (mh-container-real-child-p tree) dupl-flag + (not force-angle-flag)) + "[" "<") + (cadr scan-line) + (if (and (mh-container-real-child-p tree) dupl-flag + (not force-angle-flag)) + "]" ">") + (truncate-string-to-width + (caddr scan-line) (- mh-thread-body-width + (if dupl-flag level new-level))) + "\n") + (setq increment-level-flag t) + (setq dupl-flag nil))) + (unless increment-level-flag (setq new-level level)) + (dolist (child (mh-container-children tree)) + (mh-thread-generate-scan-lines child new-level)))) + (t (let ((nlevel (+ level 2))) + (dolist (ch tree) + (mh-thread-generate-scan-lines ch nlevel)))))) + +;; Another and may be better approach would be to generate all the info from +;; the scan which generates the threading info. For now this will have to do. +(defun mh-thread-parse-scan-line (&optional string) + "Parse a scan line. +If optional argument STRING is given then that is assumed to be the scan line. +Otherwise uses the line at point as the scan line to parse." + (let* ((string (or string + (buffer-substring-no-properties (line-beginning-position) + (line-end-position)))) + (first-string (substring string 0 (+ mh-cmd-note 8)))) + (setf (elt first-string mh-cmd-note) ? ) + (when (equal (elt first-string (1+ mh-cmd-note)) (elt mh-note-seq 0)) + (setf (elt first-string (1+ mh-cmd-note)) ? )) + (list first-string + (substring string + (+ mh-cmd-note mh-scan-field-from-start-offset) + (+ mh-cmd-note mh-scan-field-from-end-offset -2)) + (substring string (+ mh-cmd-note mh-scan-field-from-end-offset)) + string))) + +;;;###mh-autoload +(defun mh-thread-add-spaces (count) + "Add COUNT spaces to each scan line in `mh-thread-scan-line-map'." + (let ((spaces (format (format "%%%ss" count) ""))) + (while (not (eobp)) + (let* ((msg-num (mh-get-msg-num nil)) + (old-line (nth 3 (gethash msg-num mh-thread-scan-line-map)))) + (when (numberp msg-num) + (setf (gethash msg-num mh-thread-scan-line-map) + (mh-thread-parse-scan-line (format "%s%s" spaces old-line))))) + (forward-line 1)))) + +(defun mh-thread-folder () + "Generate thread view of folder." + (message "Threading %s..." (buffer-name)) + (mh-thread-initialize) + (goto-char (point-min)) + (while (not (eobp)) + (let ((index (mh-get-msg-num nil))) + (when (numberp index) + (setf (gethash index mh-thread-scan-line-map) + (mh-thread-parse-scan-line)))) + (forward-line)) + (let* ((range (format "%s-%s" mh-first-msg-num mh-last-msg-num)) + (thread-tree (mh-thread-generate (buffer-name) (list range)))) + (delete-region (point-min) (point-max)) + (let ((mh-thread-body-width (- (window-width) mh-cmd-note + (1- mh-scan-field-subject-start-offset))) + (mh-thread-last-ancestor nil)) + (mh-thread-generate-scan-lines thread-tree -2)) + (mh-notate-user-sequences) + (mh-notate-deleted-and-refiled) + (mh-notate-seq 'cur mh-note-cur mh-cmd-note) + (message "Threading %s...done" (buffer-name)))) + +;;;###mh-autoload +(defun mh-toggle-threads () + "Toggle threaded view of folder. +The conversion of normal view to threaded view is exact, that is the same +messages are displayed in the folder buffer before and after threading. However +the conversion from threaded view to normal view is inexact. So more messages +than were originally present may be shown as a result." + (interactive) + (let ((msg-at-point (mh-get-msg-num nil)) + (old-buffer-modified-flag (buffer-modified-p)) + (buffer-read-only nil)) + (cond ((and (memq 'unthread mh-view-ops) mh-narrowed-to-seq) + (unless (mh-valid-view-change-operation-p 'unthread) + (error "Can't unthread folder")) + (mh-scan-folder mh-current-folder + (format "%s" mh-narrowed-to-seq) + t) + (when mh-index-data + (mh-index-insert-folder-headers))) + ((memq 'unthread mh-view-ops) + (unless (mh-valid-view-change-operation-p 'unthread) + (error "Can't unthread folder")) + (mh-scan-folder mh-current-folder + (format "%s-%s" mh-first-msg-num mh-last-msg-num) + t) + (when mh-index-data + (mh-index-insert-folder-headers))) + (t (mh-thread-folder) + (push 'unthread mh-view-ops))) + (when msg-at-point (mh-goto-msg msg-at-point t t)) + (set-buffer-modified-p old-buffer-modified-flag) + (mh-recenter nil))) + +;;;###mh-autoload +(defun mh-thread-forget-message (index) + "Forget the message INDEX from the threading tables." + (let* ((id (gethash index mh-thread-index-id-map)) + (id-index (gethash id mh-thread-id-index-map)) + (duplicates (gethash id mh-thread-duplicates))) + (remhash index mh-thread-index-id-map) + (cond ((and (eql index id-index) (null duplicates)) + (remhash id mh-thread-id-index-map)) + ((eql index id-index) + (setf (gethash id mh-thread-id-index-map) (car duplicates)) + (setf (gethash (car duplicates) mh-thread-index-id-map) id) + (setf (gethash id mh-thread-duplicates) (cdr duplicates))) + (t + (setf (gethash id mh-thread-duplicates) + (remove index duplicates)))))) + + + +;;; Operations on threads + +(defun mh-thread-current-indentation-level () + "Find the number of spaces by which current message is indented." + (save-excursion + (let ((address-start-offset (+ mh-cmd-note mh-scan-date-flag-width + mh-scan-date-width 1)) + (level 0)) + (beginning-of-line) + (forward-char address-start-offset) + (while (char-equal (char-after) ? ) + (incf level) + (forward-char)) + level))) + +;;;###mh-autoload +(defun mh-thread-next-sibling (&optional previous-flag) + "Jump to next sibling. +With non-nil optional argument PREVIOUS-FLAG jump to the previous sibling." + (interactive) + (cond ((not (memq 'unthread mh-view-ops)) + (error "Folder isn't threaded")) + ((eobp) + (error "No message at point"))) + (beginning-of-line) + (let ((point (point)) + (done nil) + (my-level (mh-thread-current-indentation-level))) + (while (and (not done) + (equal (forward-line (if previous-flag -1 1)) 0) + (not (eobp))) + (let ((level (mh-thread-current-indentation-level))) + (cond ((equal level my-level) + (setq done 'success)) + ((< level my-level) + (message "No %s sibling" (if previous-flag "previous" "next")) + (setq done 'failure))))) + (cond ((eq done 'success) (mh-maybe-show)) + ((eq done 'failure) (goto-char point)) + (t (message "No %s sibling" (if previous-flag "previous" "next")) + (goto-char point))))) + +;;;###mh-autoload +(defun mh-thread-previous-sibling () + "Jump to previous sibling." + (interactive) + (mh-thread-next-sibling t)) + +(defun mh-thread-immediate-ancestor () + "Jump to immediate ancestor in thread tree." + (beginning-of-line) + (let ((point (point)) + (ancestor-level (- (mh-thread-current-indentation-level) 2)) + (done nil)) + (if (< ancestor-level 0) + nil + (while (and (not done) (equal (forward-line -1) 0)) + (when (equal ancestor-level (mh-thread-current-indentation-level)) + (setq done t))) + (unless done + (goto-char point)) + done))) + +;;;###mh-autoload +(defun mh-thread-ancestor (&optional thread-root-flag) + "Jump to the ancestor of current message. +If optional argument THREAD-ROOT-FLAG is non-nil then jump to the root of the +thread tree the message belongs to." + (interactive "P") + (beginning-of-line) + (cond ((not (memq 'unthread mh-view-ops)) + (error "Folder isn't threaded")) + ((eobp) + (error "No message at point"))) + (let ((current-level (mh-thread-current-indentation-level))) + (cond (thread-root-flag + (while (mh-thread-immediate-ancestor)) + (mh-maybe-show)) + ((equal current-level 1) + (message "Message has no ancestor")) + (t (mh-thread-immediate-ancestor) + (mh-maybe-show))))) + +(defun mh-thread-find-children () + "Return a region containing the current message and its children. +The result is returned as a list of two elements. The first is the point at the +start of the region and the second is the point at the end." + (beginning-of-line) + (if (eobp) + nil + (let ((address-start-offset (+ mh-cmd-note mh-scan-date-flag-width + mh-scan-date-width 1)) + (level (mh-thread-current-indentation-level)) + spaces begin) + (setq begin (point)) + (setq spaces (format (format "%%%ss" (1+ level)) "")) + (forward-line) + (block nil + (while (not (eobp)) + (forward-char address-start-offset) + (unless (equal (string-match spaces (buffer-substring-no-properties + (point) (line-end-position))) + 0) + (beginning-of-line) + (backward-char) + (return)) + (forward-line))) + (list begin (point))))) + +;;;###mh-autoload +(defun mh-thread-delete () + "Mark current message and all its children for subsequent deletion." + (interactive) + (cond ((not (memq 'unthread mh-view-ops)) + (error "Folder isn't threaded")) + ((eobp) + (error "No message at point")) + (t (mh-delete-msg + (apply #'mh-region-to-msg-list (mh-thread-find-children)))))) + +;; This doesn't handle mh-default-folder-for-message-function. We should +;; refactor that code so that we don't copy it. +;;;###mh-autoload +(defun mh-thread-refile (folder) + "Mark current message and all its children for refiling to FOLDER." + (interactive (list + (intern (mh-prompt-for-folder + "Destination" + (cond ((eq 'refile (car mh-last-destination-folder)) + (symbol-name (cdr mh-last-destination-folder))) + (t "")) + t)))) + (cond ((not (memq 'unthread mh-view-ops)) + (error "Folder isn't threaded")) + ((eobp) + (error "No message at point")) + (t (mh-refile-msg + (apply #'mh-region-to-msg-list (mh-thread-find-children)) + folder)))) + +(provide 'mh-seq) + +;;; Local Variables: +;;; indent-tabs-mode: nil +;;; sentence-end-double-space: nil +;;; End: + +;;; mh-seq.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mh-e/mh-speed.el Sun Jan 26 02:38:37 2003 +0000 @@ -0,0 +1,573 @@ +;;; mh-speed.el --- Speedbar interface for MH-E. + +;; Copyright (C) 2002 Free Software Foundation, Inc. + +;; Author: Satyaki Das <satyaki@theforce.stanford.edu> +;; Maintainer: Bill Wohler <wohler@newt.com> +;; Keywords: mail +;; See: mh-e.el + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: +;; Future versions should only use flists. + +;; Speedbar support for MH-E package. + +;;; Change Log: + +;; $Id: mh-speed.el,v 1.2 2003/01/08 23:21:16 wohler Exp $ + +;;; Code: + +;; Requires +(require 'cl) +(require 'mh-e) +(require 'speedbar) + +;; Global variables +(defvar mh-speed-refresh-flag nil) +(defvar mh-speed-last-selected-folder nil) +(defvar mh-speed-folder-map (make-hash-table :test #'equal)) +(defvar mh-speed-folders-cache (make-hash-table :test #'equal)) +(defvar mh-speed-flists-cache (make-hash-table :test #'equal)) +(defvar mh-speed-flists-process nil) +(defvar mh-speed-flists-timer nil) +(defvar mh-speed-partial-line "") + +;; Add our stealth update function +(unless (member 'mh-speed-stealth-update + (cdr (assoc "files" speedbar-stealthy-function-list))) + ;; Is changing constant lists in elisp safe? + (setq speedbar-stealthy-function-list + (copy-tree speedbar-stealthy-function-list)) + (push 'mh-speed-stealth-update + (cdr (assoc "files" speedbar-stealthy-function-list)))) + +;; Functions called by speedbar to initialize display... +;;;###mh-autoload +(defun mh-folder-speedbar-buttons (buffer) + "Interface function to create MH-E speedbar buffer. +BUFFER is the MH-E buffer for which the speedbar buffer is to be created." + (unless (get-text-property (point-min) 'mh-level) + (erase-buffer) + (clrhash mh-speed-folder-map) + (speedbar-make-tag-line 'bracket ?+ 'mh-speed-toggle nil " " 'ignore nil + 'mh-speedbar-folder-face 0) + (forward-line -1) + (setf (gethash nil mh-speed-folder-map) + (set-marker (make-marker) (1+ (line-beginning-position)))) + (add-text-properties + (line-beginning-position) (1+ (line-beginning-position)) + `(mh-folder nil mh-expanded nil mh-children-p t mh-level 0)) + (mh-speed-stealth-update t) + (when mh-speed-run-flists-flag + (mh-speed-flists nil)))) + +;;;###mh-autoload +(defalias 'mh-show-speedbar-buttons 'mh-folder-speedbar-buttons) +;;;###mh-autoload +(defalias 'mh-letter-speedbar-buttons 'mh-folder-speedbar-buttons) + +;; Keymaps for speedbar... +(defvar mh-folder-speedbar-key-map (speedbar-make-specialized-keymap) + "Specialized speedbar keymap for MH-E buffers.") +(gnus-define-keys mh-folder-speedbar-key-map + "+" mh-speed-expand-folder + "-" mh-speed-contract-folder + "\r" mh-speed-view + "f" mh-speed-flists + "i" mh-speed-invalidate-map) + +(defvar mh-show-speedbar-key-map mh-folder-speedbar-key-map) +(defvar mh-letter-speedbar-key-map mh-folder-speedbar-key-map) + +;; Menus for speedbar... +(defvar mh-folder-speedbar-menu-items + '(["Visit Folder" mh-speed-view + (save-excursion + (set-buffer speedbar-buffer) + (get-text-property (line-beginning-position) 'mh-folder))] + ["Expand nested folders" mh-speed-expand-folder + (and (get-text-property (line-beginning-position) 'mh-children-p) + (not (get-text-property (line-beginning-position) 'mh-expanded)))] + ["Contract nested folders" mh-speed-contract-folder + (and (get-text-property (line-beginning-position) 'mh-children-p) + (get-text-property (line-beginning-position) 'mh-expanded))] + ["Run Flists" mh-speed-flists t] + ["Invalidate cached folders" mh-speed-invalidate-map t]) + "Extra menu items for speedbar.") + +(defvar mh-show-speedbar-menu-items mh-folder-speedbar-menu-items) +(defvar mh-letter-speedbar-menu-items mh-folder-speedbar-menu-items) + +(defmacro mh-speed-select-attached-frame () + "Compatibility macro to handle speedbar versions 0.11a and 0.14beta4." + (cond ((fboundp 'dframe-select-attached-frame) + '(dframe-select-attached-frame speedbar-frame)) + ((boundp 'speedbar-attached-frame) + '(select-frame speedbar-attached-frame)) + (t (error "Installed speedbar version not supported by MH-E")))) + +(defun mh-speed-update-current-folder (force) + "Update speedbar highlighting of the current folder. +The function tries to be smart so that work done is minimized. The currently +highlighted folder is cached and no highlighting happens unless it changes. +Also highlighting is suspended while the speedbar frame is selected. +Otherwise you get the disconcerting behavior of folders popping open on their +own when you are trying to navigate around in the speedbar buffer. + +The update is always carried out if FORCE is non-nil." + (let* ((lastf (selected-frame)) + (newcf (save-excursion + (mh-speed-select-attached-frame) + (prog1 (mh-speed-extract-folder-name (buffer-name)) + (select-frame lastf)))) + (lastb (current-buffer)) + (case-fold-search t)) + (when (or force + (and mh-speed-refresh-flag (not (eq lastf speedbar-frame))) + (and (stringp newcf) + (equal (substring newcf 0 1) "+") + (not (equal newcf mh-speed-last-selected-folder)))) + (setq mh-speed-refresh-flag nil) + (select-frame speedbar-frame) + (set-buffer speedbar-buffer) + + ;; Remove highlight from previous match... + (mh-speed-highlight mh-speed-last-selected-folder + 'mh-speedbar-folder-face) + + ;; If we found a match highlight it... + (when (mh-speed-goto-folder newcf) + (mh-speed-highlight newcf 'mh-speedbar-selected-folder-face)) + + (setq mh-speed-last-selected-folder newcf) + (speedbar-position-cursor-on-line) + (set-window-point (frame-first-window speedbar-frame) (point)) + (set-buffer lastb) + (select-frame lastf)) + (when (eq lastf speedbar-frame) + (setq mh-speed-refresh-flag t)))) + +(defun mh-speed-normal-face (face) + "Return normal face for given FACE." + (cond ((eq face 'mh-speedbar-folder-with-unseen-messages-face) + 'mh-speedbar-folder-face) + ((eq face 'mh-speedbar-selected-folder-with-unseen-messages-face) + 'mh-speedbar-selected-folder-face) + (t face))) + +(defun mh-speed-bold-face (face) + "Return bold face for given FACE." + (cond ((eq face 'mh-speedbar-folder-face) + 'mh-speedbar-folder-with-unseen-messages-face) + ((eq face 'mh-speedbar-selected-folder-face) + 'mh-speedbar-selected-folder-with-unseen-messages-face) + (t face))) + +(defun mh-speed-highlight (folder face) + "Set FOLDER to FACE." + (save-excursion + (speedbar-with-writable + (goto-char (gethash folder mh-speed-folder-map (point))) + (beginning-of-line) + (if (re-search-forward "([1-9][0-9]*/[0-9]+)" (line-end-position) t) + (setq face (mh-speed-bold-face face)) + (setq face (mh-speed-normal-face face))) + (beginning-of-line) + (when (re-search-forward "\\[.\\] " (line-end-position) t) + (put-text-property (point) (line-end-position) 'face face))))) + +(defun mh-speed-stealth-update (&optional force) + "Do stealth update. +With non-nil FORCE, the update is always carried out." + (cond ((save-excursion (set-buffer speedbar-buffer) + (get-text-property (point-min) 'mh-level)) + ;; Execute this hook and *don't* run anything else + (mh-speed-update-current-folder force) + nil) + ;; Otherwise on to your regular programming + (t t))) + +(defun mh-speed-goto-folder (folder) + "Move point to line containing FOLDER. +The function will expand out parent folders of FOLDER if needed." + (let ((prefix folder) + (suffix-list ()) + (last-slash t)) + (while (and (not (gethash prefix mh-speed-folder-map)) last-slash) + (setq last-slash (mh-search-from-end ?/ prefix)) + (when (integerp last-slash) + (push (substring prefix (1+ last-slash)) suffix-list) + (setq prefix (substring prefix 0 last-slash)))) + (let ((prefix-position (gethash prefix mh-speed-folder-map))) + (if prefix-position + (goto-char prefix-position) + (goto-char (point-min)) + (mh-speed-toggle) + (unless (get-text-property (point) 'mh-expanded) + (mh-speed-toggle)) + (goto-char (gethash prefix mh-speed-folder-map)))) + (while suffix-list + ;; We always need atleast one toggle. We need two if the directory list + ;; is stale since a folder was added. + (when (equal prefix (get-text-property (line-beginning-position) + 'mh-folder)) + (mh-speed-toggle) + (unless (get-text-property (point) 'mh-expanded) + (mh-speed-toggle))) + (setq prefix (format "%s/%s" prefix (pop suffix-list))) + (goto-char (gethash prefix mh-speed-folder-map (point)))) + (beginning-of-line) + (equal folder (get-text-property (point) 'mh-folder)))) + +(defun mh-speed-extract-folder-name (buffer) + "Given an MH-E BUFFER find the folder that should be highlighted. +Do the right thing for the different kinds of buffers that MH-E uses." + (save-excursion + (set-buffer buffer) + (cond ((eq major-mode 'mh-folder-mode) + mh-current-folder) + ((eq major-mode 'mh-show-mode) + (set-buffer mh-show-folder-buffer) + mh-current-folder) + ((eq major-mode 'mh-letter-mode) + (when (string-match mh-user-path buffer-file-name) + (let* ((rel-path (substring buffer-file-name (match-end 0))) + (directory-end (mh-search-from-end ?/ rel-path))) + (when directory-end + (format "+%s" (substring rel-path 0 directory-end))))))))) + +(defun mh-speed-add-buttons (folder level) + "Add speedbar button for FOLDER which is at indented by LEVEL amount." + (let ((folder-list (mh-speed-folders folder))) + (mapc + (lambda (f) + (let* ((folder-name (format "%s%s%s" (or folder "+") + (if folder "/" "") (car f))) + (counts (gethash folder-name mh-speed-flists-cache))) + (speedbar-with-writable + (speedbar-make-tag-line + 'bracket (if (cdr f) ?+ ? ) + 'mh-speed-toggle nil + (format "%s%s" + (car f) + (if counts + (format " (%s/%s)" (car counts) (cdr counts)) + "")) + 'mh-speed-view nil + (if (and counts (> (car counts) 0)) + 'mh-speedbar-folder-with-unseen-messages-face + 'mh-speedbar-folder-face) + level) + (save-excursion + (forward-line -1) + (setf (gethash folder-name mh-speed-folder-map) + (set-marker (make-marker) (1+ (line-beginning-position)))) + (add-text-properties + (line-beginning-position) (1+ (line-beginning-position)) + `(mh-folder ,folder-name + mh-expanded nil + mh-children-p ,(not (not (cdr f))) + ,@(if counts `(mh-count + (,(car counts) . ,(cdr counts))) ()) + mh-level ,level)))))) + folder-list))) + +;;;###mh-autoload +(defun mh-speed-toggle (&rest args) + "Toggle the display of child folders. +The otional ARGS are ignored and there for compatibilty with speedbar." + (interactive) + (declare (ignore args)) + (beginning-of-line) + (let ((parent (get-text-property (point) 'mh-folder)) + (kids-p (get-text-property (point) 'mh-children-p)) + (expanded (get-text-property (point) 'mh-expanded)) + (level (get-text-property (point) 'mh-level)) + (point (point)) + start-region) + (speedbar-with-writable + (cond ((not kids-p) nil) + (expanded + (forward-line) + (setq start-region (point)) + (while (and (get-text-property (point) 'mh-level) + (> (get-text-property (point) 'mh-level) level)) + (remhash (get-text-property (point) 'mh-folder) + mh-speed-folder-map) + (forward-line)) + (delete-region start-region (point)) + (forward-line -1) + (speedbar-change-expand-button-char ?+) + (add-text-properties + (line-beginning-position) (1+ (line-beginning-position)) + '(mh-expanded nil))) + (t + (forward-line) + (mh-speed-add-buttons parent (1+ level)) + (goto-char point) + (speedbar-change-expand-button-char ?-) + (add-text-properties + (line-beginning-position) (1+ (line-beginning-position)) + `(mh-expanded t))))))) + +(defalias 'mh-speed-expand-folder 'mh-speed-toggle) +(defalias 'mh-speed-contract-folder 'mh-speed-toggle) + +;;;###mh-autoload +(defun mh-speed-view (&rest args) + "View folder on current line. +Optional ARGS are ignored." + (interactive) + (declare (ignore args)) + (let* ((folder (get-text-property (line-beginning-position) 'mh-folder)) + (range (and (stringp folder) (mh-read-msg-range folder)))) + (when (stringp folder) + (speedbar-with-attached-buffer + (mh-visit-folder folder range) + (delete-other-windows))))) + +(defun mh-speed-folders (folder) + "Find the subfolders of FOLDER. +The function avoids running folders unnecessarily by caching the results of +the actual folders call." + (let ((match (gethash folder mh-speed-folders-cache 'no-result))) + (cond ((eq match 'no-result) + (setf (gethash folder mh-speed-folders-cache) + (mh-speed-folders-actual folder))) + (t match)))) + +(defun mh-speed-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." + (let* ((folder (cond ((and (stringp folder) + (equal (substring folder 0 1) "+")) + folder) + (t nil))) + (arg-list `(,(expand-file-name "folders" mh-progs) + nil (t nil) nil "-noheader" "-norecurse" + ,@(if (stringp folder) (list folder) ()))) + (results ())) + (with-temp-buffer + (apply #'call-process arg-list) + (goto-char (point-min)) + (while (not (and (eolp) (bolp))) + (goto-char (line-end-position)) + (let ((has-pos (search-backward " has " (line-beginning-position) t))) + (when (integerp has-pos) + (while (or (equal (char-after has-pos) ? ) + (equal (char-after has-pos) ?+)) + (decf has-pos)) + (incf has-pos) + (let ((name (buffer-substring (line-beginning-position) has-pos))) + (let ((first-char (substring name 0 1))) + (unless (or (string-equal first-char ".") + (string-equal first-char "#") + (string-equal first-char ",")) + (push + (cons name + (search-forward "(others)" (line-end-position) t)) + results))))) + (forward-line 1)))) + (setq results (nreverse results)) + (when (stringp folder) + (setq results (cdr results)) + (let ((folder-name-len (length (format "%s/" (substring folder 1))))) + (setq results (mapcar (lambda (f) + (cons (substring (car f) folder-name-len) + (cdr f))) + results)))) + results)) + +;;;###mh-autoload +(defun mh-speed-flists (force) + "Execute flists -recurse and update message counts. +If FORCE is non-nil the timer is reset." + (interactive (list t)) + (when force + (when (timerp mh-speed-flists-timer) + (cancel-timer mh-speed-flists-timer)) + (setq mh-speed-flists-timer nil) + (when (and (processp mh-speed-flists-process) + (not (eq (process-status mh-speed-flists-process) 'exit))) + (kill-process mh-speed-flists-process) + (setq mh-speed-flists-process nil))) + (unless mh-speed-flists-timer + (setq mh-speed-flists-timer + (run-at-time + nil mh-speed-flists-interval + (lambda () + (unless (and (processp mh-speed-flists-process) + (not (eq (process-status mh-speed-flists-process) + 'exit))) + (setq mh-speed-flists-process + (start-process (expand-file-name "flists" mh-progs) nil + "flists" "-recurse" + "-sequence" (symbol-name mh-unseen-seq))) + (set-process-filter mh-speed-flists-process + 'mh-speed-parse-flists-output))))))) + +;; Copied from mh-make-folder-list-filter... +(defun mh-speed-parse-flists-output (process output) + "Parse the incremental results from flists. +PROCESS is the flists process and OUTPUT is the results that must be handled +next." + (let ((prevailing-match-data (match-data)) + (position 0) + line-end line folder unseen total) + (unwind-protect + (while (setq line-end (string-match "\n" output position)) + (setq line (format "%s%s" + mh-speed-partial-line + (substring output position line-end)) + mh-speed-partial-line "") + (multiple-value-setq (folder unseen total) + (mh-parse-flist-output-line line)) + (when (and folder unseen total) + (setf (gethash folder mh-speed-flists-cache) (cons unseen total)) + (save-excursion + (when (buffer-live-p (get-buffer speedbar-buffer)) + (set-buffer speedbar-buffer) + (speedbar-with-writable + (when (get-text-property (point-min) 'mh-level) + (let ((pos (gethash folder mh-speed-folder-map)) + face) + (when pos + (goto-char pos) + (goto-char (line-beginning-position)) + (cond + ((null (get-text-property (point) 'mh-count)) + (goto-char (line-end-position)) + (setq face (get-text-property (1- (point)) 'face)) + (insert (format " (%s/%s)" unseen total)) + (mh-speed-highlight 'unknown face) + (goto-char (line-beginning-position)) + (add-text-properties (point) (1+ (point)) + `(mh-count (,unseen . ,total)))) + ((not (equal (get-text-property (point) 'mh-count) + (cons unseen total))) + (goto-char (line-end-position)) + (setq face (get-text-property (1- (point)) 'face)) + (re-search-backward " " (line-beginning-position) t) + (delete-region (point) (line-end-position)) + (insert (format " (%s/%s)" unseen total)) + (mh-speed-highlight 'unknown face) + (goto-char (line-beginning-position)) + (add-text-properties + (point) (1+ (point)) + `(mh-count (,unseen . ,total)))))))))))) + (setq position (1+ line-end))) + (set-match-data prevailing-match-data)) + (setq mh-speed-partial-line (substring output position)))) + +;;;###mh-autoload +(defun mh-speed-invalidate-map (folder) + "Remove FOLDER from various optimization caches." + (interactive (list "")) + (save-excursion + (set-buffer speedbar-buffer) + (let* ((speedbar-update-flag nil) + (last-slash (mh-search-from-end ?/ folder)) + (parent (if last-slash (substring folder 0 last-slash) nil)) + (parent-position (gethash parent mh-speed-folder-map)) + (parent-change nil)) + (remhash parent mh-speed-folders-cache) + (remhash folder mh-speed-folders-cache) + (when parent-position + (let ((parent-kids (mh-speed-folders parent))) + (cond ((null parent-kids) + (setq parent-change ?+)) + ((and (null (cdr parent-kids)) + (equal (if last-slash + (substring folder (1+ last-slash)) + (substring folder 1)) + (caar parent-kids))) + (setq parent-change ? )))) + (goto-char parent-position) + (when (equal (get-text-property (line-beginning-position) 'mh-folder) + parent) + (when (get-text-property (line-beginning-position) 'mh-expanded) + (mh-speed-toggle)) + (when parent-change + (speedbar-with-writable + (mh-speedbar-change-expand-button-char parent-change) + (add-text-properties + (line-beginning-position) (1+ (line-beginning-position)) + `(mh-children-p ,(equal parent-change ?+))))) + (mh-speed-highlight mh-speed-last-selected-folder + 'mh-speedbar-folder-face) + (setq mh-speed-last-selected-folder nil) + (setq mh-speed-refresh-flag t))) + (when (equal folder "") + (clrhash mh-speed-folders-cache))))) + +;;;###mh-autoload +(defun mh-speed-add-folder (folder) + "Add FOLDER since it is being created. +The function invalidates the latest ancestor that is present." + (save-excursion + (set-buffer speedbar-buffer) + (let ((speedbar-update-flag nil) + (last-slash (mh-search-from-end ?/ folder)) + (ancestor folder) + (ancestor-pos nil)) + (block while-loop + (while last-slash + (setq ancestor (substring ancestor 0 last-slash)) + (setq ancestor-pos (gethash ancestor mh-speed-folder-map)) + (when ancestor-pos + (return-from while-loop)) + (setq last-slash (mh-search-from-end ?/ ancestor)))) + (unless ancestor-pos (setq ancestor nil)) + (goto-char (or ancestor-pos (gethash nil mh-speed-folder-map))) + (speedbar-with-writable + (mh-speedbar-change-expand-button-char ?+) + (add-text-properties + (line-beginning-position) (1+ (line-beginning-position)) + `(mh-children-p t))) + (when (get-text-property (line-beginning-position) 'mh-expanded) + (mh-speed-toggle)) + (remhash ancestor mh-speed-folders-cache) + (setq mh-speed-refresh-flag t)))) + +;; Make it slightly more general to allow for [ ] buttons to be changed to +;; [+]. +(defun mh-speedbar-change-expand-button-char (char) + "Change the expansion button character to CHAR for the current line." + (save-excursion + (beginning-of-line) + (if (re-search-forward "\\[.\\]" (line-end-position) t) + (speedbar-with-writable + (backward-char 2) + (delete-char 1) + (insert-char char 1 t) + (put-text-property (point) (1- (point)) 'invisible nil) + ;; make sure we fix the image on the text here. + (speedbar-insert-image-button-maybe (- (point) 2) 3))))) + +(provide 'mh-speed) + +;;; Local Variables: +;;; indent-tabs-mode: nil +;;; sentence-end-double-space: nil +;;; End: + +;;; mh-speed.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mh-e/mh-utils.el Sun Jan 26 02:38:37 2003 +0000 @@ -0,0 +1,1879 @@ +;;; mh-utils.el --- MH-E code needed for both sending and reading + +;; Copyright (C) 1993, 1995, 1997, 2000, 2001, 2002 Free Software Foundation, Inc. + +;; Author: Bill Wohler <wohler@newt.com> +;; Maintainer: Bill Wohler <wohler@newt.com> +;; Keywords: mail +;; See: mh-e.el + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Internal support for MH-E package. + +;;; Change Log: + +;; $Id: mh-utils.el,v 1.34 2003/01/08 23:21:16 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.") + +(require 'cl) +(require 'gnus-util) +(require 'font-lock) +(require 'mh-loaddefs) +(require 'mh-customize) + +(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 + +;; Shush the byte-compiler +(defvar font-lock-auto-fontify) +(defvar font-lock-defaults) +(defvar mark-active) +(defvar tool-bar-mode) + +;;; Autoloads +(autoload 'gnus-article-highlight-citation "gnus-cite") +(autoload 'mail-header-end "sendmail") +(autoload 'Info-goto-node "info") +(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." + (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 + +(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: " + +(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 \\( \\)") + +(defvar mh-scan-msg-overflow-regexp "^\\?[0-9]" + "Regexp to find a scan line in which the message number overflowed. +The message's number is left truncated in this case.") + +(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 \\( \\).") + +(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.") + +(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.") + +(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.") + +(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) + +(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. + +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'.") + +;; 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)) + (handles ()) ; List of MIME handles + (handles-cache (make-hash-table)) ; Cache to avoid multiple decodes of + ; nested messages + (parts-count 0) ; The button number is generated from + ; this number + (part-index-hash (make-hash-table))) ; Avoid incrementing the part number + ; for nested messages +;;; This has to be a macro, since we do: (setf (mh-buffer-data) ...) +(defmacro mh-buffer-data () + "Convenience macro to get the MIME data structures of the current buffer." + `(gethash (current-buffer) mh-globals-hash)) + +(defvar mh-globals-hash (make-hash-table) + "Keeps track of MIME data on a per buffer basis.") + +(defvar mh-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 + (lambda (handle) + (mm-valid-and-fit-image-p 'jpeg handle))) + ("image/png" + mm-inline-image + (lambda (handle) + (mm-valid-and-fit-image-p 'png handle))) + ("image/gif" + mm-inline-image + (lambda (handle) + (mm-valid-and-fit-image-p 'gif handle))) + ("image/tiff" + mm-inline-image + (lambda (handle) + (mm-valid-and-fit-image-p 'tiff handle)) ) + ("image/xbm" + mm-inline-image + (lambda (handle) + (mm-valid-and-fit-image-p 'xbm handle))) + ("image/x-xbitmap" + mm-inline-image + (lambda (handle) + (mm-valid-and-fit-image-p 'xbm handle))) + ("image/xpm" + mm-inline-image + (lambda (handle) + (mm-valid-and-fit-image-p 'xpm handle))) + ("image/x-pixmap" + mm-inline-image + (lambda (handle) + (mm-valid-and-fit-image-p 'xpm handle))) + ("image/bmp" + mm-inline-image + (lambda (handle) + (mm-valid-and-fit-image-p 'bmp handle))) + ("image/x-portable-bitmap" + mm-inline-image + (lambda (handle) + (mm-valid-and-fit-image-p 'pbm handle))) + ("text/plain" mm-inline-text identity) + ("text/enriched" mm-inline-text identity) + ("text/richtext" mm-inline-text identity) + ("text/x-patch" mm-display-patch-inline + (lambda (handle) + (locate-library "diff-mode"))) + ("application/emacs-lisp" mm-display-elisp-inline identity) + ("application/x-emacs-lisp" mm-display-elisp-inline identity) + ("text/html" + ,(if (fboundp 'mm-inline-text-html) 'mm-inline-text-html 'mm-inline-text) + (lambda (handle) + (or (and (boundp 'mm-inline-text-html-renderer) + mm-inline-text-html-renderer) + (and (boundp 'mm-text-html-renderer) mm-text-html-renderer)))) + ("text/x-vcard" + mm-inline-text-vcard + (lambda (handle) + (or (featurep 'vcard) + (locate-library "vcard")))) + ("message/delivery-status" mm-inline-text identity) + ("message/rfc822" mh-mm-inline-message identity) + ;;("message/partial" mm-inline-partial identity) + ;;("message/external-body" mm-inline-external-body identity) + ("text/.*" mm-inline-text identity) + ("audio/wav" mm-inline-audio + (lambda (handle) + (and (or (featurep 'nas-sound) (featurep 'native-sound)) + (device-sound-enabled-p)))) + ("audio/au" + mm-inline-audio + (lambda (handle) + (and (or (featurep 'nas-sound) (featurep 'native-sound)) + (device-sound-enabled-p)))) + ("application/pgp-signature" ignore identity) + ("application/x-pkcs7-signature" ignore identity) + ("application/pkcs7-signature" ignore identity) + ("application/x-pkcs7-mime" ignore identity) + ("application/pkcs7-mime" ignore identity) + ("multipart/alternative" ignore identity) + ("multipart/mixed" ignore identity) + ("multipart/related" ignore identity) + ;; Disable audio and image + ("audio/.*" ignore ignore) + ("image/.*" ignore ignore) + ;; Default to displaying as text + (".*" mm-inline-text mm-readable-p)) + "Alist of media types/tests saying whether types can be displayed inline.") + +;; 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 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." + (re-search-backward "[^-_A-z0-9.@]" (line-beginning-position) 'lim) + (if (or (looking-at mh-address-mail-regexp) ; already at start + (and (re-search-forward mh-address-mail-regexp + (line-end-position) 'lim) + (goto-char (match-beginning 0)))) + (match-string-no-properties 0))) + +(defun mh-in-header-p () + "Return non-nil if the point is in the header of a draft message." + (< (point) (mail-header-end))) + +(defun mh-header-field-beginning () + "Move to the beginning of the current header field. +Handles RFC 822 continuation lines." + (beginning-of-line) + (while (looking-at "^[ \t]") + (forward-line -1))) + +(defun mh-header-field-end () + "Move to the end of the current header field. +Handles RFC 822 continuation lines." + (forward-line 1) + (while (looking-at "^[ \t]") + (forward-line 1)) + (backward-char 1)) ;to end of previous line + +(defun mh-letter-header-font-lock (limit) + "Return the entire mail header to font-lock. +Argument LIMIT limits search." + (if (= (point) limit) + nil + (let* ((mail-header-end (save-match-data (mail-header-end))) + (lesser-limit (if (< mail-header-end limit) mail-header-end limit))) + (when (mh-in-header-p) + (set-match-data (list 1 lesser-limit)) + (goto-char lesser-limit) + t)))) + +(defun mh-header-field-font-lock (field limit) + "Return the value of a header field FIELD to font-lock. +Argument LIMIT limits search." + (if (= (point) limit) + nil + (let* ((mail-header-end (mail-header-end)) + (lesser-limit (if (< mail-header-end limit) mail-header-end limit)) + (case-fold-search t)) + (when (and (< (point) mail-header-end) ;Only within header + (re-search-forward (format "^%s" field) lesser-limit t)) + (let ((match-one-b (match-beginning 0)) + (match-one-e (match-end 0))) + (mh-header-field-end) + (if (> (point) limit) ;Don't search for end beyond limit + (goto-char limit)) + (set-match-data (list match-one-b match-one-e + (1+ match-one-e) (point))) + t))))) + +(defun mh-header-to-font-lock (limit) + "Return the value of a header field To to font-lock. +Argument LIMIT limits search." + (mh-header-field-font-lock "To:" limit)) + +(defun mh-header-cc-font-lock (limit) + "Return the value of a header field cc to font-lock. +Argument LIMIT limits search." + (mh-header-field-font-lock "cc:" limit)) + +(defun mh-header-subject-font-lock (limit) + "Return the value of a header field Subject to font-lock. +Argument LIMIT limits search." + (mh-header-field-font-lock "Subject:" limit)) + +(eval-and-compile + ;; Otherwise byte-compilation fails on `mh-show-font-lock-keywords-with-cite' + (defvar mh-show-font-lock-keywords + '(("^\\(From:\\|Sender:\\)\\(.*\\)" (1 'default) (2 mh-show-from-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)) + ("^\\(Reply-To:\\|Return-Path:\\)\\(.*\\)$" + (1 'default) (2 mh-show-from-face)) + (mh-header-subject-font-lock (0 'default) (1 mh-show-subject-face)) + ("^\\(Apparently-To:\\|Newsgroups:\\)\\(.*\\)" + (1 'default) (2 mh-show-cc-face)) + ("^\\(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.")) + +(defvar mh-show-font-lock-keywords-with-cite + (eval-when-compile + (let* ((cite-chars "[>|}]") + (cite-prefix "A-Za-z") + (cite-suffix (concat cite-prefix "0-9_.@-`'\""))) + (append + mh-show-font-lock-keywords + (list + ;; Use MATCH-ANCHORED to effectively anchor the regexp left side. + `(,cite-chars + (,(concat "\\=[ \t]*" + "\\(\\([" cite-prefix "]+[" cite-suffix "]*\\)?" + "\\(" cite-chars "[ \t]*\\)\\)+" + "\\(.*\\)") + (beginning-of-line) (end-of-line) + (2 font-lock-constant-face nil t) + (4 font-lock-comment-face nil t))))))) + "Additional expressions to highlight in MH-show mode.") + +(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))) + (cond + ((and (< beg header-end)(< end header-end)) + (font-lock-default-fontify-region beg end loudly)) + ((and (< beg header-end)(>= end header-end)) + (font-lock-default-fontify-region beg header-end loudly)) + (t + nil)))) + +;; Needed to help shush the byte-compiler. +(if mh-xemacs-flag + (progn + (eval-and-compile + (require 'gnus) + (require 'gnus-art) + (require 'gnus-cite)))) + +(defun mh-gnus-article-highlight-citation () + "Highlight cited text in current buffer using gnus." + (interactive) + ;; Requiring gnus-cite should have been sufficient. However for Emacs21.1, + ;; recursive-load-depth-limit is only 10, so an error occurs. Also it may be + ;; better to have an autoload at top-level (though that won't work because + ;; of recursive-load-depth-limit). That gets rid of a compiler warning as + ;; well. + (unless mh-xemacs-flag + (require 'gnus-art) + (require 'gnus-cite)) + ;; Don't allow Gnus to create buttons while highlighting, maybe this is bad + ;; style? + (flet ((gnus-article-add-button (&rest args) nil)) + (let* ((modified (buffer-modified-p)) + (gnus-article-buffer (buffer-name)) + (gnus-cite-face-list `(,@(cdr gnus-cite-face-list) + ,(car gnus-cite-face-list)))) + (gnus-article-highlight-citation t) + (set-buffer-modified-p modified)))) + +;;; Internal bookkeeping variables: + +;; The value of `mh-folder-list-change-hook' is called whenever +;; mh-folder-list variable is set. +;; List of folder names for completion. +(defvar mh-folder-list nil) + +;; 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) + +;; Cached value of the `Unseen-Sequence:' component in the user's MH profile. +;; Name of the Unseen sequence. +(defvar mh-unseen-seq nil) + +;; Cached value of the `Previous-Sequence:' component in the user's MH +;; profile. +;; Name of the Previous sequence. +(defvar mh-previous-seq nil) + +;; 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) + +;; Name of MH-E scratch buffer. +(defconst mh-temp-buffer " *mh-temp*") + +;; Name of the MH-E folder list buffer. +(defconst mh-temp-folders-buffer "*Folders*") + +;; Name of the MH-E sequences list buffer. +(defconst mh-temp-sequences-buffer "*Sequences*") + +;; Window configuration before MH-E command. +(defvar mh-previous-window-config nil) + +;;Non-nil means next SPC or whatever goes to next undeleted message. +(defvar mh-page-to-next-msg-flag nil) + +;;; Internal variables local to a folder. + +;; Name of current folder, a string. +(defvar mh-current-folder nil) + +;; Buffer that displays message for this folder. +(defvar mh-show-buffer nil) + +;; Full path of directory for this folder. +(defvar mh-folder-filename nil) + +;;Number of msgs in buffer. +(defvar mh-msg-count nil) + +;; If non-nil, show the message in a separate window. +(defvar mh-showing-mode nil) + +(defvar mh-show-mode-map (make-sparse-keymap) + "Keymap used by the show buffer.") + +(defvar mh-show-folder-buffer nil + "Keeps track of folder whose message is being displayed.") + +;;; 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." + (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) + +;; 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) + + +;;; MH-E macros + +(defmacro with-mh-folder-updating (save-modification-flag &rest body) + "Format is (with-mh-folder-updating (SAVE-MODIFICATION-FLAG) &body BODY). +Execute BODY, which can modify the folder buffer without having to +worry about file locking or the read-only flag, and return its result. +If SAVE-MODIFICATION-FLAG is non-nil, the buffer's modification +flag is unchanged, otherwise it is cleared." + (setq save-modification-flag (car save-modification-flag)) ; CL style + `(prog1 + (let ((mh-folder-updating-mod-flag (buffer-modified-p)) + (buffer-read-only nil) + (buffer-file-name nil)) ;don't let the buffer get locked + (prog1 + (progn + ,@body) + (mh-set-folder-modified-p mh-folder-updating-mod-flag))) + ,@(if (not save-modification-flag) + '((mh-set-folder-modified-p nil))))) + +(put 'with-mh-folder-updating 'lisp-indent-hook 1) + +(defmacro mh-in-show-buffer (show-buffer &rest body) + "Format is (mh-in-show-buffer (SHOW-BUFFER) &body BODY). +Display buffer SHOW-BUFFER in other window and execute BODY in it. +Stronger than `save-excursion', weaker than `save-window-excursion'." + (setq show-buffer (car show-buffer)) ; CL style + `(let ((mh-in-show-buffer-saved-window (selected-window))) + (switch-to-buffer-other-window ,show-buffer) + (if mh-bury-show-buffer-flag (bury-buffer (current-buffer))) + (unwind-protect + (progn + ,@body) + (select-window mh-in-show-buffer-saved-window)))) + +(put 'mh-in-show-buffer 'lisp-indent-hook 1) + +(defmacro mh-make-seq (name msgs) + "Create sequence NAME with the given MSGS." + (list 'cons name msgs)) + +(defmacro mh-seq-name (sequence) + "Extract sequence name from the given SEQUENCE." + (list 'car sequence)) + +(defmacro mh-seq-msgs (sequence) + "Extract messages from the given SEQUENCE." + (list 'cdr sequence)) + +(defun mh-recenter (arg) + "Like recenter but with three improvements: +- At the end of the buffer it tries to show fewer empty lines. +- operates only if the current buffer is in the selected window. + (Commands like `save-some-buffers' can make this false.) +- nil ARG means recenter as if prefix argument had been given." + (cond ((not (eq (get-buffer-window (current-buffer)) (selected-window))) + nil) + ((= (point-max) (save-excursion + (forward-line (- (/ (window-height) 2) 2)) + (point))) + (let ((lines-from-end 2)) + (save-excursion + (while (> (point-max) (progn (forward-line) (point))) + (incf lines-from-end))) + (recenter (- lines-from-end)))) + ;; '(4) is the same as C-u prefix argument. + (t (recenter (or arg '(4)))))) + +(defun mh-start-of-uncleaned-message () + "Position uninteresting headers off the top of the window." + (let ((case-fold-search t)) + (re-search-forward + "^To:\\|^Cc:\\|^From:\\|^Subject:\\|^Date:" nil t) + (beginning-of-line) + (mh-recenter 0))) + +(defun mh-invalidate-show-buffer () + "Invalidate the show buffer so we must update it to use it." + (if (get-buffer mh-show-buffer) + (save-excursion + (set-buffer mh-show-buffer) + (mh-unvisit-file)))) + +(defun mh-unvisit-file () + "Separate current buffer from the message file it was visiting." + (or (not (buffer-modified-p)) + (null buffer-file-name) ;we've been here before + (yes-or-no-p (format "Message %s modified; flush changes? " + (file-name-nondirectory buffer-file-name))) + (error "Flushing changes not confirmed")) + (clear-visited-file-modtime) + (unlock-buffer) + (setq buffer-file-name nil)) + +;;;###mh-autoload +(defun mh-get-msg-num (error-if-no-message) + "Return the message number of the displayed message. +If the argument ERROR-IF-NO-MESSAGE is non-nil, then complain if the cursor is +not pointing to a message." + (save-excursion + (beginning-of-line) + (cond ((looking-at mh-scan-msg-number-regexp) + (string-to-int (buffer-substring (match-beginning 1) + (match-end 1)))) + (error-if-no-message + (error "Cursor not pointing to message")) + (t nil)))) + +(defun mh-folder-name-p (name) + "Return non-nil if NAME is the name of a folder. +A name (a string or symbol) can be a folder name if it begins with \"+\"." + (if (symbolp name) + (eq (aref (symbol-name name) 0) ?+) + (and (> (length name) 0) + (eq (aref name 0) ?+)))) + + +(defun mh-expand-file-name (filename &optional default) + "Expand FILENAME like `expand-file-name', but also handle MH folder names. +Any filename that starts with '+' is treated as a folder name. +See `expand-file-name' for description of DEFAULT." + (if (mh-folder-name-p filename) + (expand-file-name (substring filename 1) mh-user-path) + (expand-file-name filename default))) + + +(defun mh-msg-filename (msg &optional folder) + "Return the file name of MSG in FOLDER (default current folder)." + (expand-file-name (int-to-string msg) + (if folder + (mh-expand-file-name folder) + mh-folder-filename))) + +;;; Infrastructure to generate show-buffer functions from folder functions +;;; XEmacs does not have deactivate-mark? What is the equivalent of +;;; transient-mark-mode for XEmacs? Should we be restoring the mark in the +;;; folder buffer after the operation has been carried out. +(defmacro mh-defun-show-buffer (function original-function + &optional dont-return) + "Define FUNCTION to run ORIGINAL-FUNCTION in folder buffer. +If the buffer we start in is still visible and DONT-RETURN is nil then switch +to it after that." + `(defun ,function () + ,(format "Calls %s from the message's folder.\n%s\nSee `%s' for more info.\n" + original-function + (if dont-return "" + "When function completes, returns to the show buffer if it is +still visible.\n") + original-function) + (interactive) + (when (buffer-live-p (get-buffer mh-show-folder-buffer)) + (let ((config (current-window-configuration)) + (folder-buffer mh-show-folder-buffer) + (normal-exit nil) + ,@(if dont-return () '((cur-buffer-name (buffer-name))))) + (pop-to-buffer mh-show-folder-buffer nil) + (unless (equal (buffer-name + (window-buffer (frame-first-window (selected-frame)))) + folder-buffer) + (delete-other-windows)) + (mh-goto-cur-msg t) + (and (fboundp 'deactivate-mark) (deactivate-mark)) + (unwind-protect + (prog1 (call-interactively (function ,original-function)) + (setq normal-exit t)) + (and (fboundp 'deactivate-mark) (deactivate-mark)) + (cond ((not normal-exit) + (set-window-configuration config)) + ,(if dont-return + `(t (setq mh-previous-window-config config)) + `((and (get-buffer cur-buffer-name) + (window-live-p (get-buffer-window + (get-buffer cur-buffer-name)))) + (pop-to-buffer (get-buffer cur-buffer-name) nil))))))))) + +;;; Generate interactive functions for the show buffer from the corresponding +;;; folder functions. +(mh-defun-show-buffer mh-show-previous-undeleted-msg + mh-previous-undeleted-msg) +(mh-defun-show-buffer mh-show-next-undeleted-msg + mh-next-undeleted-msg) +(mh-defun-show-buffer mh-show-quit mh-quit) +(mh-defun-show-buffer mh-show-delete-msg mh-delete-msg) +(mh-defun-show-buffer mh-show-refile-msg mh-refile-msg) +(mh-defun-show-buffer mh-show-undo mh-undo) +(mh-defun-show-buffer mh-show-execute-commands mh-execute-commands) +(mh-defun-show-buffer mh-show-reply mh-reply t) +(mh-defun-show-buffer mh-show-redistribute mh-redistribute) +(mh-defun-show-buffer mh-show-forward mh-forward t) +(mh-defun-show-buffer mh-show-header-display mh-header-display) +(mh-defun-show-buffer mh-show-refile-or-write-again + mh-refile-or-write-again) +(mh-defun-show-buffer mh-show-show mh-show) +(mh-defun-show-buffer mh-show-write-message-to-file + mh-write-msg-to-file) +(mh-defun-show-buffer mh-show-extract-rejected-mail + mh-extract-rejected-mail t) +(mh-defun-show-buffer mh-show-delete-msg-no-motion + mh-delete-msg-no-motion) +(mh-defun-show-buffer mh-show-first-msg mh-first-msg) +(mh-defun-show-buffer mh-show-last-msg mh-last-msg) +(mh-defun-show-buffer mh-show-copy-msg mh-copy-msg) +(mh-defun-show-buffer mh-show-edit-again mh-edit-again t) +(mh-defun-show-buffer mh-show-goto-msg mh-goto-msg) +(mh-defun-show-buffer mh-show-inc-folder mh-inc-folder) +(mh-defun-show-buffer mh-show-delete-subject-or-thread + mh-delete-subject-or-thread) +(mh-defun-show-buffer mh-show-delete-subject mh-delete-subject) +(mh-defun-show-buffer mh-show-print-msg mh-print-msg) +(mh-defun-show-buffer mh-show-send mh-send t) +(mh-defun-show-buffer mh-show-toggle-showing mh-toggle-showing t) +(mh-defun-show-buffer mh-show-pipe-msg mh-pipe-msg t) +(mh-defun-show-buffer mh-show-sort-folder mh-sort-folder) +(mh-defun-show-buffer mh-show-visit-folder mh-visit-folder t) +(mh-defun-show-buffer mh-show-rescan-folder mh-rescan-folder) +(mh-defun-show-buffer mh-show-pack-folder mh-pack-folder) +(mh-defun-show-buffer mh-show-kill-folder mh-kill-folder t) +(mh-defun-show-buffer mh-show-list-folders mh-list-folders t) +(mh-defun-show-buffer mh-show-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) +(mh-defun-show-buffer mh-show-delete-seq mh-delete-seq) +(mh-defun-show-buffer mh-show-list-sequences mh-list-sequences) +(mh-defun-show-buffer mh-show-narrow-to-seq mh-narrow-to-seq) +(mh-defun-show-buffer mh-show-put-msg-in-seq mh-put-msg-in-seq) +(mh-defun-show-buffer mh-show-msg-is-in-seq mh-msg-is-in-seq) +(mh-defun-show-buffer mh-show-widen mh-widen) +(mh-defun-show-buffer mh-show-narrow-to-subject + mh-narrow-to-subject) +(mh-defun-show-buffer mh-show-store-msg mh-store-msg) +(mh-defun-show-buffer mh-show-page-digest mh-page-digest) +(mh-defun-show-buffer mh-show-page-digest-backwards + mh-page-digest-backwards) +(mh-defun-show-buffer mh-show-burst-digest mh-burst-digest) +(mh-defun-show-buffer mh-show-page-msg mh-page-msg) +(mh-defun-show-buffer mh-show-previous-page mh-previous-page) +(mh-defun-show-buffer mh-show-modify mh-modify t) +(mh-defun-show-buffer mh-show-next-button mh-next-button) +(mh-defun-show-buffer mh-show-prev-button mh-prev-button) +(mh-defun-show-buffer mh-show-toggle-mime-part mh-folder-toggle-mime-part) +(mh-defun-show-buffer mh-show-save-mime-part mh-folder-save-mime-part) +(mh-defun-show-buffer mh-show-inline-mime-part mh-folder-inline-mime-part) +(mh-defun-show-buffer mh-show-toggle-threads mh-toggle-threads) +(mh-defun-show-buffer mh-show-thread-delete mh-thread-delete) +(mh-defun-show-buffer mh-show-thread-refile mh-thread-refile) +(mh-defun-show-buffer mh-show-update-sequences mh-update-sequences) +(mh-defun-show-buffer mh-show-next-unread-msg mh-next-unread-msg) +(mh-defun-show-buffer mh-show-previous-unread-msg mh-previous-unread-msg) +(mh-defun-show-buffer mh-show-thread-ancestor mh-thread-ancestor) +(mh-defun-show-buffer mh-show-thread-next-sibling mh-thread-next-sibling) +(mh-defun-show-buffer mh-show-thread-previous-sibling + mh-thread-previous-sibling) +(mh-defun-show-buffer mh-show-index-visit-folder mh-index-visit-folder t) + +;;; Populate mh-show-mode-map +(gnus-define-keys mh-show-mode-map + " " mh-show-page-msg + "!" mh-show-refile-or-write-again + "," mh-show-header-display + "." mh-show-show + ">" mh-show-write-message-to-file + "?" mh-help + "E" mh-show-extract-rejected-mail + "M" mh-show-modify + "\177" mh-show-previous-page + "\C-d" mh-show-delete-msg-no-motion + "\t" mh-show-next-button + [backtab] mh-show-prev-button + "\M-\t" mh-show-prev-button + "\ed" mh-show-redistribute + "^" mh-show-refile-msg + "c" mh-show-copy-msg + "d" mh-show-delete-msg + "e" mh-show-edit-again + "f" mh-show-forward + "g" mh-show-goto-msg + "i" mh-show-inc-folder + "k" mh-show-delete-subject-or-thread + "l" mh-show-print-msg + "m" mh-show-send + "n" mh-show-next-undeleted-msg + "\M-n" mh-show-next-unread-msg + "o" mh-show-refile-msg + "p" mh-show-previous-undeleted-msg + "\M-p" mh-show-previous-unread-msg + "q" mh-show-quit + "r" mh-show-reply + "s" mh-show-send + "t" mh-show-toggle-showing + "u" mh-show-undo + "x" mh-show-execute-commands + "v" mh-show-index-visit-folder + "|" mh-show-pipe-msg) + +(gnus-define-keys (mh-show-folder-map "F" mh-show-mode-map) + "?" mh-prefix-help + "S" mh-show-sort-folder + "f" mh-show-visit-folder + "i" mh-index-search + "k" mh-show-kill-folder + "l" mh-show-list-folders + "o" mh-show-visit-folder + "r" mh-show-rescan-folder + "s" mh-show-search-folder + "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-prefix-help + "d" mh-show-delete-msg-from-seq + "k" mh-show-delete-seq + "l" mh-show-list-sequences + "n" mh-show-narrow-to-seq + "p" mh-show-put-msg-in-seq + "s" mh-show-msg-is-in-seq + "w" mh-show-widen) + +(gnus-define-keys (mh-show-thread-map "T" mh-show-mode-map) + "?" mh-prefix-help + "u" mh-show-thread-ancestor + "p" mh-show-thread-previous-sibling + "n" mh-show-thread-next-sibling + "t" mh-show-toggle-threads + "d" mh-show-thread-delete + "o" mh-show-thread-refile) + +(gnus-define-keys (mh-show-limit-map "/" mh-show-mode-map) + "?" mh-prefix-help + "s" mh-show-narrow-to-subject + "w" mh-show-widen) + +(gnus-define-keys (mh-show-extract-map "X" mh-show-mode-map) + "?" mh-prefix-help + "s" mh-show-store-msg + "u" mh-show-store-msg) + +;; Untested... +(gnus-define-keys (mh-show-digest-map "D" mh-show-mode-map) + "?" mh-prefix-help + " " mh-show-page-digest + "\177" mh-show-page-digest-backwards + "b" mh-show-burst-digest) + +(gnus-define-keys (mh-show-mime-map "K" mh-show-mode-map) + "?" mh-prefix-help + "a" mh-mime-save-parts + "v" mh-show-toggle-mime-part + "o" mh-show-save-mime-part + "i" mh-show-inline-mime-part + "\t" mh-show-next-button + [backtab] mh-show-prev-button + "\M-\t" mh-show-prev-button) + +(easy-menu-define + mh-show-sequence-menu mh-show-mode-map "Menu for MH-E folder-sequence." + '("Sequence" + ["Add Message to Sequence..." mh-show-put-msg-in-seq t] + ["List Sequences for Message" mh-show-msg-is-in-seq t] + ["Delete Message from Sequence..." mh-show-delete-msg-from-seq t] + ["List Sequences in Folder..." mh-show-list-sequences t] + ["Delete Sequence..." mh-show-delete-seq t] + ["Narrow to Sequence..." mh-show-narrow-to-seq t] + ["Widen from Sequence" mh-show-widen t] + "--" + ["Narrow to Subject Sequence" mh-show-narrow-to-subject t] + ["Delete Rest of Same Subject" mh-show-delete-subject t] + "--" + ["Push State Out to MH" mh-show-update-sequences t])) + +(easy-menu-define + mh-show-message-menu mh-show-mode-map "Menu for MH-E folder-message." + '("Message" + ["Show Message" mh-show-show t] + ["Show Message with Header" mh-show-header-display t] + ["Next Message" mh-show-next-undeleted-msg t] + ["Previous Message" mh-show-previous-undeleted-msg t] + ["Go to First Message" mh-show-first-msg t] + ["Go to Last Message" mh-show-last-msg t] + ["Go to Message by Number..." mh-show-goto-msg t] + ["Modify Message" mh-show-modify t] + ["Delete Message" mh-show-delete-msg t] + ["Refile Message" mh-show-refile-msg t] + ["Undo Delete/Refile" mh-show-undo t] + ["Process Delete/Refile" mh-show-execute-commands t] + "--" + ["Compose a New Message" mh-send t] + ["Reply to Message..." mh-show-reply t] + ["Forward Message..." mh-show-forward t] + ["Redistribute Message..." mh-show-redistribute t] + ["Edit Message Again" mh-show-edit-again t] + ["Re-edit a Bounced Message" mh-show-extract-rejected-mail t] + "--" + ["Copy Message to Folder..." mh-show-copy-msg t] + ["Print Message" mh-show-print-msg t] + ["Write Message to File..." mh-show-write-msg-to-file t] + ["Pipe Message to Command..." mh-show-pipe-msg t] + ["Unpack Uuencoded Message..." mh-show-store-msg t] + ["Burst Digest Message" mh-show-burst-digest t])) + +(easy-menu-define + mh-show-folder-menu mh-show-mode-map "Menu for MH-E folder." + '("Folder" + ["Incorporate New Mail" mh-show-inc-folder t] + ["Toggle Show/Folder" mh-show-toggle-showing t] + ["Execute Delete/Refile" mh-show-execute-commands t] + ["Rescan Folder" mh-show-rescan-folder t] + ["Thread Folder" mh-show-toggle-threads t] + ["Pack Folder" mh-show-pack-folder t] + ["Sort Folder" mh-show-sort-folder t] + "--" + ["List Folders" mh-show-list-folders t] + ["Visit a Folder..." mh-show-visit-folder t] + ["Search a Folder..." mh-show-search-folder t] + ["Indexed Search..." mh-index-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) + +(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." + (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) + (make-local-variable 'font-lock-defaults) + ;;(set (make-local-variable 'font-lock-support-mode) nil) + (cond + ((equal mh-highlight-citation-p 'font-lock) + (setq font-lock-defaults '(mh-show-font-lock-keywords-with-cite t))) + ((equal mh-highlight-citation-p 'gnus) + (setq font-lock-defaults '((mh-show-font-lock-keywords) + t nil nil nil + (font-lock-fontify-region-function + . mh-show-font-lock-fontify-region))) + (mh-gnus-article-highlight-citation)) + (t + (setq font-lock-defaults '(mh-show-font-lock-keywords t)))) + (if (and mh-xemacs-flag + font-lock-auto-fontify) + (turn-on-font-lock)) + (if (and (boundp 'tool-bar-mode) tool-bar-mode) + (set (make-local-variable 'tool-bar-map) mh-show-tool-bar-map)) + (when mh-decode-mime-flag + (add-hook 'kill-buffer-hook 'mh-mime-cleanup nil t)) + (easy-menu-add mh-show-sequence-menu) + (easy-menu-add mh-show-message-menu) + (easy-menu-add mh-show-folder-menu) + (make-local-variable 'mh-show-folder-buffer) + (buffer-disable-undo) + (setq buffer-read-only t) + (use-local-map mh-show-mode-map) + (run-hooks 'mh-show-mode-hook)) + +(defun mh-show-addr () + "Use `goto-address'." + (when mh-show-use-goto-addr-flag + (if (not (featurep 'goto-addr)) + (load "goto-addr" t t)) + (if (fboundp 'goto-address) + (goto-address)))) + +(defvar mh-show-xface-function + (cond ((and mh-xemacs-flag (locate-library "x-face")) + (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)) + (t #'ignore)) + "Determine at run time what function should be called to display X-Face.") + +(defun mh-show-xface () + "Display X-Face." + (when (and mh-show-use-xface-flag + (or mh-decode-mime-flag mhl-formfile + mh-clean-message-header-flag)) + (funcall mh-show-xface-function))) + +(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. + +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)) + (mh-show-msg message)) + +(defun mh-show-mouse (EVENT) + "Move point to mouse EVENT and show message." + (interactive "e") + (mouse-set-point EVENT) + (mh-show)) + +(defun mh-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." + (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) + (clean-message-header mh-clean-message-header-flag) + (show-window (get-buffer-window mh-show-buffer))) + (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) + (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)) + +(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. + +The message is displayed in raw form." + (interactive) + (let* ((message (or message (mh-get-msg-num t))) + (msg-filename (mh-msg-filename message)) + edit-buffer) + (when (not (file-exists-p msg-filename)) + (error "Message %d does not exist" message)) + + ;; Invalidate the show buffer if it is showing the same message that is + ;; to be edited. + (when (and (buffer-live-p (get-buffer mh-show-buffer)) + (equal (save-excursion (set-buffer mh-show-buffer) + buffer-file-name) + msg-filename)) + (mh-invalidate-show-buffer)) + + ;; Edit message + (find-file msg-filename) + (setq edit-buffer (current-buffer)) + + ;; Set buffer properties + (mh-letter-mode) + (use-local-map text-mode-map) + + ;; Just show the edit buffer... + (delete-other-windows) + (switch-to-buffer edit-buffer))) + +(defun mh-decode-quoted-printable () + "Run mimedecode on current buffer, replacing its contents." + (let ((case-fold-search t)) + (goto-char (point-min)) + (when (and (re-search-forward + "^content-transfer-encoding:[ \t]*quoted-printable" + (if mh-decode-mime-flag (mail-header-end) nil) t) + (search-forward "\n\n" nil t)) + (message "Converting quoted-printable characters...") + (let ((modified (buffer-modified-p)) + (command "mimedecode")) + (shell-command-on-region (point-min) (point-max) command t t) + (if (fboundp 'deactivate-mark) + (deactivate-mark)) + (set-buffer-modified-p modified)) + (message "Converting quoted-printable characters... done.")))) + +(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)) + (while (re-search-forward "^>From" nil t) + (replace-match "From")) + (set-buffer-modified-p modified)))) + +(defun mh-msg-folder (folder-name) + "Return the name of the buffer for FOLDER-NAME." + folder-name) + +(defun mh-display-msg (msg-num folder-name) + "Display MSG-NUM of FOLDER-NAME. +Sets the current buffer to the show buffer." + (let ((folder (mh-msg-folder folder-name))) + (set-buffer folder) + ;; When Gnus uses external displayers it has to keep handles longer. So + ;; we will delete these handles when mh-quit is called on the folder. It + ;; would be nicer if there are weak pointers in emacs lisp, then we could + ;; get the garbage collector to do this for us. + (unless (mh-buffer-data) + (setf (mh-buffer-data) (mh-make-buffer-data))) + ;; Bind variables in folder buffer in case they are local + (let ((formfile mhl-formfile) + (clean-message-header mh-clean-message-header-flag) + (invisible-headers mh-invisible-headers) + (visible-headers mh-visible-headers) + (msg-filename (mh-msg-filename msg-num folder-name)) + (show-buffer mh-show-buffer) + (mm-inline-media-tests mh-mm-inline-media-tests)) + (if (not (file-exists-p msg-filename)) + (error "Message %d does not exist" msg-num)) + (if (and (> mh-show-maximum-size 0) + (> (elt (file-attributes msg-filename) 7) + mh-show-maximum-size) + (not (y-or-n-p + (format + "Message %d (%d bytes) exceeds %d bytes. Display it? " + msg-num (elt (file-attributes msg-filename) 7) + mh-show-maximum-size)))) + (error "Message %d not displayed" msg-num)) + (set-buffer show-buffer) + (cond ((not (equal msg-filename buffer-file-name)) + (mh-unvisit-file) + (setq buffer-read-only nil) + (erase-buffer) + ;; Changing contents, so this hook needs to be reinitialized. + ;; pgp.el uses this. + (if (boundp 'write-contents-hooks) ;Emacs 19 + (kill-local-variable 'write-contents-hooks)) + (if formfile + (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear" + (if (stringp formfile) + (list "-form" formfile)) + msg-filename) + (insert-file-contents msg-filename)) + (if mh-decode-quoted-printable-flag + (mh-decode-quoted-printable)) + ;; 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)) + ;; Header cleanup + (goto-char (point-min)) + (cond (clean-message-header + (mh-clean-msg-header (point-min) + invisible-headers + visible-headers) + (goto-char (point-min))) + (t + (mh-start-of-uncleaned-message))) + ;; the parts of visiting we want to do (no locking) + (or (eq buffer-undo-list t) ;don't save undo info for prev msgs + (setq buffer-undo-list nil)) + (set-buffer-auto-saved) + ;; the parts of set-visited-file-name we want to do (no locking) + (setq buffer-file-name msg-filename) + (setq buffer-backed-up nil) + (auto-save-mode 1) + (set-mark nil) + (mh-show-mode) + (unwind-protect + (when (and mh-decode-mime-flag (not formfile)) + (setq buffer-read-only nil) + (mh-display-smileys) + (mh-display-emphasis)) + (setq buffer-read-only t)) + (set-buffer-modified-p nil) + (setq mh-show-folder-buffer folder) + (setq mode-line-buffer-identification + (list (format mh-show-buffer-mode-line-buffer-id + folder-name msg-num))) + (set-buffer folder) + (setq mh-showing-with-headers nil)))))) + +(defun mh-clean-msg-header (start invisible-headers visible-headers) + "Flush extraneous lines in message header. +Header is cleaned from START to the end of the message header. +INVISIBLE-HEADERS contains a regular expression specifying lines to delete +from the header. VISIBLE-HEADERS contains a regular expression specifying the +lines to display. INVISIBLE-HEADERS is ignored if VISIBLE-HEADERS is non-nil." + (let ((case-fold-search t) + (after-change-functions nil)) ;Work around emacs-20 font-lock bug + ;causing an endless loop. + (save-restriction + (goto-char start) + (if (search-forward "\n\n" nil 'move) + (backward-char 1)) + (narrow-to-region start (point)) + (goto-char (point-min)) + (if visible-headers + (while (< (point) (point-max)) + (cond ((looking-at visible-headers) + (forward-line 1) + (while (looking-at "[ \t]") (forward-line 1))) + (t + (mh-delete-line 1) + (while (looking-at "[ \t]") + (mh-delete-line 1))))) + (while (re-search-forward invisible-headers nil t) + (beginning-of-line) + (mh-delete-line 1) + (while (looking-at "[ \t]") + (mh-delete-line 1)))) + (unlock-buffer)))) + +(defun mh-delete-line (lines) + "Delete the next LINES lines." + (delete-region (point) (progn (forward-line lines) (point)))) + +(defun mh-notate (msg notation offset) + "Mark MSG with the character NOTATION at position OFFSET. +Null MSG means the message at cursor." + (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))) + +(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." + (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) + (goto-char point) + (unless no-error-if-no-message + (error "No message %d" number)) + (setq return-value nil)) + (beginning-of-line) + (or dont-show (not return-value) (mh-maybe-show number)) + return-value)) + +(defun mh-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))) + (and mh-auto-folder-collect-flag + (let ((mh-no-install t)) ;only get folders if MH installed + (condition-case err + (mh-make-folder-list-background) + (file-error))))) ;so don't complain if not installed + +(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)) + +(defun mh-find-seq (name) + "Return sequence NAME." + (assoc name mh-seq-list)) + +(defun mh-seq-to-msgs (seq) + "Return a list of the messages in SEQ." + (mh-seq-msgs (mh-find-seq seq))) + +(defun mh-update-scan-format (fmt width) + "Return a scan format with the (msg) width in the FMT replaced with WIDTH. + +The message number width portion of the format is discovered using +`mh-scan-msg-format-regexp'. Its replacement is controlled with +`mh-scan-msg-format-string'." + (or (and + (string-match mh-scan-msg-format-regexp fmt) + (let ((begin (match-beginning 1)) + (end (match-end 1))) + (concat (substring fmt 0 begin) + (format mh-scan-msg-format-string width) + (substring fmt end)))) + fmt)) + +(defun mh-message-number-width (folder) + "Return the widest message number in this FOLDER." + (or mh-progs (mh-find-path)) + (let ((tmp-buffer (get-buffer-create mh-temp-buffer)) + (width 0)) + (save-excursion + (set-buffer tmp-buffer) + (erase-buffer) + (apply 'call-process + (expand-file-name "scan" mh-progs) nil '(t nil) nil + (list folder "last" "-format" "%(msg)")) + (goto-char (point-min)) + (if (re-search-forward mh-scan-msg-number-regexp nil 0 1) + (setq width (length (buffer-substring + (match-beginning 1) (match-end 1)))))) + width)) + +(defun mh-add-msgs-to-seq (msgs seq &optional internal-flag) + "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." + (let ((entry (mh-find-seq seq))) + (if (and msgs (atom msgs)) (setq msgs (list msgs))) + (if (null entry) + (setq mh-seq-list + (cons (mh-make-seq seq (mh-canonicalize-sequence msgs)) + mh-seq-list)) + (if msgs (setcdr entry (mh-canonicalize-sequence + (append msgs (mh-seq-msgs entry)))))) + (cond ((not internal-flag) + (mh-add-to-sequence seq msgs) + (mh-notate-seq seq mh-note-seq (1+ mh-cmd-note)))))) + +(defun mh-canonicalize-sequence (msgs) + "Sort MSGS in decreasing order and remove duplicates." + (let* ((sorted-msgs (sort (copy-sequence msgs) '>)) + (head sorted-msgs)) + (while (cdr head) + (if (= (car head) (cadr head)) + (setcdr head (cddr head)) + (setq head (cdr head)))) + sorted-msgs)) + +(defvar mh-folder-hist nil) +(defvar mh-speed-folder-map) + +(defun mh-prompt-for-folder (prompt default can-create + &optional default-string) + "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. +The value of `mh-folder-list-change-hook' is a list of functions to be called, +with no arguments, whenever the cached folder list `mh-folder-list' is +changed." + (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)) + read-name folder-name) + (if (null mh-folder-list) + (mh-set-folder-list)) + (while (and (setq read-name (completing-read prompt mh-folder-list nil nil + "+" 'mh-folder-hist)) + (equal read-name "") + (equal default ""))) + (cond ((or (equal read-name "") (equal read-name "+")) + (setq read-name default)) + ((not (mh-folder-name-p read-name)) + (setq read-name (format "+%s" read-name)))) + (if (or (not read-name) (equal "" read-name)) + (error "No folder specified")) + (setq folder-name read-name) + (cond ((and (> (length folder-name) 0) + (eq (aref folder-name (1- (length folder-name))) ?/)) + (setq folder-name (substring folder-name 0 -1)))) + (let ((new-file-flag + (not (file-exists-p (mh-expand-file-name folder-name))))) + (cond ((and new-file-flag + (y-or-n-p + (format "Folder %s does not exist. Create it? " + folder-name))) + (message "Creating %s" folder-name) + (mh-exec-cmd-error nil "folder" folder-name) + (when (boundp 'mh-speed-folder-map) + (mh-speed-add-folder folder-name)) + (message "Creating %s...done" folder-name) + (setq mh-folder-list (cons (list read-name) mh-folder-list)) + (run-hooks 'mh-folder-list-change-hook)) + (new-file-flag + (error "Folder %s is not created" folder-name)) + ((not (file-directory-p (mh-expand-file-name folder-name))) + (error "\"%s\" is not a directory" + (mh-expand-file-name folder-name))) + ((and (null (assoc read-name mh-folder-list)) + (null (assoc (concat read-name "/") mh-folder-list))) + (setq mh-folder-list (cons (list read-name) mh-folder-list)) + (run-hooks 'mh-folder-list-change-hook)))) + folder-name)) + +(defvar mh-make-folder-list-process nil) ;The background process collecting + ;the folder list. + +(defvar mh-folder-list-temp nil) ;mh-folder-list as it is being built. + +(defvar mh-folder-list-partial-line "") ;Start of last incomplete line from + ;folder process. + +(defun mh-set-folder-list () + "Set `mh-folder-list' correctly. +A useful function for the command line or for when you need to +sync by hand. Format is in a form suitable for completing read. +The value of `mh-folder-list-change-hook' is a list of functions to be called, +with no arguments, once the list of folders has been created." + (message "Collecting folder names...") + (if (not mh-make-folder-list-process) + (mh-make-folder-list-background)) + (while (eq (process-status mh-make-folder-list-process) 'run) + (accept-process-output mh-make-folder-list-process)) + (setq mh-folder-list mh-folder-list-temp) + (run-hooks 'mh-folder-list-change-hook) + (setq mh-folder-list-temp nil) + (delete-process mh-make-folder-list-process) + (setq mh-make-folder-list-process nil) + (message "Collecting folder names...done")) + +(defun mh-make-folder-list-background () + "Start a background process to compute a list of the user's folders. +Call `mh-set-folder-list' to wait for the result." + (cond + ((not mh-make-folder-list-process) + (unless mh-inbox + (mh-find-path)) + (let ((process-connection-type nil)) + (setq mh-make-folder-list-process + (start-process "folders" nil (expand-file-name "folders" mh-progs) + "-fast" + (if mh-recursive-folders-flag + "-recurse" + "-norecurse"))) + (set-process-filter mh-make-folder-list-process + 'mh-make-folder-list-filter) + (process-kill-without-query mh-make-folder-list-process))))) + +(defun mh-make-folder-list-filter (process output) + "Given the PROCESS \"folders -fast\", parse OUTPUT. +See also `set-process-filter'." + (let ((position 0) + line-end + new-folder + (prevailing-match-data (match-data))) + (unwind-protect + ;; make sure got complete line + (while (setq line-end (string-match "\n" output position)) + (setq new-folder (format "+%s%s" + mh-folder-list-partial-line + (substring output position line-end))) + (setq mh-folder-list-partial-line "") + ;; is new folder a subfolder of previous? + (if (and mh-folder-list-temp + (string-match + (regexp-quote + (concat (car (car mh-folder-list-temp)) "/")) + new-folder)) + ;; append slash to parent folder for better completion + ;; (undone by mh-prompt-for-folder) + (setq mh-folder-list-temp + (cons + (list new-folder) + (cons + (list (concat (car (car mh-folder-list-temp)) "/")) + (cdr mh-folder-list-temp)))) + (setq mh-folder-list-temp + (cons (list new-folder) + mh-folder-list-temp))) + (setq position (1+ line-end))) + (set-match-data prevailing-match-data)) + (setq mh-folder-list-partial-line (substring output position)))) + +;;; 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-temp-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-temp-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 &rest args) + "Execute MH command COMMAND with ARGS in the background. +Any output from command is displayed in an asynchronous pop-up window." + (save-excursion + (set-buffer (get-buffer-create mh-temp-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 'mh-process-daemon))) + +(defun mh-process-daemon (process output) + "PROCESS daemon that puts OUTPUT into a temporary buffer." + (set-buffer (get-buffer-create mh-temp-buffer)) + (insert-before-markers output) + (display-buffer mh-temp-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))))))) + +(defun mh-list-to-string (l) + "Flatten the list L and make every element of the new list into a string." + (nreverse (mh-list-to-string-1 l))) + +(defun mh-list-to-string-1 (l) + "Flatten the list L and make every element of the new list into a string." + (let ((new-list nil)) + (while l + (cond ((null (car l))) + ((symbolp (car l)) + (setq new-list (cons (symbol-name (car l)) new-list))) + ((numberp (car l)) + (setq new-list (cons (int-to-string (car l)) new-list))) + ((equal (car l) "")) + ((stringp (car l)) (setq new-list (cons (car l) new-list))) + ((listp (car l)) + (setq new-list (nconc (mh-list-to-string-1 (car l)) + new-list))) + (t (error "Bad element in mh-list-to-string: %s" (car l)))) + (setq l (cdr l))) + new-list)) + +(provide 'mh-utils) + +;;; Local Variables: +;;; indent-tabs-mode: nil +;;; sentence-end-double-space: nil +;;; End: + +;;; mh-utils.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/mh-e/mh-xemacs-compat.el Sun Jan 26 02:38:37 2003 +0000 @@ -0,0 +1,62 @@ +;;; mh-xemacs-compat.el --- GNU Emacs Functions needed by XEmacs + +;; Copyright (C) 2001, 2002 Free Software Foundation, Inc. + +;; Author: FSF +;; Maintainer: Bill Wohler <wohler@newt.com> +;; Keywords: mail +;; See: mh-e.el + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Change Log: + +;; $Id: mh-xemacs-compat.el,v 1.3 2003/01/08 23:21:16 wohler Exp $ + +;;; Code: + +;;; Some requires: +(require 'rfc822) + +;;; Simple compatibility: + +(unless (fboundp 'match-string-no-properties) + (defsubst match-string-no-properties (match) + (buffer-substring-no-properties + (match-beginning match) (match-end match)))) + +(unless (fboundp 'line-beginning-position) + (defalias 'line-beginning-position 'point-at-bol)) +(unless (fboundp 'line-end-position) + (defalias 'line-end-position 'point-at-eol)) + +(unless (fboundp 'timerp) + (defalias 'timerp 'itimerp)) +(unless (fboundp 'cancel-timer) + (defalias 'cancel-timer 'delete-itimer)) + +(provide 'mh-xemacs-compat) + +;;; Local Variables: +;;; indent-tabs-mode: nil +;;; sentence-end-double-space: nil +;;; End: + +;;; mh-xemacs-compat.el ends here