diff options
Diffstat (limited to 'lisp/mail')
34 files changed, 0 insertions, 20361 deletions
diff --git a/lisp/mail/blessmail.el b/lisp/mail/blessmail.el deleted file mode 100644 index dc4c749c31a..00000000000 --- a/lisp/mail/blessmail.el +++ /dev/null @@ -1,69 +0,0 @@ -;;; blessmail.el --- Decide whether movemail needs special privileges. - -;; Copyright (C) 1994 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: internal - -;; 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 is loaded into a bare Emacs to create the blessmail script, -;; which (on systems that need it) is used during installation -;; to give appropriate permissions to movemail. -;; -;; It has to be done from lisp in order to be sure of getting the -;; correct value of rmail-spool-directory. - -;;; Code: - -;; These are no longer needed because we run this in emacs instead of temacs. -;; (message "Using load-path %s" load-path) -;; (load "paths.el") -;; It is not safe to load site-init.el here, because it might have things in it -;; that won't load properly unless all the rest of Emacs is loaded. - -(let ((dirname (directory-file-name rmail-spool-directory)) - linkname attr modes) - ;; Check for symbolic link - (while (setq linkname (file-symlink-p dirname)) - (setq dirname (if (file-name-absolute-p linkname) - linkname - (concat (file-name-directory dirname) linkname)))) - (insert "#!/bin/sh\n") - (setq attr (file-attributes dirname)) - (if (not (eq t (car attr))) - (insert (format "echo %s is not a directory\n" rmail-spool-directory)) - (setq modes (nth 8 attr)) - (cond ((= ?w (aref modes 8)) - ;; Nothing needs to be done. - ) - ((= ?w (aref modes 5)) - (insert "chgrp " (number-to-string (nth 3 attr)) - " $* && chmod g+s $*\n")) - ((= ?w (aref modes 2)) - (insert "chown " (number-to-string (nth 2 attr)) - " $* && chmod u+s $*\n")) - (t - (insert "chown root $* && chmod u+s $*\n")))) - (insert "echo mail directory = " dirname "\n")) -(write-region (point-min) (point-max) "blessmail") -(kill-emacs) - -;;; blessmail.el ends here diff --git a/lisp/mail/emacsbug.el b/lisp/mail/emacsbug.el deleted file mode 100644 index 6efd33ea05a..00000000000 --- a/lisp/mail/emacsbug.el +++ /dev/null @@ -1,153 +0,0 @@ -;;; emacsbug.el --- command to report Emacs bugs to appropriate mailing list. - -;; Copyright (C) 1985, 1994 Free Software Foundation, Inc. - -;; Author: K. Shane Hartman -;; Maintainer: FSF -;; Keywords: maint - -;; Not fully installed because it can work only on Internet hosts. -;; 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: - -;; `M-x report-emacs-bug ' starts an email note to the Emacs maintainers -;; describing a problem. Here's how it's done... - -;;; Code: - -;; >> This should be an address which is accessible to your machine, -;; >> otherwise you can't use this file. It will only work on the -;; >> internet with this address. - -(require 'sendmail) - -(defvar bug-gnu-emacs "bug-gnu-emacs@prep.ai.mit.edu" - "Address of mailing list for GNU Emacs bugs.") - -(defvar report-emacs-bug-pretest-address "emacs-pretest-bug@gnu.ai.mit.edu" - "Address of mailing list for GNU Emacs pretest bugs.") - -(defvar report-emacs-bug-orig-text nil - "The automatically-created initial text of bug report.") - -;;;###autoload -(defun report-emacs-bug (topic &optional recent-keys) - "Report a bug in GNU Emacs. -Prompts for bug subject. Leaves you in a mail buffer." - ;; This strange form ensures that (recent-keys) is the value before - ;; the bug subject string is read. - (interactive (reverse (list (recent-keys) (read-string "Bug Subject: ")))) - (condition-case nil - (let (user-point) - (compose-mail (if (string-match "\\..*\\..*\\." emacs-version) - ;; If there are four numbers in emacs-version, - ;; this is a pretest version. - report-emacs-bug-pretest-address - bug-gnu-emacs) - topic) - ;; The rest of this does not execute - ;; if the user was asked to confirm and said no. - (goto-char (point-min)) - (re-search-forward (concat "^" (regexp-quote mail-header-separator) "\n")) - (insert "In " (emacs-version) "\n") - (if (and system-configuration-options - (not (equal system-configuration-options ""))) - (insert "configured using `configure " - system-configuration-options "'\n")) - (insert "\n") - (insert "Please describe exactly what actions triggered the bug\n" - "and the precise symptoms of the bug:\n\n") - (setq user-point (point)) - (insert "\n\n\n" - "Recent input:\n") - (let ((before-keys (point))) - (insert (mapconcat (lambda (key) - (if (or (integerp key) - (symbolp key) - (listp key)) - (single-key-description key) - (prin1-to-string key nil))) - (or recent-keys (recent-keys)) - " ")) - (save-restriction - (narrow-to-region before-keys (point)) - (goto-char before-keys) - (while (progn (move-to-column 50) (not (eobp))) - (search-forward " " nil t) - (insert "\n")))) - (let ((message-buf (get-buffer "*Messages*"))) - (if message-buf - (progn - (insert "\n\nRecent messages:\n") - (insert-buffer-substring message-buf - (save-excursion - (set-buffer message-buf) - (goto-char (point-max)) - (forward-line -10) - (point)) - (save-excursion - (set-buffer message-buf) - (point-max)))))) - ;; This is so the user has to type something - ;; in order to send easily. - (use-local-map (nconc (make-sparse-keymap) (current-local-map))) - (define-key (current-local-map) "\C-c\C-i" 'report-emacs-bug-info) - (with-output-to-temp-buffer "*Bug Help*" - (princ (substitute-command-keys - "Type \\[mail-send-and-exit] to send the bug report.\n")) - (princ (substitute-command-keys - "Type \\[kill-buffer] RET to cancel (don't send it).\n")) - (terpri) - (princ (substitute-command-keys - "Type \\[report-emacs-bug-info] to visit in Info the Emacs Manual section -about when and how to write a bug report, -and what information to supply so that the bug can be fixed. -Type SPC to scroll through this section and its subsections."))) - ;; Make it less likely people will send empty messages. - (make-local-variable 'mail-send-hook) - (add-hook 'mail-send-hook 'report-emacs-bug-hook) - (save-excursion - (goto-char (point-max)) - (skip-chars-backward " \t\n") - (make-local-variable 'report-emacs-bug-orig-text) - (setq report-emacs-bug-orig-text (buffer-substring (point-min) (point)))) - (goto-char user-point)) - (error nil))) - -(defun report-emacs-bug-info () - "Go to the Info node on reporting Emacs bugs." - (interactive) - (info) - (Info-directory) - (Info-menu "emacs") - (Info-goto-node "Bugs")) - -(defun report-emacs-bug-hook () - (save-excursion - (goto-char (point-max)) - (skip-chars-backward " \t\n") - (if (and (= (- (point) (point-min)) - (length report-emacs-bug-orig-text)) - (equal (buffer-substring (point-min) (point)) - report-emacs-bug-orig-text)) - (error "No text entered in bug report")))) - -(provide 'emacsbug) - -;;; emacsbug.el ends here diff --git a/lisp/mail/mail-extr.el b/lisp/mail/mail-extr.el deleted file mode 100644 index 931685c4de1..00000000000 --- a/lisp/mail/mail-extr.el +++ /dev/null @@ -1,1987 +0,0 @@ -;;; mail-extr.el --- extract full name and address from RFC 822 mail header. - -;; Copyright (C) 1991, 1992, 1993, 1994 Free Software Foundation, Inc. - -;; Author: Joe Wells <jbw@cs.bu.edu> -;; Maintainer: Jamie Zawinski <jwz@lucid.com> -;; Version: 1.8 -;; 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: - -;;; This file has been censored by the Communications Decency Act. -;;; That law was passed under the guise of a ban on pornography, but -;;; it bans far more than that. This file did not contain pornography, -;;; but it was censored nonetheless. - -;;; For information on US government censorship of the Internet, and -;;; what you can do to bring back freedom of the press, see the web -;;; site http://www.vtw.org/ - -;; The entry point of this code is -;; -;; mail-extract-address-components: (address) -;; -;; Given an RFC-822 ADDRESS, extract full name and canonical address. -;; Returns a list of the form (FULL-NAME CANONICAL-ADDRESS). -;; If no name can be extracted, FULL-NAME will be nil. -;; ADDRESS may be a string or a buffer. If it is a buffer, the visible -;; (narrowed) portion of the buffer will be interpreted as the address. -;; (This feature exists so that the clever caller might be able to avoid -;; consing a string.) -;; If ADDRESS contains more than one RFC-822 address, only the first is -;; returned. -;; -;; This code is more correct (and more heuristic) parser than the code in -;; rfc822.el. And despite its size, it's fairly fast. -;; -;; There are two main benefits: -;; -;; 1. Higher probability of getting the correct full name for a human than -;; any other package we know of. (On the other hand, it will cheerfully -;; mangle non-human names/comments.) -;; 2. Address part is put in a canonical form. -;; -;; The interface is not yet carved in stone; please give us suggestions. -;; -;; We have an extensive test-case collection of funny addresses if you want to -;; work with the code. Developing this code requires frequent testing to -;; make sure you're not breaking functionality. The test cases aren't included -;; because they are over 100K. -;; -;; If you find an address that mail-extr fails on, please send it to the -;; maintainer along with what you think the correct results should be. We do -;; not consider it a bug if mail-extr mangles a comment that does not -;; correspond to a real human full name, although we would prefer that -;; mail-extr would return the comment as-is. -;; -;; Features: -;; -;; * Full name handling: -;; -;; * knows where full names can be found in an address. -;; * avoids using empty comments and quoted text. -;; * extracts full names from mailbox names. -;; * recognizes common formats for comments after a full name. -;; * puts a period and a space after each initial. -;; * understands & referring to the mailbox name, capitalized. -;; * strips name prefixes like "Prof.", etc. -;; * understands what characters can occur in names (not just letters). -;; * figures out middle initial from mailbox name. -;; * removes funny nicknames. -;; * keeps suffixes such as Jr., Sr., III, etc. -;; * reorders "Last, First" type names. -;; -;; * Address handling: -;; -;; * parses rfc822 quoted text, comments, and domain literals. -;; * parses rfc822 multi-line headers. -;; * does something reasonable with rfc822 GROUP addresses. -;; * handles many rfc822 noncompliant and garbage addresses. -;; * canonicalizes addresses (after stripping comments/phrases outside <>). -;; * converts ! addresses into .UUCP and %-style addresses. -;; * converts rfc822 ROUTE addresses to %-style addresses. -;; * truncates %-style addresses at leftmost fully qualified domain name. -;; * handles local relative precedence of ! vs. % and @ (untested). -;; -;; It does almost no string creation. It primarily uses the built-in -;; parsing routines with the appropriate syntax tables. This should -;; result in greater speed. -;; -;; TODO: -;; -;; * handle all test cases. (This will take forever.) -;; * software to pick the correct header to use (eg., "Senders-Name:"). -;; * multiple addresses in the "From:" header (almost all of the necessary -;; code is there). -;; * flag to not treat `,' as an address separator. (This is useful when -;; there is a "From:" header but no "Sender:" header, because then there -;; is only allowed to be one address.) -;; * mailbox name does not necessarily contain full name. -;; * fixing capitalization when it's all upper or lowercase. (Hard!) -;; * some of the domain literal handling is missing. (But I've never even -;; seen one of these in a mail address, so maybe no big deal.) -;; * arrange to have syntax tables byte-compiled. -;; * speed hacks. -;; * delete unused variables. -;; * arrange for testing with different relative precedences of ! vs. @ -;; and %. -;; * insert documentation strings! -;; * handle X.400-gatewayed addresses according to RFC 1148. - -;;; Change Log: -;; -;; Thu Feb 17 17:57:33 1994 Jamie Zawinski (jwz@lucid.com) -;; -;; * merged with jbw's latest version -;; -;; Wed Feb 9 21:56:27 1994 Jamie Zawinski (jwz@lucid.com) -;; -;; * high-bit chars in comments weren't treated as word syntax -;; -;; Sat Feb 5 03:13:40 1994 Jamie Zawinski (jwz@lucid.com) -;; -;; * call replace-match with fixed-case arg -;; -;; Thu Dec 16 21:56:45 1993 Jamie Zawinski (jwz@lucid.com) -;; -;; * some more cleanup, doc, added provide -;; -;; Tue Mar 23 21:23:18 1993 Joe Wells (jbw at csd.bu.edu) -;; -;; * Made mail-full-name-prefixes a user-customizable variable. -;; Allow passing the address as a buffer as well as as a string. -;; Allow [ and ] as name characters (Finnish character set). -;; -;; Mon Mar 22 21:20:56 1993 Joe Wells (jbw at bigbird.bu.edu) -;; -;; * Handle "null" addresses. Handle = used for spacing in mailbox -;; name. Fix bug in handling of ROUTE-ADDR-type addresses that are -;; missing their brackets. Handle uppercase "JR". Extract full -;; names from X.400 addresses encoded in RFC-822. Fix bug in -;; handling of multiple addresses where first has trailing comment. -;; Handle more kinds of telephone extension lead-ins. -;; -;; Mon Mar 22 20:16:57 1993 Joe Wells (jbw at bigbird.bu.edu) -;; -;; * Handle HZ encoding for embedding GB encoded chinese characters. -;; -;; Mon Mar 22 00:46:12 1993 Joe Wells (jbw at bigbird.bu.edu) -;; -;; * Fixed too broad matching of ham radio call signs. Fixed bug in -;; handling an unmatched ' in a name string. Enhanced recognition -;; of when . in the mailbox name terminates the name portion. -;; Narrowed conversion of . to space to only the necessary -;; situation. Deal with VMS's stupid date stamps. Handle a unique -;; way of introducing an alternate address. Fixed spacing bug I -;; introduced in switching last name order. Fixed bug in handling -;; address with ! and % but no @. Narrowed the cases in which -;; certain trailing words are discarded. -;; -;; Sun Mar 21 21:41:06 1993 Joe Wells (jbw at bigbird.bu.edu) -;; -;; * Fixed bugs in handling GROUP addresses. Certain words in the -;; middle of a name no longer terminate it. Handle LISTSERV list -;; names. Ignore comment field containing mailbox name. -;; -;; Sun Mar 21 14:39:38 1993 Joe Wells (jbw at bigbird.bu.edu) -;; -;; * Moved variant-method code back into main function. Handle -;; underscores as spaces in comments. Handle leading nickname. Add -;; flag to ignore single-word names. Other changes. -;; -;; Mon Feb 1 22:23:31 1993 Joe Wells (jbw at bigbird.bu.edu) -;; -;; * Added in changes by Rod Whitby and Jamie Zawinski. This -;; includes the flag mail-extr-guess-middle-initial and the fix for -;; handling multiple addresses correctly. (Whitby just changed -;; a > to a <.) -;; -;; Mon Apr 6 23:59:09 1992 Joe Wells (jbw at bigbird.bu.edu) -;; -;; * Cleaned up some more. Release version 1.0 to world. -;; -;; Sun Apr 5 19:39:08 1992 Joe Wells (jbw at bigbird.bu.edu) -;; -;; * Cleaned up full name extraction extensively. -;; -;; Sun Feb 2 14:45:24 1992 Joe Wells (jbw at bigbird.bu.edu) -;; -;; * Total rewrite. Integrated mail-canonicalize-address into -;; mail-extract-address-components. Now handles GROUP addresses more -;; or less correctly. Better handling of lots of different cases. -;; -;; Fri Jun 14 19:39:50 1991 -;; * Created. - -;;; Code: - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; User configuration variable definitions. -;; - -(defvar mail-extr-guess-middle-initial nil - "*Whether to try to guess middle initial from mail address. -If true, then when we see an address like \"John Smith <jqs@host.com>\" -we will assume that \"John Q. Smith\" is the fellow's name.") - -(defvar mail-extr-ignore-single-names t - "*Whether to ignore a name that is just a single word. -If true, then when we see an address like \"Idiot <dumb@stupid.com>\" -we will act as though we couldn't find a full name in the address.") - -;; Matches a leading title that is not part of the name (does not -;; contribute to uniquely identifying the person). -(defvar mail-extr-full-name-prefixes - (purecopy - "\\(Prof\\|D[Rr]\\|Mrs?\\|Rev\\|Rabbi\\|SysOp\\|LCDR\\)\\.?[ \t\n]") - "*Matches prefixes to the full name that identify a person's position. -These are stripped from the full name because they do not contribute to -uniquely identifying the person.") - -(defvar mail-extr-@-binds-tighter-than-! nil - "*Whether the local mail transport agent looks at ! before @.") - -(defvar mail-extr-mangle-uucp nil - "*Whether to throw away information in UUCP addresses -by translating things like \"foo!bar!baz@host\" into \"baz@bar.UUCP\".") - -;;---------------------------------------------------------------------- -;; what orderings are meaningful????? -;;(defvar mail-operator-precedence-list '(?! ?% ?@)) -;; Right operand of a % or a @ must be a domain name, period. No other -;; operators allowed. Left operand of a @ is an address relative to that -;; site. - -;; Left operand of a ! must be a domain name. Right operand is an -;; arbitrary address. -;;---------------------------------------------------------------------- - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Constant definitions. -;; - -;; Codes in -;; Names in ISO 8859-1 Name -;; ISO 10XXX ISO 8859-2 in -;; ISO 6937 ISO 10646 RFC Swedish -;; etc. Hex Oct 1345 TeX Split ASCII Description -;; --------- ---------- ---- --- ----- ----- ------------------------------- -;; %a E4 344 a: \"a ae { latin small a + diaeresis d -;; %o F6 366 o: \"o oe | latin small o + diaeresis v -;; @a E5 345 aa \oa aa } latin small a + ring above e -;; %u FC 374 u: \"u ue ~ latin small u + diaeresis | -;; /e E9 351 e' \'e ` latin small e + acute i -;; %A C4 304 A: \"A AE [ latin capital a + diaeresis D -;; %O D6 326 O: \"O OE \ latin capital o + diaeresis V -;; @A C5 305 AA \oA AA ] latin capital a + ring above E -;; %U DC 334 U: \"U UE ^ latin capital u + diaeresis \ -;; /E C9 311 E' \'E @ latin capital e + acute I - -;; NOTE: @a and @A are not in ISO 8859-2 (the codes mentioned above invoke -;; /l and /L). Some of this data was retrieved from -;; listserv@jhuvm.hcf.jhu.edu. - -;; Any character that can occur in a name, not counting characters that -;; separate parts of a multipart name (hyphen and period). -;; Yes, there are weird people with digits in their names. -;; You will also notice the consideration for the -;; Swedish/Finnish/Norwegian character set. -(defconst mail-extr-all-letters-but-separators - (purecopy "][A-Za-z{|}'~0-9`\200-\377")) - -;; Any character that can occur in a name in an RFC822 address including -;; the separator (hyphen and possibly period) for multipart names. -;; #### should . be in here? -(defconst mail-extr-all-letters - (purecopy (concat mail-extr-all-letters-but-separators "---"))) - -;; Any character that can start a name. -;; Keep this set as minimal as possible. -(defconst mail-extr-first-letters (purecopy "A-Za-z\200-\377")) - -;; Any character that can end a name. -;; Keep this set as minimal as possible. -(defconst mail-extr-last-letters (purecopy "A-Za-z\200-\377`'.")) - -(defconst mail-extr-leading-garbage - (purecopy (format "[^%s]+" mail-extr-first-letters))) - -;; (defconst mail-extr-non-name-chars -;; (purecopy (concat "^" mail-extr-all-letters "."))) -;; (defconst mail-extr-non-begin-name-chars -;; (purecopy (concat "^" mail-extr-first-letters))) -;; (defconst mail-extr-non-end-name-chars -;; (purecopy (concat "^" mail-extr-last-letters))) - -;; Matches an initial not followed by both a period and a space. -;; (defconst mail-extr-bad-initials-pattern -;; (purecopy -;; (format "\\(\\([^%s]\\|\\`\\)[%s]\\)\\(\\.\\([^ ]\\)\\| \\|\\([^%s .]\\)\\|\\'\\)" -;; mail-extr-all-letters mail-extr-first-letters mail-extr-all-letters))) - -;; Matches periods used instead of spaces. Must not match the period -;; following an initial. -(defconst mail-extr-bad-dot-pattern - (purecopy - (format "\\([%s][%s]\\)\\.+\\([%s]\\)" - mail-extr-all-letters - mail-extr-last-letters - mail-extr-first-letters))) - -;; Matches an embedded or leading nickname that should be removed. -;; (defconst mail-extr-nickname-pattern -;; (purecopy -;; (format "\\([ .]\\|\\`\\)[\"'`\[\(]\\([ .%s]+\\)[\]\"'\)] " -;; mail-extr-all-letters))) - -;; Matches the occurrence of a generational name suffix, and the last -;; character of the preceding name. This is important because we want to -;; keep such suffixes: they help to uniquely identify the person. -;; *** Perhaps this should be a user-customizable variable. However, the -;; *** regular expression is fairly tricky to alter, so maybe not. -(defconst mail-extr-full-name-suffix-pattern - (purecopy - (format - "\\(,? ?\\([JjSs][Rr]\\.?\\|V?I+V?\\)\\)\\([^%s]\\([^%s]\\|\\'\\)\\|\\'\\)" - mail-extr-all-letters mail-extr-all-letters))) - -(defconst mail-extr-roman-numeral-pattern (purecopy "V?I+V?\\b")) - -;; Matches a trailing uppercase (with other characters possible) acronym. -;; Must not match a trailing uppercase last name or trailing initial -(defconst mail-extr-weird-acronym-pattern - (purecopy "\\([A-Z]+[-_/]\\|[A-Z][A-Z][A-Z]?\\b\\)")) - -;; Matches a mixed-case or lowercase name (not an initial). -;; #### Match Latin1 lower case letters here too? -;; (defconst mail-extr-mixed-case-name-pattern -;; (purecopy -;; (format -;; "\\b\\([a-z][%s]*[%s]\\|[%s][%s]*[a-z][%s]*[%s]\\|[%s][%s]*[a-z]\\)" -;; mail-extr-all-letters mail-extr-last-letters -;; mail-extr-first-letters mail-extr-all-letters mail-extr-all-letters -;; mail-extr-last-letters mail-extr-first-letters mail-extr-all-letters))) - -;; Matches a trailing alternative address. -;; #### Match Latin1 letters here too? -;; #### Match _ before @ here too? -(defconst mail-extr-alternative-address-pattern - (purecopy "\\(aka *\\)?[a-zA-Z.]+[!@][a-zA-Z.]")) - -;; Matches a variety of trailing comments not including comma-delimited -;; comments. -(defconst mail-extr-trailing-comment-start-pattern - (purecopy " [-{]\\|--\\|[+@#></\;]")) - -;; Matches a name (not an initial). -;; This doesn't force a word boundary at the end because sometimes a -;; comment is separated by a `-' with no preceding space. -(defconst mail-extr-name-pattern - (purecopy (format "\\b[%s][%s]*[%s]" - mail-extr-first-letters - mail-extr-all-letters - mail-extr-last-letters))) - -(defconst mail-extr-initial-pattern - (purecopy (format "\\b[%s]\\([. ]\\|\\b\\)" mail-extr-first-letters))) - -;; Matches a single name before a comma. -;; (defconst mail-extr-last-name-first-pattern -;; (purecopy (concat "\\`" mail-extr-name-pattern ","))) - -;; Matches telephone extensions. -(defconst mail-extr-telephone-extension-pattern - (purecopy - "\\(\\([Ee]xt\\|\\|[Tt]ph\\|[Tt]el\\|[Xx]\\).?\\)? *\\+?[0-9][- 0-9]+")) - -;; Matches ham radio call signs. -;; Help from: Mat Maessen N2NJZ <maessm@rpi.edu>, Mark Feit -;; <mark@era.com>, Michael Covington <mcovingt@ai.uga.edu>. -;; Examples: DX504 DX515 K5MRU K8DHK KA9WGN KA9WGN KD3FU KD6EUI KD6HBW -;; KE9TV KF0NV N1API N3FU N3GZE N3IGS N4KCC N7IKQ N9HHU W4YHF W6ANK WA2SUH -;; WB7VZI N2NJZ NR3G KJ4KK AB4UM AL7NI KH6OH WN3KBT N4TMI W1A N0NZO -(defconst mail-extr-ham-call-sign-pattern - (purecopy "\\b\\(DX[0-9]+\\|[AKNW][A-Z]?[0-9][A-Z][A-Z]?[A-Z]?\\)")) - -;; Possible trailing suffixes: "\\(/\\(KT\\|A[AEG]\\|[R0-9]\\)\\)?" -;; /KT == Temporary Technician (has CSC but not "real" license) -;; /AA == Temporary Advanced -;; /AE == Temporary Extra -;; /AG == Temporary General -;; /R == repeater -;; /# == stations operating out of home district -;; I don't include these in the regexp above because I can't imagine -;; anyone putting them with their name in an e-mail address. - -;; Matches normal single-part name -(defconst mail-extr-normal-name-pattern - (purecopy (format "\\b[%s][%s]+[%s]" - mail-extr-first-letters - mail-extr-all-letters-but-separators - mail-extr-last-letters))) - -;; Matches a single word name. -;; (defconst mail-extr-one-name-pattern -;; (purecopy (concat "\\`" mail-extr-normal-name-pattern "\\'"))) - -;; Matches normal two names with missing middle initial -;; The first name is not allowed to have a hyphen because this can cause -;; false matches where the "middle initial" is actually the first letter -;; of the second part of the first name. -(defconst mail-extr-two-name-pattern - (purecopy - (concat "\\`\\(" mail-extr-normal-name-pattern - "\\|" mail-extr-initial-pattern - "\\) +\\(" mail-extr-name-pattern "\\)\\(,\\|\\'\\)"))) - -(defconst mail-extr-listserv-list-name-pattern - (purecopy "Multiple recipients of list \\([-A-Z]+\\)")) - -(defconst mail-extr-stupid-vms-date-stamp-pattern - (purecopy - "[0-9][0-9]-[JFMASOND][aepuco][nbrylgptvc]-[0-9][0-9][0-9][0-9] [0-9]+ *")) - -;;; HZ -- GB (PRC Chinese character encoding) in ASCII embedding protocol -;; -;; In ASCII mode, a byte is interpreted as an ASCII character, unless a '~' is -;; encountered. The character '~' is an escape character. By convention, it -;; must be immediately followed ONLY by '~', '{' or '\n' (<LF>), with the -;; following special meaning. -;; -;; o The escape sequence '~~' is interpreted as a '~'. -;; o The escape-to-GB sequence '~{' switches the mode from ASCII to GB. -;; o The escape sequence '~\n' is a line-continuation marker to be consumed -;; with no output produced. -;; -;; In GB mode, characters are interpreted two bytes at a time as (pure) GB -;; codes until the escape-from-GB code '~}' is read. This code switches the -;; mode from GB back to ASCII. (Note that the escape-from-GB code '~}' -;; ($7E7D) is outside the defined GB range.) -(defconst mail-extr-hz-embedded-gb-encoded-chinese-pattern - (purecopy "~{\\([^~].\\|~[^\}]\\)+~}")) - -;; The leading optional lowercase letters are for a bastardized version of -;; the encoding, as is the optional nature of the final slash. -(defconst mail-extr-x400-encoded-address-pattern - (purecopy "[a-z]?[a-z]?\\(/[A-Za-z]+\\(\\.[A-Za-z]+\\)?=[^/]+\\)+/?\\'")) - -(defconst mail-extr-x400-encoded-address-field-pattern-format - (purecopy "/%s=\\([^/]+\\)\\(/\\|\\'\\)")) - -(defconst mail-extr-x400-encoded-address-surname-pattern - ;; S stands for Surname (family name). - (purecopy - (format mail-extr-x400-encoded-address-field-pattern-format "[Ss]"))) - -(defconst mail-extr-x400-encoded-address-given-name-pattern - ;; G stands for Given name. - (purecopy - (format mail-extr-x400-encoded-address-field-pattern-format "[Gg]"))) - -(defconst mail-extr-x400-encoded-address-full-name-pattern - ;; PN stands for Personal Name. When used it represents the combination - ;; of the G and S fields. - ;; "The one system I used having this field asked it with the prompt - ;; `Personal Name'. But they mapped it into G and S on outgoing real - ;; X.400 addresses. As they mapped G and S into PN on incoming..." - (purecopy - (format mail-extr-x400-encoded-address-field-pattern-format "[Pp][Nn]"))) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Syntax tables used for quick parsing. -;; - -(defconst mail-extr-address-syntax-table (make-syntax-table)) -(defconst mail-extr-address-comment-syntax-table (make-syntax-table)) -(defconst mail-extr-address-domain-literal-syntax-table (make-syntax-table)) -(defconst mail-extr-address-text-comment-syntax-table (make-syntax-table)) -(defconst mail-extr-address-text-syntax-table (make-syntax-table)) -(mapcar - (function - (lambda (pair) - (let ((syntax-table (symbol-value (car pair)))) - (mapcar - (function - (lambda (item) - (if (eq 2 (length item)) - ;; modifying syntax of a single character - (modify-syntax-entry (car item) (car (cdr item)) syntax-table) - ;; modifying syntax of a range of characters - (let ((char (nth 0 item)) - (bound (nth 1 item)) - (syntax (nth 2 item))) - (while (<= char bound) - (modify-syntax-entry char syntax syntax-table) - (setq char (1+ char))))))) - (cdr pair))))) - '((mail-extr-address-syntax-table - (?\000 ?\037 "w") ;control characters - (?\040 " ") ;SPC - (?! ?~ "w") ;printable characters - (?\177 "w") ;DEL - (?\200 ?\377 "w") ;high-bit-on characters - (?\240 " ") ;nobreakspace - (?\t " ") - (?\r " ") - (?\n " ") - (?\( ".") - (?\) ".") - (?< ".") - (?> ".") - (?@ ".") - (?, ".") - (?\; ".") - (?: ".") - (?\\ "\\") - (?\" "\"") - (?. ".") - (?\[ ".") - (?\] ".") - ;; % and ! aren't RFC822 characters, but it is convenient to pretend - (?% ".") - (?! ".") ;; this needs to be word-constituent when not in .UUCP mode - ) - (mail-extr-address-comment-syntax-table - (?\000 ?\377 "w") - (?\040 " ") - (?\240 " ") - (?\t " ") - (?\r " ") - (?\n " ") - (?\( "\(\)") - (?\) "\)\(") - (?\\ "\\")) - (mail-extr-address-domain-literal-syntax-table - (?\000 ?\377 "w") - (?\040 " ") - (?\240 " ") - (?\t " ") - (?\r " ") - (?\n " ") - (?\[ "\(\]") ;?????? - (?\] "\)\[") ;?????? - (?\\ "\\")) - (mail-extr-address-text-comment-syntax-table - (?\000 ?\377 "w") - (?\040 " ") - (?\240 " ") - (?\t " ") - (?\r " ") - (?\n " ") - (?\( "\(\)") - (?\) "\)\(") - (?\[ "\(\]") - (?\] "\)\[") - (?\{ "\(\}") - (?\} "\)\{") - (?\\ "\\") - (?\" "\"") - ;; (?\' "\)\`") - ;; (?\` "\(\'") - ) - (mail-extr-address-text-syntax-table - (?\000 ?\177 ".") - (?\200 ?\377 "w") - (?\040 " ") - (?\t " ") - (?\r " ") - (?\n " ") - (?A ?Z "w") - (?a ?z "w") - (?- "w") - (?\} "w") - (?\{ "w") - (?| "w") - (?\' "w") - (?~ "w") - (?0 ?9 "w")) - )) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Utility functions and macros. -;; - -(defmacro mail-extr-delete-char (n) - ;; in v19, delete-char is compiled as a function call, but delete-region - ;; is byte-coded, so it's much much faster. - (list 'delete-region '(point) (list '+ '(point) n))) - -(defmacro mail-extr-skip-whitespace-forward () - ;; v19 fn skip-syntax-forward is more tasteful, but not byte-coded. - '(skip-chars-forward " \t\n\r\240")) - -(defmacro mail-extr-skip-whitespace-backward () - ;; v19 fn skip-syntax-backward is more tasteful, but not byte-coded. - '(skip-chars-backward " \t\n\r\240")) - - -(defmacro mail-extr-undo-backslash-quoting (beg end) - (`(save-excursion - (save-restriction - (narrow-to-region (, beg) (, end)) - (goto-char (point-min)) - ;; undo \ quoting - (while (search-forward "\\" nil t) - (mail-extr-delete-char -1) - (or (eobp) - (forward-char 1)) - ))))) - -(defmacro mail-extr-nuke-char-at (pos) - (` (save-excursion - (goto-char (, pos)) - (mail-extr-delete-char 1) - (insert ?\ )))) - -(put 'mail-extr-nuke-outside-range - 'edebug-form-spec '(symbolp &optional form form atom)) - -(defmacro mail-extr-nuke-outside-range (list-symbol - beg-symbol end-symbol - &optional no-replace) - ;; LIST-SYMBOL names a variable holding a list of buffer positions - ;; BEG-SYMBOL and END-SYMBOL name variables delimiting a range - ;; Each element of LIST-SYMBOL which lies outside of the range is - ;; deleted from the list. - ;; Unless NO-REPLACE is true, at each of the positions in LIST-SYMBOL - ;; which lie outside of the range, one character at that position is - ;; replaced with a SPC. - (or (memq no-replace '(t nil)) - (error "no-replace must be t or nil, evaluable at macroexpand-time")) - (` (let ((temp (, list-symbol)) - ch) - (while temp - (setq ch (car temp)) - (cond ((or (> ch (, end-symbol)) - (< ch (, beg-symbol))) - (,@ (if no-replace - nil - (` ((mail-extr-nuke-char-at ch))))) - (setcar temp nil))) - (setq temp (cdr temp))) - (setq (, list-symbol) (delq nil (, list-symbol)))))) - -(defun mail-extr-demarkerize (marker) - ;; if arg is a marker, destroys the marker, then returns the old value. - ;; otherwise returns the arg. - (if (markerp marker) - (let ((temp (marker-position marker))) - (set-marker marker nil) - temp) - marker)) - -(defun mail-extr-markerize (pos) - ;; coerces pos to a marker if non-nil. - (if (or (markerp pos) (null pos)) - pos - (copy-marker pos))) - -(defmacro mail-extr-last (list) - ;; Returns last element of LIST. - ;; Could be a subst. - (` (let ((list (, list))) - (while (not (null (cdr list))) - (setq list (cdr list))) - (car list)))) - -(defmacro mail-extr-safe-move-sexp (arg) - ;; Safely skip over one balanced sexp, if there is one. Return t if success. - (` (condition-case error - (progn - (goto-char (or (scan-sexps (point) (, arg)) (point))) - t) - (error - ;; #### kludge kludge kludge kludge kludge kludge kludge !!! - (if (string-equal (nth 1 error) "Unbalanced parentheses") - nil - (while t - (signal (car error) (cdr error)))))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; The main function to grind addresses -;; - -(defvar disable-initial-guessing-flag) ; dynamic assignment -(defvar cbeg) ; dynamic assignment -(defvar cend) ; dynamic assignment - -;;;###autoload -(defun mail-extract-address-components (address) - "Given an RFC-822 ADDRESS, extract full name and canonical address. -Returns a list of the form (FULL-NAME CANONICAL-ADDRESS). -If no name can be extracted, FULL-NAME will be nil. -ADDRESS may be a string or a buffer. If it is a buffer, the visible - (narrowed) portion of the buffer will be interpreted as the address. - (This feature exists so that the clever caller might be able to avoid - consing a string.) -If ADDRESS contains more than one RFC-822 address, only the first is - returned. Some day this function may be extended to extract multiple - addresses, or perhaps return the position at which parsing stopped." - (let ((canonicalization-buffer (get-buffer-create " *canonical address*")) - (extraction-buffer (get-buffer-create " *extract address components*")) - char -;; multiple-addresses - <-pos >-pos @-pos :-pos comma-pos !-pos %-pos \;-pos - group-:-pos group-\;-pos route-addr-:-pos - record-pos-symbol - first-real-pos last-real-pos - phrase-beg phrase-end - cbeg cend ; dynamically set from -voodoo - quote-beg quote-end - atom-beg atom-end - mbox-beg mbox-end - \.-ends-name - temp -;; name-suffix - fi mi li ; first, middle, last initial - saved-%-pos saved-!-pos saved-@-pos - domain-pos \.-pos insert-point -;; mailbox-name-processed-flag - disable-initial-guessing-flag ; dynamically set from -voodoo - ) - - (save-excursion - (set-buffer extraction-buffer) - (fundamental-mode) - (kill-all-local-variables) - (buffer-disable-undo extraction-buffer) - (set-syntax-table mail-extr-address-syntax-table) - (widen) - (erase-buffer) - (setq case-fold-search nil) - - ;; Insert extra space at beginning to allow later replacement with < - ;; without having to move markers. - (insert ?\ ) - - ;; Insert the address itself. - (cond ((stringp address) - (insert address)) - ((bufferp address) - (insert-buffer-substring address)) - (t - (error "Invalid address: %s" address))) - - (set-text-properties (point-min) (point-max) nil) - - ;; stolen from rfc822.el - ;; Unfold multiple lines. - (goto-char (point-min)) - (while (re-search-forward "\\([^\\]\\(\\\\\\\\\\)*\\)\n[ \t]" nil t) - (replace-match "\\1 " t)) - - ;; first pass grabs useful information about address - (goto-char (point-min)) - (while (progn - (mail-extr-skip-whitespace-forward) - (not (eobp))) - (setq char (char-after (point))) - (or first-real-pos - (if (not (eq char ?\()) - (setq first-real-pos (point)))) - (cond - ;; comment - ((eq char ?\() - (set-syntax-table mail-extr-address-comment-syntax-table) - ;; only record the first non-empty comment's position - (if (and (not cbeg) - (save-excursion - (forward-char 1) - (mail-extr-skip-whitespace-forward) - (not (eq ?\) (char-after (point)))))) - (setq cbeg (point))) - ;; TODO: don't record if unbalanced - (or (mail-extr-safe-move-sexp 1) - (forward-char 1)) - (set-syntax-table mail-extr-address-syntax-table) - (if (and cbeg - (not cend)) - (setq cend (point)))) - ;; quoted text - ((eq char ?\") - ;; only record the first non-empty quote's position - (if (and (not quote-beg) - (save-excursion - (forward-char 1) - (mail-extr-skip-whitespace-forward) - (not (eq ?\" (char-after (point)))))) - (setq quote-beg (point))) - ;; TODO: don't record if unbalanced - (or (mail-extr-safe-move-sexp 1) - (forward-char 1)) - (if (and quote-beg - (not quote-end)) - (setq quote-end (point)))) - ;; domain literals - ((eq char ?\[) - (set-syntax-table mail-extr-address-domain-literal-syntax-table) - (or (mail-extr-safe-move-sexp 1) - (forward-char 1)) - (set-syntax-table mail-extr-address-syntax-table)) - ;; commas delimit addresses when outside < > pairs. - ((and (eq char ?,) - (or (and (null <-pos) - ;; Handle ROUTE-ADDR address that is missing its <. - (not (eq ?@ (char-after (1+ (point)))))) - (and >-pos - ;; handle weird munged addresses - ;; BUG FIX: This test was reversed. Thanks to the - ;; brilliant Rod Whitby <rwhitby@research.canon.oz.au> - ;; for discovering this! - (< (mail-extr-last <-pos) (car >-pos))))) -;; It'd be great if some day this worked, but for now, punt. -;; (setq multiple-addresses t) -;; ;; *** Why do I want this: -;; (mail-extr-delete-char 1) -;; (narrow-to-region (point-min) (point)) - (delete-region (point) (point-max)) - (setq char ?\() ; HAVE I NO SHAME?? - ) - ;; record the position of various interesting chars, determine - ;; legality later. - ((setq record-pos-symbol - (cdr (assq char - '((?< . <-pos) (?> . >-pos) (?@ . @-pos) - (?: . :-pos) (?, . comma-pos) (?! . !-pos) - (?% . %-pos) (?\; . \;-pos))))) - (set record-pos-symbol - (cons (point) (symbol-value record-pos-symbol))) - (forward-char 1)) - ((eq char ?.) - (forward-char 1)) - ((memq char '( - ;; comment terminator illegal - ?\) - ;; domain literal terminator illegal - ?\] - ;; \ allowed only within quoted strings, - ;; domain literals, and comments - ?\\ - )) - (mail-extr-nuke-char-at (point)) - (forward-char 1)) - (t - (forward-word 1))) - (or (eq char ?\() - ;; At the end of first address of a multiple address header. - (and (eq char ?,) - (eobp)) - (setq last-real-pos (point)))) - - ;; Use only the leftmost <, if any. Replace all others with spaces. - (while (cdr <-pos) - (mail-extr-nuke-char-at (car <-pos)) - (setq <-pos (cdr <-pos))) - - ;; Use only the rightmost >, if any. Replace all others with spaces. - (while (cdr >-pos) - (mail-extr-nuke-char-at (nth 1 >-pos)) - (setcdr >-pos (nthcdr 2 >-pos))) - - ;; If multiple @s and a :, but no < and >, insert around buffer. - ;; Example: @foo.bar.dom,@xxx.yyy.zzz:mailbox@aaa.bbb.ccc - ;; This commonly happens on the UUCP "From " line. Ugh. - (cond ((and (> (length @-pos) 1) - (eq 1 (length :-pos)) ;TODO: check if between last two @s - (not \;-pos) - (not <-pos)) - (goto-char (point-min)) - (mail-extr-delete-char 1) - (setq <-pos (list (point))) - (insert ?<))) - - ;; If < but no >, insert > in rightmost possible position - (cond ((and <-pos - (null >-pos)) - (goto-char (point-max)) - (setq >-pos (list (point))) - (insert ?>))) - - ;; If > but no <, replace > with space. - (cond ((and >-pos - (null <-pos)) - (mail-extr-nuke-char-at (car >-pos)) - (setq >-pos nil))) - - ;; Turn >-pos and <-pos into non-lists - (setq >-pos (car >-pos) - <-pos (car <-pos)) - - ;; Trim other punctuation lists of items outside < > pair to handle - ;; stupid MTAs. - (cond (<-pos ; don't need to check >-pos also - ;; handle bozo software that violates RFC 822 by sticking - ;; punctuation marks outside of a < > pair - (mail-extr-nuke-outside-range @-pos <-pos >-pos t) - ;; RFC 822 says nothing about these two outside < >, but - ;; remove those positions from the lists to make things - ;; easier. - (mail-extr-nuke-outside-range !-pos <-pos >-pos t) - (mail-extr-nuke-outside-range %-pos <-pos >-pos t))) - - ;; Check for : that indicates GROUP list and for : part of - ;; ROUTE-ADDR spec. - ;; Can't possibly be more than two :. Nuke any extra. - (while :-pos - (setq temp (car :-pos) - :-pos (cdr :-pos)) - (cond ((and <-pos >-pos - (> temp <-pos) - (< temp >-pos)) - (if (or route-addr-:-pos - (< (length @-pos) 2) - (> temp (car @-pos)) - (< temp (nth 1 @-pos))) - (mail-extr-nuke-char-at temp) - (setq route-addr-:-pos temp))) - ((or (not <-pos) - (and <-pos - (< temp <-pos))) - (setq group-:-pos temp)))) - - ;; Nuke any ; that is in or to the left of a < > pair or to the left - ;; of a GROUP starting :. Also, there may only be one ;. - (while \;-pos - (setq temp (car \;-pos) - \;-pos (cdr \;-pos)) - (cond ((and <-pos >-pos - (> temp <-pos) - (< temp >-pos)) - (mail-extr-nuke-char-at temp)) - ((and (or (not group-:-pos) - (> temp group-:-pos)) - (not group-\;-pos)) - (setq group-\;-pos temp)))) - - ;; Nuke unmatched GROUP syntax characters. - (cond ((and group-:-pos (not group-\;-pos)) - ;; *** Do I really need to erase it? - (mail-extr-nuke-char-at group-:-pos) - (setq group-:-pos nil))) - (cond ((and group-\;-pos (not group-:-pos)) - ;; *** Do I really need to erase it? - (mail-extr-nuke-char-at group-\;-pos) - (setq group-\;-pos nil))) - - ;; Handle junk like ";@host.company.dom" that sendmail adds. - ;; **** should I remember comment positions? - (cond - (group-\;-pos - ;; this is fine for now - (mail-extr-nuke-outside-range !-pos group-:-pos group-\;-pos t) - (mail-extr-nuke-outside-range @-pos group-:-pos group-\;-pos t) - (mail-extr-nuke-outside-range %-pos group-:-pos group-\;-pos t) - (mail-extr-nuke-outside-range comma-pos group-:-pos group-\;-pos t) - (and last-real-pos - (> last-real-pos (1+ group-\;-pos)) - (setq last-real-pos (1+ group-\;-pos))) - ;; *** This may be wrong: - (and cend - (> cend group-\;-pos) - (setq cend nil - cbeg nil)) - (and quote-end - (> quote-end group-\;-pos) - (setq quote-end nil - quote-beg nil)) - ;; This was both wrong and unnecessary: - ;;(narrow-to-region (point-min) group-\;-pos) - - ;; *** The entire handling of GROUP addresses seems rather lame. - ;; *** It deserves a complete rethink, except that these addresses - ;; *** are hardly ever seen. - )) - - ;; Any commas must be between < and : of ROUTE-ADDR. Nuke any - ;; others. - ;; Hell, go ahead an nuke all of the commas. - ;; **** This will cause problems when we start handling commas in - ;; the PHRASE part .... no it won't ... yes it will ... ????? - (mail-extr-nuke-outside-range comma-pos 1 1) - - ;; can only have multiple @s inside < >. The fact that some MTAs - ;; put de-bracketed ROUTE-ADDRs in the UUCP-style "From " line is - ;; handled above. - - ;; Locate PHRASE part of ROUTE-ADDR. - (cond (<-pos - (goto-char <-pos) - (mail-extr-skip-whitespace-backward) - (setq phrase-end (point)) - (goto-char (or ;;group-:-pos - (point-min))) - (mail-extr-skip-whitespace-forward) - (if (< (point) phrase-end) - (setq phrase-beg (point)) - (setq phrase-end nil)))) - - ;; handle ROUTE-ADDRS with real ROUTEs. - ;; If there are multiple @s, then we assume ROUTE-ADDR syntax, and - ;; any % or ! must be semantically meaningless. - ;; TODO: do this processing into canonicalization buffer - (cond (route-addr-:-pos - (setq !-pos nil - %-pos nil - >-pos (copy-marker >-pos) - route-addr-:-pos (copy-marker route-addr-:-pos)) - (goto-char >-pos) - (insert-before-markers ?X) - (goto-char (car @-pos)) - (while (setq @-pos (cdr @-pos)) - (mail-extr-delete-char 1) - (setq %-pos (cons (point-marker) %-pos)) - (insert "%") - (goto-char (1- >-pos)) - (save-excursion - (insert-buffer-substring extraction-buffer - (car @-pos) route-addr-:-pos) - (delete-region (car @-pos) route-addr-:-pos)) - (or (cdr @-pos) - (setq saved-@-pos (list (point))))) - (setq @-pos saved-@-pos) - (goto-char >-pos) - (mail-extr-delete-char -1) - (mail-extr-nuke-char-at route-addr-:-pos) - (mail-extr-demarkerize route-addr-:-pos) - (setq route-addr-:-pos nil - >-pos (mail-extr-demarkerize >-pos) - %-pos (mapcar 'mail-extr-demarkerize %-pos)))) - - ;; de-listify @-pos - (setq @-pos (car @-pos)) - - ;; TODO: remove comments in the middle of an address - - (set-buffer canonicalization-buffer) - (fundamental-mode) - (kill-all-local-variables) - (buffer-disable-undo canonicalization-buffer) - (set-syntax-table mail-extr-address-syntax-table) - (setq case-fold-search nil) - - (widen) - (erase-buffer) - (insert-buffer-substring extraction-buffer) - - (if <-pos - (narrow-to-region (progn - (goto-char (1+ <-pos)) - (mail-extr-skip-whitespace-forward) - (point)) - >-pos) - (if (and first-real-pos last-real-pos) - (narrow-to-region first-real-pos last-real-pos) - ;; ****** Oh no! What if the address is completely empty! - ;; *** Is this correct? - (narrow-to-region (point-max) (point-max)) - )) - - (and @-pos %-pos - (mail-extr-nuke-outside-range %-pos (point-min) @-pos)) - (and %-pos !-pos - (mail-extr-nuke-outside-range !-pos (point-min) (car %-pos))) - (and @-pos !-pos (not %-pos) - (mail-extr-nuke-outside-range !-pos (point-min) @-pos)) - - ;; Error condition:?? (and %-pos (not @-pos)) - - ;; WARNING: THIS CODE IS DUPLICATED BELOW. - (cond ((and %-pos - (not @-pos)) - (goto-char (car %-pos)) - (mail-extr-delete-char 1) - (setq @-pos (point)) - (insert "@") - (setq %-pos (cdr %-pos)))) - - (if mail-extr-mangle-uucp - (cond (!-pos - ;; **** I don't understand this save-restriction and the - ;; narrow-to-region inside it. Why did I do that? - (save-restriction - (cond ((and @-pos - mail-extr-@-binds-tighter-than-!) - (goto-char @-pos) - (setq %-pos (cons (point) %-pos) - @-pos nil) - (mail-extr-delete-char 1) - (insert "%") - (setq insert-point (point-max))) - (mail-extr-@-binds-tighter-than-! - (setq insert-point (point-max))) - (%-pos - (setq insert-point (mail-extr-last %-pos) - saved-%-pos (mapcar 'mail-extr-markerize %-pos) - %-pos nil - @-pos (mail-extr-markerize @-pos))) - (@-pos - (setq insert-point @-pos) - (setq @-pos (mail-extr-markerize @-pos))) - (t - (setq insert-point (point-max)))) - (narrow-to-region (point-min) insert-point) - (setq saved-!-pos (car !-pos)) - (while !-pos - (goto-char (point-max)) - (cond ((and (not @-pos) - (not (cdr !-pos))) - (setq @-pos (point)) - (insert-before-markers "@ ")) - (t - (setq %-pos (cons (point) %-pos)) - (insert-before-markers "% "))) - (backward-char 1) - (insert-buffer-substring - (current-buffer) - (if (nth 1 !-pos) - (1+ (nth 1 !-pos)) - (point-min)) - (car !-pos)) - (mail-extr-delete-char 1) - (or (save-excursion - (mail-extr-safe-move-sexp -1) - (mail-extr-skip-whitespace-backward) - (eq ?. (preceding-char))) - (insert-before-markers - (if (save-excursion - (mail-extr-skip-whitespace-backward) - (eq ?. (preceding-char))) - "" - ".") - "uucp")) - (setq !-pos (cdr !-pos)))) - (and saved-%-pos - (setq %-pos (append (mapcar 'mail-extr-demarkerize - saved-%-pos) - %-pos))) - (setq @-pos (mail-extr-demarkerize @-pos)) - (narrow-to-region (1+ saved-!-pos) (point-max))))) - - ;; WARNING: THIS CODE IS DUPLICATED ABOVE. - (cond ((and %-pos - (not @-pos)) - (goto-char (car %-pos)) - (mail-extr-delete-char 1) - (setq @-pos (point)) - (insert "@") - (setq %-pos (cdr %-pos)))) - - (setq %-pos (nreverse %-pos)) - (cond (%-pos ; implies @-pos valid - (setq temp %-pos) - (catch 'truncated - (while temp - (goto-char (or (nth 1 temp) - @-pos)) - (mail-extr-skip-whitespace-backward) - (save-excursion - (mail-extr-safe-move-sexp -1) - (setq domain-pos (point)) - (mail-extr-skip-whitespace-backward) - (setq \.-pos (eq ?. (preceding-char)))) - (cond ((and \.-pos - ;; #### string consing - (let ((s (intern-soft - (buffer-substring domain-pos (point)) - mail-extr-all-top-level-domains))) - (and s (get s 'domain-name)))) - (narrow-to-region (point-min) (point)) - (goto-char (car temp)) - (mail-extr-delete-char 1) - (setq @-pos (point)) - (setcdr temp nil) - (setq %-pos (delq @-pos %-pos)) - (insert "@") - (throw 'truncated t))) - (setq temp (cdr temp)))))) - (setq mbox-beg (point-min) - mbox-end (if %-pos (car %-pos) - (or @-pos - (point-max)))) - - ;; Done canonicalizing address. - - (set-buffer extraction-buffer) - - ;; Decide what part of the address to search to find the full name. - (cond ( - ;; Example: "First M. Last" <fml@foo.bar.dom> - (and phrase-beg - (eq quote-beg phrase-beg) - (<= quote-end phrase-end)) - (narrow-to-region (1+ quote-beg) (1- quote-end)) - (mail-extr-undo-backslash-quoting (point-min) (point-max))) - - ;; Example: First Last <fml@foo.bar.dom> - (phrase-beg - (narrow-to-region phrase-beg phrase-end)) - - ;; Example: fml@foo.bar.dom (First M. Last) - (cbeg - (narrow-to-region (1+ cbeg) (1- cend)) - (mail-extr-undo-backslash-quoting (point-min) (point-max)) - - ;; Deal with spacing problems - (goto-char (point-min)) -; (cond ((not (search-forward " " nil t)) -; (goto-char (point-min)) -; (cond ((search-forward "_" nil t) -; ;; Handle the *idiotic* use of underlines as spaces. -; ;; Example: fml@foo.bar.dom (First_M._Last) -; (goto-char (point-min)) -; (while (search-forward "_" nil t) -; (replace-match " " t))) -; ((search-forward "." nil t) -; ;; Fix . used as space -; ;; Example: danj1@cb.att.com (daniel.jacobson) -; (goto-char (point-min)) -; (while (re-search-forward mail-extr-bad-dot-pattern nil t) -; (replace-match "\\1 \\2" t)))))) - ) - - ;; Otherwise we try to get the name from the mailbox portion - ;; of the address. - ;; Example: First_M_Last@foo.bar.dom - (t - ;; *** Work in canon buffer instead? No, can't. Hmm. - (goto-char (point-max)) - (narrow-to-region (point) (point)) - (insert-buffer-substring canonicalization-buffer - mbox-beg mbox-end) - (goto-char (point-min)) - - ;; Example: First_Last.XXX@foo.bar.dom - (setq \.-ends-name (re-search-forward "[_0-9]" nil t)) - - (goto-char (point-min)) - - (if (not mail-extr-mangle-uucp) - (modify-syntax-entry ?! "w" (syntax-table))) - - (while (progn - (mail-extr-skip-whitespace-forward) - (not (eobp))) - (setq char (char-after (point))) - (cond - ((eq char ?\") - (setq quote-beg (point)) - (or (mail-extr-safe-move-sexp 1) - ;; TODO: handle this error condition!!!!! - (forward-char 1)) - ;; take into account deletions - (setq quote-end (- (point) 2)) - (save-excursion - (backward-char 1) - (mail-extr-delete-char 1) - (goto-char quote-beg) - (or (eobp) - (mail-extr-delete-char 1))) - (mail-extr-undo-backslash-quoting quote-beg quote-end) - (or (eq ?\ (char-after (point))) - (insert " ")) -;; (setq mailbox-name-processed-flag t) - (setq \.-ends-name t)) - ((eq char ?.) - (if (memq (char-after (1+ (point))) '(?_ ?=)) - (progn - (forward-char 1) - (mail-extr-delete-char 1) - (insert ?\ )) - (if \.-ends-name - (narrow-to-region (point-min) (point)) - (mail-extr-delete-char 1) - (insert " "))) -;; (setq mailbox-name-processed-flag t) - ) - ((memq (char-syntax char) '(?. ?\\)) - (mail-extr-delete-char 1) - (insert " ") -;; (setq mailbox-name-processed-flag t) - ) - (t - (setq atom-beg (point)) - (forward-word 1) - (setq atom-end (point)) - (goto-char atom-beg) - (save-restriction - (narrow-to-region atom-beg atom-end) - (cond - - ;; Handle X.400 addresses encoded in RFC-822. - ;; *** This has to handle the case where it is - ;; *** embedded in a quote too! - ;; *** The input is being broken up into atoms - ;; *** by periods! - ((looking-at mail-extr-x400-encoded-address-pattern) - - ;; Copy the contents of the individual fields that - ;; might hold name data to the beginning. - (mapcar - (function - (lambda (field-pattern) - (cond - ((save-excursion - (re-search-forward field-pattern nil t)) - (insert-buffer-substring (current-buffer) - (match-beginning 1) - (match-end 1)) - (insert " "))))) - (list mail-extr-x400-encoded-address-given-name-pattern - mail-extr-x400-encoded-address-surname-pattern - mail-extr-x400-encoded-address-full-name-pattern)) - - ;; Discard the rest, since it contains stuff like - ;; routing information, not part of a name. - (mail-extr-skip-whitespace-backward) - (delete-region (point) (point-max)) - - ;; Handle periods used for spacing. - (while (re-search-forward mail-extr-bad-dot-pattern nil t) - (replace-match "\\1 \\2" t)) - -;; (setq mailbox-name-processed-flag t) - ) - - ;; Handle normal addresses. - (t - (goto-char (point-min)) - ;; Handle _ and = used for spacing. - (while (re-search-forward "\\([^_=]+\\)[_=]" nil t) - (replace-match "\\1 " t) -;; (setq mailbox-name-processed-flag t) - ) - (goto-char (point-max)))))))) - - ;; undo the dirty deed - (if (not mail-extr-mangle-uucp) - (modify-syntax-entry ?! "." (syntax-table))) - ;; - ;; If we derived the name from the mailbox part of the address, - ;; and we only got one word out of it, don't treat that as a - ;; name. "foo@bar" --> (nil "foo@bar"), not ("foo" "foo@bar") - ;; (if (not mailbox-name-processed-flag) - ;; (delete-region (point-min) (point-max))) - )) - - (set-syntax-table mail-extr-address-text-syntax-table) - - (mail-extr-voodoo mbox-beg mbox-end canonicalization-buffer) - (goto-char (point-min)) - - ;; If name is "First Last" and userid is "F?L", then assume - ;; the middle initial is the second letter in the userid. - ;; Initial code by Jamie Zawinski <jwz@lucid.com> - ;; *** Make it work when there's a suffix as well. - (goto-char (point-min)) - (cond ((and mail-extr-guess-middle-initial - (not disable-initial-guessing-flag) - (eq 3 (- mbox-end mbox-beg)) - (progn - (goto-char (point-min)) - (looking-at mail-extr-two-name-pattern))) - (setq fi (char-after (match-beginning 0)) - li (char-after (match-beginning 3))) - (save-excursion - (set-buffer canonicalization-buffer) - ;; char-equal is ignoring case here, so no need to upcase - ;; or downcase. - (let ((case-fold-search t)) - (and (char-equal fi (char-after mbox-beg)) - (char-equal li (char-after (1- mbox-end))) - (setq mi (char-after (1+ mbox-beg)))))) - (cond ((and mi - ;; TODO: use better table than syntax table - (eq ?w (char-syntax mi))) - (goto-char (match-beginning 3)) - (insert (upcase mi) ". "))))) - - ;; Nuke name if it is the same as mailbox name. - (let ((buffer-length (- (point-max) (point-min))) - (i 0) - (names-match-flag t)) - (cond ((and (> buffer-length 0) - (eq buffer-length (- mbox-end mbox-beg))) - (goto-char (point-max)) - (insert-buffer-substring canonicalization-buffer - mbox-beg mbox-end) - (while (and names-match-flag - (< i buffer-length)) - (or (eq (downcase (char-after (+ i (point-min)))) - (downcase - (char-after (+ i buffer-length (point-min))))) - (setq names-match-flag nil)) - (setq i (1+ i))) - (delete-region (+ (point-min) buffer-length) (point-max)) - (if names-match-flag - (narrow-to-region (point) (point)))))) - - ;; Nuke name if it's just one word. - (goto-char (point-min)) - (and mail-extr-ignore-single-names - (not (re-search-forward "[- ]" nil t)) - (narrow-to-region (point) (point))) - - ;; Result - (list (if (not (= (point-min) (point-max))) - (buffer-string)) - (progn - (set-buffer canonicalization-buffer) - (if (not (= (point-min) (point-max))) - (buffer-string)))) - ))) - -(defun mail-extr-voodoo (mbox-beg mbox-end canonicalization-buffer) - (let ((word-count 0) - (case-fold-search nil) - mixed-case-flag lower-case-flag ;;upper-case-flag - suffix-flag last-name-comma-flag - ;;cbeg cend - initial - begin-again-flag - drop-this-word-if-trailing-flag - drop-last-word-if-trailing-flag - word-found-flag - this-word-beg last-word-beg - name-beg name-end - name-done-flag - ) - (save-excursion - (set-syntax-table mail-extr-address-text-syntax-table) - - ;; This was moved above. - ;; Fix . used as space - ;; But it belongs here because it occurs not only as - ;; rypens@reks.uia.ac.be (Piet.Rypens) - ;; but also as - ;; "Piet.Rypens" <rypens@reks.uia.ac.be> - ;;(goto-char (point-min)) - ;;(while (re-search-forward mail-extr-bad-dot-pattern nil t) - ;; (replace-match "\\1 \\2" t)) - - (cond ((not (search-forward " " nil t)) - (goto-char (point-min)) - (cond ((search-forward "_" nil t) - ;; Handle the *idiotic* use of underlines as spaces. - ;; Example: fml@foo.bar.dom (First_M._Last) - (goto-char (point-min)) - (while (search-forward "_" nil t) - (replace-match " " t))) - ((search-forward "." nil t) - ;; Fix . used as space - ;; Example: danj1@cb.att.com (daniel.jacobson) - (goto-char (point-min)) - (while (re-search-forward mail-extr-bad-dot-pattern nil t) - (replace-match "\\1 \\2" t)))))) - - - ;; Loop over the words (and other junk) in the name. - (goto-char (point-min)) - (while (not name-done-flag) - - (cond (word-found-flag - ;; Last time through this loop we skipped over a word. - (setq last-word-beg this-word-beg) - (setq drop-last-word-if-trailing-flag - drop-this-word-if-trailing-flag) - (setq word-found-flag nil))) - - (cond (begin-again-flag - ;; Last time through the loop we found something that - ;; indicates we should pretend we are beginning again from - ;; the start. - (setq word-count 0) - (setq last-word-beg nil) - (setq drop-last-word-if-trailing-flag nil) - (setq mixed-case-flag nil) - (setq lower-case-flag nil) -;; (setq upper-case-flag nil) - (setq begin-again-flag nil) - )) - - ;; Initialize for this iteration of the loop. - (mail-extr-skip-whitespace-forward) - (if (eq word-count 0) (narrow-to-region (point) (point-max))) - (setq this-word-beg (point)) - (setq drop-this-word-if-trailing-flag nil) - - ;; Decide what to do based on what we are looking at. - (cond - - ;; Delete title - ((and (eq word-count 0) - (looking-at mail-extr-full-name-prefixes)) - (goto-char (match-end 0)) - (narrow-to-region (point) (point-max))) - - ;; Stop after name suffix - ((and (>= word-count 2) - (looking-at mail-extr-full-name-suffix-pattern)) - (mail-extr-skip-whitespace-backward) - (setq suffix-flag (point)) - (if (eq ?, (following-char)) - (forward-char 1) - (insert ?,)) - ;; Enforce at least one space after comma - (or (eq ?\ (following-char)) - (insert ?\ )) - (mail-extr-skip-whitespace-forward) - (cond ((memq (following-char) '(?j ?J ?s ?S)) - (capitalize-word 1) - (if (eq (following-char) ?.) - (forward-char 1) - (insert ?.))) - (t - (upcase-word 1))) - (setq word-found-flag t) - (setq name-done-flag t)) - - ;; Handle SCA names - ((looking-at "MKA \\(.+\\)") ; "Mundanely Known As" - (goto-char (match-beginning 1)) - (narrow-to-region (point) (point-max)) - (setq begin-again-flag t)) - - ;; Check for initial last name followed by comma - ((and (eq ?, (following-char)) - (eq word-count 1)) - (forward-char 1) - (setq last-name-comma-flag t) - (or (eq ?\ (following-char)) - (insert ?\ ))) - - ;; Stop before trailing comma-separated comment - ;; THIS CASE MUST BE AFTER THE PRECEDING CASES. - ;; *** This case is redundant??? - ;;((eq ?, (following-char)) - ;; (setq name-done-flag t)) - - ;; Delete parenthesized/quoted comment/nickname - ((memq (following-char) '(?\( ?\{ ?\[ ?\" ?\' ?\`)) - (setq cbeg (point)) - (set-syntax-table mail-extr-address-text-comment-syntax-table) - (cond ((memq (following-char) '(?\' ?\`)) - (or (search-forward "'" nil t - (if (eq ?\' (following-char)) 2 1)) - (mail-extr-delete-char 1))) - (t - (or (mail-extr-safe-move-sexp 1) - (goto-char (point-max))))) - (set-syntax-table mail-extr-address-text-syntax-table) - (setq cend (point)) - (cond - ;; Handle case of entire name being quoted - ((and (eq word-count 0) - (looking-at " *\\'") - (>= (- cend cbeg) 2)) - (narrow-to-region (1+ cbeg) (1- cend)) - (goto-char (point-min))) - (t - ;; Handle case of quoted initial - (if (and (or (= 3 (- cend cbeg)) - (and (= 4 (- cend cbeg)) - (eq ?. (char-after (+ 2 cbeg))))) - (not (looking-at " *\\'"))) - (setq initial (char-after (1+ cbeg))) - (setq initial nil)) - (delete-region cbeg cend) - (if initial - (insert initial ". "))))) - - ;; Handle & substitution - ((and (or (bobp) - (eq ?\ (preceding-char))) - (looking-at "&\\( \\|\\'\\)")) - (mail-extr-delete-char 1) - (capitalize-region - (point) - (progn - (insert-buffer-substring canonicalization-buffer - mbox-beg mbox-end) - (point))) - (setq disable-initial-guessing-flag t) - (setq word-found-flag t)) - - ;; Handle *Stupid* VMS date stamps - ((looking-at mail-extr-stupid-vms-date-stamp-pattern) - (replace-match "" t)) - - ;; Handle Chinese characters. - ((looking-at mail-extr-hz-embedded-gb-encoded-chinese-pattern) - (goto-char (match-end 0)) - (setq word-found-flag t)) - - ;; Skip initial garbage characters. - ;; THIS CASE MUST BE AFTER THE PRECEDING CASES. - ((and (eq word-count 0) - (looking-at mail-extr-leading-garbage)) - (goto-char (match-end 0)) - ;; *** Skip backward over these??? - ;; (skip-chars-backward "& \"") - (narrow-to-region (point) (point-max))) - - ;; Various stopping points - ((or - - ;; Stop before ALL CAPS acronyms, if preceded by mixed-case - ;; words. Example: XT-DEM. - (and (>= word-count 2) - mixed-case-flag - (looking-at mail-extr-weird-acronym-pattern) - (not (looking-at mail-extr-roman-numeral-pattern))) - - ;; Stop before trailing alternative address - (looking-at mail-extr-alternative-address-pattern) - - ;; Stop before trailing comment not introduced by comma - ;; THIS CASE MUST BE AFTER AN EARLIER CASE. - (looking-at mail-extr-trailing-comment-start-pattern) - - ;; Stop before telephone numbers - (looking-at mail-extr-telephone-extension-pattern)) - (setq name-done-flag t)) - - ;; Delete ham radio call signs - ((looking-at mail-extr-ham-call-sign-pattern) - (delete-region (match-beginning 0) (match-end 0))) - - ;; Fixup initials - ((looking-at mail-extr-initial-pattern) - (or (eq (following-char) (upcase (following-char))) - (setq lower-case-flag t)) - (forward-char 1) - (if (eq ?. (following-char)) - (forward-char 1) - (insert ?.)) - (or (eq ?\ (following-char)) - (insert ?\ )) - (setq word-found-flag t)) - - ;; Handle BITNET LISTSERV list names. - ((and (eq word-count 0) - (looking-at mail-extr-listserv-list-name-pattern)) - (narrow-to-region (match-beginning 1) (match-end 1)) - (setq word-found-flag t) - (setq name-done-flag t)) - - ;; Regular name words - ((looking-at mail-extr-name-pattern) - (setq name-beg (point)) - (setq name-end (match-end 0)) - - ;; Certain words will be dropped if they are at the end. - (and (>= word-count 2) - (not lower-case-flag) - (or - ;; A trailing 4-or-more letter lowercase words preceded by - ;; mixed case or uppercase words will be dropped. - (looking-at "[a-z][a-z][a-z][a-z]+[ \t]*\\'") - ;; Drop a trailing word which is terminated with a period. - (eq ?. (char-after (1- name-end)))) - (setq drop-this-word-if-trailing-flag t)) - - ;; Set the flags that indicate whether we have seen a lowercase - ;; word, a mixed case word, and an uppercase word. - (if (re-search-forward "[a-z]" name-end t) - (if (progn - (goto-char name-beg) - (re-search-forward "[A-Z]" name-end t)) - (setq mixed-case-flag t) - (setq lower-case-flag t)) -;; (setq upper-case-flag t) - ) - - (goto-char name-end) - (setq word-found-flag t)) - - (t - (setq name-done-flag t) - )) - - ;; Count any word that we skipped over. - (if word-found-flag - (setq word-count (1+ word-count)))) - - ;; If the last thing in the name is 2 or more periods, or one or more - ;; other sentence terminators (but not a single period) then keep them - ;; and the preceding word. This is for the benefit of whole sentences - ;; in the name field: it's better behavior than dropping the last word - ;; of the sentence... - (if (and (not suffix-flag) - (looking-at "\\(\\.+\\|[?!;:.][?!;:.]+\\|[?!;:][?!;:.]*\\)\\'")) - (goto-char (setq suffix-flag (point-max)))) - - ;; Drop everything after point and certain trailing words. - (narrow-to-region (point-min) - (or (and drop-last-word-if-trailing-flag - last-word-beg) - (point))) - - ;; Xerox's mailers SUCK!!!!!! - ;; We simply refuse to believe that any last name is PARC or ADOC. - ;; If it looks like that is the last name, that there is no meaningful - ;; here at all. Actually I guess it would be best to map patterns - ;; like foo.hoser@xerox.com into foo@hoser.xerox.com, but I don't - ;; actually know that that is what's going on. - (cond ((not suffix-flag) - (goto-char (point-min)) - (let ((case-fold-search t)) - (if (looking-at "[-A-Za-z_]+[. ]\\(PARC\\|ADOC\\)\\'") - (erase-buffer))))) - - ;; If last name first put it at end (but before suffix) - (cond (last-name-comma-flag - (goto-char (point-min)) - (search-forward ",") - (setq name-end (1- (point))) - (goto-char (or suffix-flag (point-max))) - (or (eq ?\ (preceding-char)) - (insert ?\ )) - (insert-buffer-substring (current-buffer) (point-min) name-end) - (goto-char name-end) - (skip-chars-forward "\t ,") - (narrow-to-region (point) (point-max)))) - - ;; Delete leading and trailing junk characters. - ;; *** This is probably completely unneeded now. - ;;(goto-char (point-max)) - ;;(skip-chars-backward mail-extr-non-end-name-chars) - ;;(if (eq ?. (following-char)) - ;; (forward-char 1)) - ;;(narrow-to-region (point) - ;; (progn - ;; (goto-char (point-min)) - ;; (skip-chars-forward mail-extr-non-begin-name-chars) - ;; (point))) - - ;; Compress whitespace - (goto-char (point-min)) - (while (re-search-forward "[ \t\n]+" nil t) - (replace-match (if (eobp) "" " ") t)) - ))) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Table of top-level domain names. -;; -;; This is used during address canonicalization; be careful of format changes. -;; Keep in mind that the country abbreviations follow ISO-3166. There is -;; a U.S. FIPS that specifies a different set of two-letter country -;; abbreviations. - -(defconst mail-extr-all-top-level-domains - (let ((ob (make-vector 509 0))) - (mapcar - (function - (lambda (x) - (put (intern (downcase (car x)) ob) - 'domain-name - (if (nth 2 x) - (format (nth 2 x) (nth 1 x)) - (nth 1 x))))) - '( - ;; ISO 3166 codes: - ("ae" "United Arab Emirates") - ("ag" "Antigua and Barbuda") - ("al" "Albania") - ("ao" "Angola") - ("aq" "Antarctica") ; continent - ("ar" "Argentina" "Argentine Republic") - ("at" "Austria" "The Republic of %s") - ("au" "Australia") - ("az" "Azerbaijan") - ("bb" "Barbados") - ("bd" "Bangladesh") - ("be" "Belgium" "The Kingdom of %s") - ("bf" "Burkina Faso") - ("bg" "Bulgaria") - ("bh" "Bahrain") - ("bm" "Bermuda") - ("bo" "Bolivia" "Republic of %s") - ("br" "Brazil" "The Federative Republic of %s") - ("bs" "Bahamas") - ("bw" "Botswana") - ("by" "Belarus") - ("bz" "Belize") - ("ca" "Canada") - ("cg" "Congo") - ("ch" "Switzerland" "The Swiss Confederation") - ("ci" "Ivory Coast") - ("cl" "Chile" "The Republic of %s") - ("cm" "Cameroon") ; In .fr domain - ("cn" "China" "The People's Republic of %s") - ("co" "Colombia") - ("cr" "Costa Rica" "The Republic of %s") - ("cs" "Czechoslovakia") - ("cu" "Cuba") - ("cy" "Cyprus") - ("cz" "Czech Republic") - ("de" "Germany") - ("dk" "Denmark") - ("dm" "Dominica") - ("do" "Dominican Republic" "The %s") - ("dz" "Algeria") - ("ec" "Ecuador" "The Republic of %s") - ("ee" "Estonia") - ("eg" "Egypt" "The Arab Republic of %s") - ("er" "Eritrea") - ("es" "Spain" "The Kingdom of %s") - ("fi" "Finland" "The Republic of %s") - ("fj" "Fiji") - ("fo" "Faroe Islands") - ("fr" "France") - ("gb" "Great Britain") - ("gd" "Grenada") - ("ge" "Georgia") - ("gf" "Guyana (Fr.)") - ("gp" "Guadeloupe (Fr.)") - ("gr" "Greece" "The Hellenic Republic (%s)") - ("gt" "Guatemala") - ("gu" "Guam (U.S.)") - ("hk" "Hong Kong") - ("hn" "Honduras") - ("hr" "Croatia") - ("ht" "Haiti") - ("hu" "Hungary" "The Hungarian Republic") ;??? - ("id" "Indonesia") - ("ie" "Ireland") - ("il" "Israel" "The State of %s") - ("in" "India" "The Republic of %s") - ("ir" "Iran") - ("is" "Iceland" "The Republic of %s") - ("it" "Italy" "The Italian Republic") - ("jm" "Jamaica") - ("jp" "Japan") - ("ke" "Kenya") - ("kn" "St. Kitts, Nevis, and Anguilla") - ("kp" "Korea (North)") - ("kr" "Korea (South)") - ("kw" "Kuwait") - ("kz" "Kazakhstan") - ("lb" "Lebanon") - ("lc" "St. Lucia") - ("li" "Liechtenstein") - ("lk" "Sri Lanka" "The Democratic Socialist Republic of %s") - ("ls" "Lesotho") - ("lt" "Lithuania") - ("lu" "Luxembourg") - ("lv" "Latvia") - ("ma" "Morocco") - ("md" "Moldova") - ("mg" "Madagascar") - ("mk" "Macedonia") - ("ml" "Mali") - ("mo" "Macau") - ("mt" "Malta") - ("mu" "Mauritius") - ("mw" "Malawi") - ("mx" "Mexico" "The United Mexican States") - ("my" "Malaysia" "%s (changed to Myanmar?)") ;??? - ("mz" "Mozambique") - ("na" "Namibia") - ("nc" "New Caledonia (Fr.)") - ("ne" "Niger") ; In .fr domain - ("ni" "Nicaragua" "The Republic of %s") - ("nl" "Netherlands" "The Kingdom of the %s") - ("no" "Norway" "The Kingdom of %s") - ("np" "Nepal") ; Via .in domain - ("nz" "New Zealand") - ("pa" "Panama") - ("pe" "Peru") - ("pf" "Polynesia (Fr.)") - ("pg" "Papua New Guinea") - ("ph" "Philippines" "The Republic of the %s") - ("pk" "Pakistan") - ("pl" "Poland") - ("pr" "Puerto Rico (U.S.)") - ("pt" "Portugal" "The Portuguese Republic") - ("py" "Paraguay") - ("re" "Reunion (Fr.)") ; In .fr domain - ("ro" "Romania") - ("ru" "Russian Federation") - ("sa" "Saudi Arabia") - ("sc" "Seychelles") - ("sd" "Sudan") - ("se" "Sweden" "The Kingdom of %s") - ("sg" "Singapore" "The Republic of %s") - ("si" "Slovenia") - ("sj" "Svalbard and Jan Mayen Is.") ; In .no domain - ("sk" "Slovakia" "The Slovak Republic") - ("sn" "Senegal") - ("sr" "Suriname") - ("su" "Soviet Union") - ("sz" "Swaziland") - ("tg" "Togo") - ("th" "Thailand" "The Kingdom of %s") - ("tm" "Turkmenistan") ; In .su domain - ("tn" "Tunisia") - ("tr" "Turkey" "The Republic of %s") - ("tt" "Trinidad and Tobago") - ("tw" "Taiwan") - ("ua" "Ukraine") - ("uk" "United Kingdom" "The %s of Great Britain and Northern Ireland") - ("us" "United States" "The %s of America") - ("uy" "Uruguay" "The Eastern Republic of %s") - ("vc" "St. Vincent and the Grenadines") - ("ve" "Venezuela" "The Republic of %s") - ("vi" "Virgin Islands (U.S.)") - ("vn" "Vietnam") - ("vu" "Vanuatu") - ("yu" "Yugoslavia" "The Socialist Federal Republic of %s") - ("za" "South Africa" "The Republic of %s (or Zambia? Zaire?)") - ("zw" "Zimbabwe" "Republic of %s") - ;; Special top-level domains: - ("arpa" t "Advanced Research Projects Agency (U.S. DoD)") - ("bitnet" t "Because It's Time NET") - ("com" t "Commercial") - ("edu" t "Educational") - ("gov" t "Government (U.S.)") - ("int" t "International (NATO)") - ("mil" t "Military (U.S.)") - ("nato" t "North Atlantic Treaty Organization") - ("net" t "Network") - ("org" t "Non-profit Organization") - ;;("unter-dom" t "? (Ger.)") - ("uucp" t "Unix to Unix CoPy") - ;;("fipnet" nil "?") - )) - ob)) - -;;;###autoload -(defun what-domain (domain) - "Convert mail domain DOMAIN to the country it corresponds to." - (interactive - (let ((completion-ignore-case t)) - (list (completing-read "Domain: " - mail-extr-all-top-level-domains nil t)))) - (or (setq domain (intern-soft (downcase domain) - mail-extr-all-top-level-domains)) - (error "No such domain")) - (message "%s: %s" (upcase (symbol-name domain)) (get domain 'domain-name))) - - -;(let ((all nil)) -; (mapatoms #'(lambda (x) -; (if (and (boundp x) -; (string-match "^mail-extr-" (symbol-name x))) -; (setq all (cons x all))))) -; (setq all (sort all #'string-lessp)) -; (cons 'setq -; (apply 'nconc (mapcar #'(lambda (x) -; (list x (symbol-value x))) -; all)))) - - -(provide 'mail-extr) - -;;; mail-extr.el ends here diff --git a/lisp/mail/mail-hist.el b/lisp/mail/mail-hist.el deleted file mode 100644 index 893ce40ddb7..00000000000 --- a/lisp/mail/mail-hist.el +++ /dev/null @@ -1,302 +0,0 @@ -;;; mail-hist.el --- Headers and message body history for outgoing mail. - -;; Copyright (C) 1994 Free Software Foundation, Inc. - -;; Author: Karl Fogel <kfogel@cs.oberlin.edu> -;; Created: March, 1994 -;; Keywords: mail, history - -;; 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: - -;; Thanks to Jim Blandy for mentioning ring.el. It saved a lot of -;; time. -;; -;; To use this package, put it in a directory in your load-path, and -;; put this in your .emacs file: -;; -;; (load "mail-hist" nil t) -;; -;; Or you could do it with autoloads and hooks in your .emacs: -;; -;; (add-hook 'mail-mode-hook 'mail-hist-define-keys) -;; (add-hook 'mail-send-hook 'mail-hist-put-headers-into-history) -;; (add-hook 'vm-mail-mode-hook 'mail-hist-define-keys) ;or rmail, etc -;; (autoload 'mail-hist-define-keys "mail-hist") -;; (autoload 'mail-hist-put-headers-into-history "mail-hist") -;; -;; Once it's installed, use M-p and M-n from mail headers to recover -;; previous/next contents in the history for that header, or, in the -;; body of the message, to recover previous/next text of the message. -;; This only applies to outgoing mail -- mail-hist ignores received -;; messages. -;; -;; Although repeated history requests do clear out the text from the -;; previous request, an isolated request just inserts its text at -;; point, so that you can mix the histories of different messages -;; easily. This might be confusing at times, but there should be no -;; problems that undo can't handle. - -;;; Code: -(require 'ring) - -;;;###autoload -(defun mail-hist-define-keys () - "Define keys for accessing mail header history. For use in hooks." - (local-set-key "\M-p" 'mail-hist-previous-input) - (local-set-key "\M-n" 'mail-hist-next-input)) - -;;;###autoload -(defun mail-hist-enable () - (add-hook 'mail-mode-hook 'mail-hist-define-keys) - (add-hook 'mail-send-hook 'mail-hist-put-headers-into-history)) - -(defvar mail-hist-header-ring-alist nil - "Alist of form (header-name . history-ring). -Used for knowing which history list to look in when the user asks for -previous/next input.") - -(defvar mail-hist-history-size (or kill-ring-max 1729) - "*The maximum number of elements in a mail field's history. -Oldest elements are dumped first.") - -;;;###autoload -(defvar mail-hist-keep-history t - "*Non-nil means keep a history for headers and text of outgoing mail.") - -;; For handling repeated history requests -(defvar mail-hist-access-count 0) - -(defvar mail-hist-last-bounds nil) -;; (start . end) A pair indicating the buffer positions delimiting the -;; last inserted history, so it can be replaced by a new input if the -;; command is repeated. - -(defvar mail-hist-header-regexp "^[^:]*:" - "Regular expression for matching headers in a mail message.") - -(defsubst mail-hist-current-header-name () - "Get name of mail header point is currently in, without the colon. -Returns nil if not in a header, implying that point is in the body of -the message." - (if (save-excursion - (re-search-backward (concat "^" (regexp-quote mail-header-separator) - "$") - nil t)) - nil ; then we are in the body of the message - (save-excursion - (let* ((body-start ; limit possibility of false headers - (save-excursion - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "$") - nil t))) - (name-start - (re-search-backward mail-hist-header-regexp nil t)) - (name-end - (prog2 (search-forward ":" body-start t) (1- (point))))) - (and - name-start - name-end - (downcase (buffer-substring-no-properties name-start name-end))))))) - -(defsubst mail-hist-forward-header (count) - "Move forward COUNT headers (backward if COUNT is negative). -If last/first header is encountered first, stop there and returns -nil. - -Places point on the first non-whitespace on the line following the -colon after the header name, or on the second space following that if -the header is empty." - (let ((boundary (save-excursion - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "$") - nil t)))) - (and - boundary - (let ((unstopped t)) - (setq boundary (save-excursion - (goto-char boundary) - (beginning-of-line) - (1- (point)))) - (if (> count 0) - (while (> count 0) - (setq - unstopped - (re-search-forward mail-hist-header-regexp boundary t)) - (setq count (1- count))) - ;; because the current header will match too. - (setq count (1- count)) - ;; count is negative - (while (< count 0) - (setq - unstopped - (re-search-backward mail-hist-header-regexp nil t)) - (setq count (1+ count))) - ;; we end up behind the header, so must move to the front - (re-search-forward mail-hist-header-regexp boundary t)) - ;; Now we are right after the colon - (and (looking-at "\\s-") (forward-char 1)) - ;; return nil if didn't go as far as asked, otherwise point - unstopped)))) - -(defsubst mail-hist-beginning-of-header () - "Move to the start of the current header. -The start of the current header is defined as one space after the -colon, or just after the colon if it is not followed by whitespace." - ;; this is slick as all heck: - (if (mail-hist-forward-header -1) - (mail-hist-forward-header 1) - (mail-hist-forward-header 1) - (mail-hist-forward-header -1))) - -(defsubst mail-hist-current-header-contents () - "Get the contents of the mail header in which point is located." - (save-excursion - (mail-hist-beginning-of-header) - (let ((start (point))) - (or (mail-hist-forward-header 1) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "$"))) - (beginning-of-line) - (buffer-substring start (1- (point)))))) - -(defsubst mail-hist-get-header-ring (header) - "Get HEADER's history ring, or nil if none. -HEADER is a string without the colon." - (setq header (downcase header)) - (cdr (assoc header mail-hist-header-ring-alist))) - -(defvar mail-hist-text-size-limit nil - "*Don't store any header or body with more than this many characters. -If the value is nil, that means no limit on text size.") - -(defun mail-hist-text-too-long-p (text) - "Return t if TEXT does not exceed mail-hist's size limit. -The variable `mail-hist-text-size-limit' defines this limit." - (if mail-hist-text-size-limit - (> (length text) mail-hist-text-size-limit))) - -(defsubst mail-hist-add-header-contents-to-ring (header &optional contents) - "Add the contents of HEADER to the header history ring. -Optional argument CONTENTS is a string which will be the contents -\(instead of whatever's found in the header)." - (setq header (downcase header)) - (let ((ctnts (or contents (mail-hist-current-header-contents))) - (ring (cdr (assoc header mail-hist-header-ring-alist)))) - (if (mail-hist-text-too-long-p ctnts) (setq ctnts "")) - (or ring - ;; If the ring doesn't exist, we'll have to make it and add it - ;; to the mail-header-ring-alist: - (prog1 - (setq ring (make-ring mail-hist-history-size)) - (setq mail-hist-header-ring-alist - (cons (cons header ring) mail-hist-header-ring-alist)))) - (ring-insert ring ctnts))) - -;;;###autoload -(defun mail-hist-put-headers-into-history () - "Put headers and contents of this message into mail header history. -Each header has its own independent history, as does the body of the -message. - -This function normally would be called when the message is sent." - (and - mail-hist-keep-history - (save-excursion - (goto-char (point-min)) - (while (mail-hist-forward-header 1) - (mail-hist-add-header-contents-to-ring - (mail-hist-current-header-name))) - (let ((body-contents - (save-excursion - (goto-char (point-min)) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "$") - nil) - (forward-line 1) - (buffer-substring (point) (point-max))))) - (mail-hist-add-header-contents-to-ring "body" body-contents))))) - -(defun mail-hist-previous-input (header) - "Insert the previous contents of this mail header or message body. -Moves back through the history of sent mail messages. Each header has -its own independent history, as does the body of the message. - -The history only contains the contents of outgoing messages, not -received mail." - (interactive (list (or (mail-hist-current-header-name) "body"))) - (setq header (downcase header)) - (let* ((ring (cdr (assoc header mail-hist-header-ring-alist))) - (len (ring-length ring)) - (repeat (eq last-command 'mail-hist-input-access))) - (if repeat - (setq mail-hist-access-count - (ring-plus1 mail-hist-access-count len)) - (setq mail-hist-access-count 0)) - (if (null ring) - (progn - (ding) - (message "No history for \"%s\"." header)) - (if (ring-empty-p ring) - (error "\"%s\" ring is empty." header) - (and repeat - (delete-region (car mail-hist-last-bounds) - (cdr mail-hist-last-bounds))) - (let ((start (point))) - (insert (ring-ref ring mail-hist-access-count)) - (setq mail-hist-last-bounds (cons start (point))) - (setq this-command 'mail-hist-input-access)))))) - -(defun mail-hist-next-input (header) - "Insert next contents of this mail header or message body. -Moves back through the history of sent mail messages. Each header has -its own independent history, as does the body of the message. - -Although you can do so, it does not make much sense to call this -without having called `mail-hist-previous-header' first -(\\[mail-hist-previous-header]). - -The history only contains the contents of outgoing messages, not -received mail." - (interactive (list (or (mail-hist-current-header-name) "body"))) - (setq header (downcase header)) - (let* ((ring (cdr (assoc header mail-hist-header-ring-alist))) - (len (ring-length ring)) - (repeat (eq last-command 'mail-hist-input-access))) - (if repeat - (setq mail-hist-access-count - (ring-minus1 mail-hist-access-count len)) - (setq mail-hist-access-count 0)) - (if (null ring) - (progn - (ding) - (message "No history for \"%s\"." header)) - (if (ring-empty-p ring) - (error "\"%s\" ring is empty." header) - (and repeat - (delete-region (car mail-hist-last-bounds) - (cdr mail-hist-last-bounds))) - (let ((start (point))) - (insert (ring-ref ring mail-hist-access-count)) - (setq mail-hist-last-bounds (cons start (point))) - (setq this-command 'mail-hist-input-access)))))) - -(provide 'mail-hist) - -;; mail-hist.el ends here diff --git a/lisp/mail/mail-utils.el b/lisp/mail/mail-utils.el deleted file mode 100644 index ebf2f617789..00000000000 --- a/lisp/mail/mail-utils.el +++ /dev/null @@ -1,254 +0,0 @@ -;;; mail-utils.el --- utility functions used both by rmail and rnews - -;; Copyright (C) 1985 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: mail, news - -;; 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: - -;; Utility functions for mail and netnews handling. These handle fine -;; points of header parsing. - -;;; Code: - -;;; We require lisp-mode to make sure that lisp-mode-syntax-table has -;;; been initialized. -(require 'lisp-mode) - -;;;###autoload -(defvar mail-use-rfc822 nil "\ -*If non-nil, use a full, hairy RFC822 parser on mail addresses. -Otherwise, (the default) use a smaller, somewhat faster, and -often correct parser.") - -;; Returns t if file FILE is an Rmail file. -;;;###autoload -(defun mail-file-babyl-p (file) - (let ((buf (generate-new-buffer " *rmail-file-p*"))) - (unwind-protect - (save-excursion - (set-buffer buf) - (insert-file-contents file nil 0 100) - (looking-at "BABYL OPTIONS:")) - (kill-buffer buf)))) - -(defun mail-string-delete (string start end) - "Returns a string containing all of STRING except the part -from START (inclusive) to END (exclusive)." - (if (null end) (substring string 0 start) - (concat (substring string 0 start) - (substring string end nil)))) - -(defun mail-strip-quoted-names (address) - "Delete comments and quoted strings in an address list ADDRESS. -Also delete leading/trailing whitespace and replace FOO <BAR> with just BAR. -Return a modified address list." - (if (null address) - nil - (if mail-use-rfc822 - (progn (require 'rfc822) - (mapconcat 'identity (rfc822-addresses address) ", ")) - (let (pos) - (string-match "\\`[ \t\n]*" address) - ;; strip surrounding whitespace - (setq address (substring address - (match-end 0) - (string-match "[ \t\n]*\\'" address - (match-end 0)))) - - ;; Detect nested comments. - (if (string-match "[ \t]*(\\([^)\\]\\|\\\\.\\|\\\\\n\\)*(" address) - ;; Strip nested comments. - (save-excursion - (set-buffer (get-buffer-create " *temp*")) - (erase-buffer) - (insert address) - (set-syntax-table lisp-mode-syntax-table) - (goto-char 1) - (while (search-forward "(" nil t) - (forward-char -1) - (skip-chars-backward " \t") - (delete-region (point) - (save-excursion - (condition-case () - (forward-sexp 1) - (error (goto-char (point-max)))) - (point)))) - (setq address (buffer-string)) - (erase-buffer)) - ;; Strip non-nested comments an easier way. - (while (setq pos (string-match - ;; This doesn't hack rfc822 nested comments - ;; `(xyzzy (foo) whinge)' properly. Big deal. - "[ \t]*(\\([^)\\]\\|\\\\.\\|\\\\\n\\)*)" - address)) - (setq address - (mail-string-delete address - pos (match-end 0))))) - - ;; strip `quoted' names (This is supposed to hack `"Foo Bar" <bar@host>') - (setq pos 0) - (while (setq pos (string-match - "[ \t]*\"\\([^\"\\]\\|\\\\.\\|\\\\\n\\)*\"[ \t\n]*" - address pos)) - ;; If the next thing is "@", we have "foo bar"@host. Leave it. - (if (and (> (length address) (match-end 0)) - (= (aref address (match-end 0)) ?@)) - (setq pos (match-end 0)) - (setq address - (mail-string-delete address - pos (match-end 0))))) - ;; Retain only part of address in <> delims, if there is such a thing. - (while (setq pos (string-match "\\(,\\s-*\\|\\`\\)[^,]*<\\([^>,]*>\\)" - address)) - (let ((junk-beg (match-end 1)) - (junk-end (match-beginning 2)) - (close (match-end 0))) - (setq address (mail-string-delete address (1- close) close)) - (setq address (mail-string-delete address junk-beg junk-end)))) - address)))) - -(or (and (boundp 'rmail-default-dont-reply-to-names) - (not (null rmail-default-dont-reply-to-names))) - (setq rmail-default-dont-reply-to-names "info-")) - -; rmail-dont-reply-to-names is defined in loaddefs -(defun rmail-dont-reply-to (userids) - "Returns string of mail addresses USERIDS sans any recipients -that start with matches for `rmail-dont-reply-to-names'. -Usenet paths ending in an element that matches are removed also." - (if (null rmail-dont-reply-to-names) - (setq rmail-dont-reply-to-names - (concat (if rmail-default-dont-reply-to-names - (concat rmail-default-dont-reply-to-names "\\|") - "") - (concat (regexp-quote (user-login-name)) - "\\>")))) - (let ((match (concat "\\(^\\|,\\)[ \t\n]*\\([^,\n]*!\\|\\)\\(" - rmail-dont-reply-to-names - "\\|[^\,.<]*<\\(" rmail-dont-reply-to-names "\\)" - "\\)")) - (case-fold-search t) - pos epos) - (setq foo match) - (while (setq pos (string-match match userids)) - (if (> pos 0) (setq pos (match-beginning 2))) - (setq epos - ;; Delete thru the next comma, plus whitespace after. - (if (string-match ",[ \t\n]+" userids (match-end 0)) - (match-end 0) - (length userids))) - (setq userids - (mail-string-delete - userids pos epos))) - ;; get rid of any trailing commas - (if (setq pos (string-match "[ ,\t\n]*\\'" userids)) - (setq userids (substring userids 0 pos))) - ;; remove leading spaces. they bother me. - (if (string-match "\\s *" userids) - (substring userids (match-end 0)) - userids))) - -;;;###autoload -(defun mail-fetch-field (field-name &optional last all) - "Return the value of the header field FIELD-NAME. -The buffer is expected to be narrowed to just the headers of the message. -If second arg LAST is non-nil, use the last such field if there are several. -If third arg ALL is non-nil, concatenate all such fields with commas between." - (save-excursion - (goto-char (point-min)) - (let ((case-fold-search t) - (name (concat "^" (regexp-quote field-name) "[ \t]*:[ \t]*"))) - (if all - (let ((value "")) - (while (re-search-forward name nil t) - (let ((opoint (point))) - (while (progn (forward-line 1) - (looking-at "[ \t]"))) - ;; Back up over newline, then trailing spaces or tabs - (forward-char -1) - (skip-chars-backward " \t" opoint) - (setq value (concat value - (if (string= value "") "" ", ") - (buffer-substring-no-properties - opoint (point)))))) - (and (not (string= value "")) value)) - (if (re-search-forward name nil t) - (progn - (if last (while (re-search-forward name nil t))) - (let ((opoint (point))) - (while (progn (forward-line 1) - (looking-at "[ \t]"))) - ;; Back up over newline, then trailing spaces or tabs - (forward-char -1) - (skip-chars-backward " \t" opoint) - (buffer-substring-no-properties opoint (point))))))))) - -;; Parse a list of tokens separated by commas. -;; It runs from point to the end of the visible part of the buffer. -;; Whitespace before or after tokens is ignored, -;; but whitespace within tokens is kept. -(defun mail-parse-comma-list () - (let (accumulated - beg) - (skip-chars-forward " ") - (while (not (eobp)) - (setq beg (point)) - (skip-chars-forward "^,") - (skip-chars-backward " ") - (setq accumulated - (cons (buffer-substring beg (point)) - accumulated)) - (skip-chars-forward "^,") - (skip-chars-forward ", ")) - accumulated)) - -(defun mail-comma-list-regexp (labels) - (let (pos) - (setq pos (or (string-match "[^ \t]" labels) 0)) - ;; Remove leading and trailing whitespace. - (setq labels (substring labels pos (string-match "[ \t]*$" labels pos))) - ;; Change each comma to \|, and flush surrounding whitespace. - (while (setq pos (string-match "[ \t]*,[ \t]*" labels)) - (setq labels - (concat (substring labels 0 pos) - "\\|" - (substring labels (match-end 0)))))) - labels) - -(defun mail-rfc822-time-zone (time) - (let* ((sec (or (car (current-time-zone time)) 0)) - (absmin (/ (abs sec) 60))) - (format "%c%02d%02d" (if (< sec 0) ?- ?+) (/ absmin 60) (% absmin 60)))) - -(defun mail-rfc822-date () - (let* ((time (current-time)) - (s (current-time-string time))) - (string-match "[^ ]+ +\\([^ ]+\\) +\\([^ ]+\\) \\([^ ]+\\) \\([^ ]+\\)" s) - (concat (substring s (match-beginning 2) (match-end 2)) " " - (substring s (match-beginning 1) (match-end 1)) " " - (substring s (match-beginning 4) (match-end 4)) " " - (substring s (match-beginning 3) (match-end 3)) " " - (mail-rfc822-time-zone time)))) - -(provide 'mail-utils) - -;;; mail-utils.el ends here diff --git a/lisp/mail/mailabbrev.el b/lisp/mail/mailabbrev.el deleted file mode 100644 index e69e10cdf5f..00000000000 --- a/lisp/mail/mailabbrev.el +++ /dev/null @@ -1,576 +0,0 @@ -;;; mailabbrev.el --- abbrev-expansion of mail aliases. - -;; Copyright (C) 1985, 1986, 87, 92, 93, 1996 Free Software Foundation, Inc. - -;; Author: Jamie Zawinski <jwz@lucid.com> -;; Maintainer: Jamie Zawinski <jwz@lucid.com> -;; Created: 19 Oct 90 -;; 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: - -;; This file ensures that, when the point is in a To:, CC:, BCC:, or From: -;; field, word-abbrevs are defined for each of your mail aliases. These -;; aliases will be defined from your .mailrc file (or the file specified by -;; the MAILRC environment variable) if it exists. Your mail aliases will -;; expand any time you type a word-delimiter at the end of an abbreviation. -;; -;; What you see is what you get: if mailabbrev is in use when you type -;; a name, and the name does not expand, you know it is not an abbreviation. -;; However, if you yank abbreviations into the headers -;; in a way that bypasses the check for abbreviations, -;; they are expanded (but not visibly) when you send the message. -;; -;; Your mail alias abbrevs will be in effect only when the point is in an -;; appropriate header field. When in the body of the message, or other -;; header fields, the mail aliases will not expand. Rather, the normal -;; mode-specific abbrev table (mail-mode-abbrev-table) will be used if -;; defined. So if you use mail-mode specific abbrevs, this code will not -;; adversely affect you. You can control which header fields the abbrevs -;; are used in by changing the variable mail-abbrev-mode-regexp. -;; -;; If auto-fill mode is on, abbrevs will wrap at commas instead of at word -;; boundaries; also, header continuation-lines will be properly indented. -;; -;; You can also insert a mail alias with mail-interactive-insert-alias -;; (bound to C-c C-a), which prompts you for an alias (with completion) -;; and inserts its expansion at point. -;; -;; This file fixes a bug in the old system which prohibited your .mailrc -;; file from having lines like -;; -;; alias someone "John Doe <doe@quux.com>" -;; -;; That is, if you want an address to have embedded spaces, simply surround it -;; with double-quotes. This is necessary because the format of the .mailrc -;; file bogusly uses spaces as address delimiters. The following line defines -;; an alias which expands to three addresses: -;; -;; alias foobar addr-1 addr-2 "address three <addr-3>" -;; -;; (This is bogus because mail-delivery programs want commas, not spaces, -;; but that's what the file format is, so we have to live with it.) -;; -;; If you like, you can call the function define-mail-abbrev to define your -;; mail aliases instead of using a .mailrc file. When you call it in this -;; way, addresses are separated by commas. -;; -;; CAVEAT: This works on most Sun systems; I have been told that some versions -;; of /bin/mail do not understand double-quotes in the .mailrc file. So you -;; should make sure your version does before including verbose addresses like -;; this. One solution to this, if you are on a system whose /bin/mail doesn't -;; work that way, (and you still want to be able to /bin/mail to send mail in -;; addition to emacs) is to define minimal aliases (without full names) in -;; your .mailrc file, and use define-mail-abbrev to redefine them when sending -;; mail from emacs; this way, mail sent from /bin/mail will work, and mail -;; sent from emacs will be pretty. -;; -;; Aliases in the mailrc file may be nested. If you define aliases like -;; alias group1 fred ethel -;; alias group2 larry curly moe -;; alias everybody group1 group2 -;; Then when you type "everybody" on the To: line, it will be expanded to -;; fred, ethyl, larry, curly, moe -;; -;; Aliases may also contain forward references; the alias of "everybody" can -;; precede the aliases of "group1" and "group2". -;; -;; This code also understands the "source" .mailrc command, for reading -;; aliases from some other file as well. -;; -;; Aliases may contain hyphens, as in "alias foo-bar foo@bar"; word-abbrevs -;; normally cannot contain hyphens, but this code works around that for the -;; specific case of mail-alias word-abbrevs. -;; -;; To read in the contents of another .mailrc-type file from emacs, use the -;; command Meta-X merge-mail-abbrevs. The rebuild-mail-abbrevs command is -;; similar, but will delete existing aliases first. -;; -;; If you would like your aliases to be expanded when you type M-> or ^N to -;; move out of the mail-header into the message body (instead of having to -;; type SPC at the end of the abbrev before moving away) then you can do -;; -;; (add-hook -;; 'mail-setup-hook -;; '(lambda () -;; (substitute-key-definition 'next-line 'mail-abbrev-next-line -;; mail-mode-map global-map) -;; (substitute-key-definition 'end-of-buffer 'mail-abbrev-end-of-buffer -;; mail-mode-map global-map))) -;; -;; If you want multiple addresses separated by a string other than ", " then -;; you can set the variable mail-alias-separator-string to it. This has to -;; be a comma bracketed by whitespace if you want any kind of reasonable -;; behaviour. -;; -;; Thanks to Harald Hanche-Olsen, Michael Ernst, David Loeffler, and -;; Noah Friedman for suggestions and bug reports. - -;; To use this package, do (add-hook 'mail-setup-hook 'mail-abbrevs-setup). - -;;; Code: - -(require 'sendmail) - -;; originally defined in sendmail.el - used to be an alist, now is a table. -(defvar mail-abbrevs nil - "Word-abbrev table of mail address aliases. -If this is nil, it means the aliases have not yet been initialized and -should be read from the .mailrc file. (This is distinct from there being -no aliases, which is represented by this being a table with no entries.)") - -(defvar mail-abbrev-modtime nil - "The modification time of your mail alias file when it was last examined.") - -(defun mail-abbrevs-sync-aliases () - (if (file-exists-p mail-personal-alias-file) - (let ((modtime (nth 5 (file-attributes mail-personal-alias-file)))) - (if (not (equal mail-abbrev-modtime modtime)) - (progn - (setq mail-abbrev-modtime modtime) - (build-mail-abbrevs)))))) - -;;;###autoload -(defun mail-abbrevs-setup () - "Initialize use of the `mailabbrev' package." - (if (and (not (vectorp mail-abbrevs)) - (file-exists-p mail-personal-alias-file)) - (progn - (setq mail-abbrev-modtime - (nth 5 (file-attributes mail-personal-alias-file))) - (build-mail-abbrevs))) - (mail-abbrevs-sync-aliases) - (make-local-hook 'pre-abbrev-expand-hook) - (add-hook 'pre-abbrev-expand-hook 'sendmail-pre-abbrev-expand-hook - nil t) - (abbrev-mode 1)) - -;;;###autoload -(defun build-mail-abbrevs (&optional file recursivep) - "Read mail aliases from personal mail alias file and set `mail-abbrevs'. -By default this is the file specified by `mail-personal-alias-file'." - (setq file (expand-file-name (or file mail-personal-alias-file))) - (if (vectorp mail-abbrevs) - nil - (setq mail-abbrevs nil) - (define-abbrev-table 'mail-abbrevs '())) - (message "Parsing %s..." file) - (let ((buffer nil) - (obuf (current-buffer))) - (unwind-protect - (progn - (setq buffer (generate-new-buffer "mailrc")) - (buffer-disable-undo buffer) - (set-buffer buffer) - (cond ((get-file-buffer file) - (insert (save-excursion - (set-buffer (get-file-buffer file)) - (buffer-substring (point-min) (point-max))))) - ((not (file-exists-p file))) - (t (insert-file-contents file))) - ;; Don't lose if no final newline. - (goto-char (point-max)) - (or (eq (preceding-char) ?\n) (newline)) - (goto-char (point-min)) - ;; Delete comments from the file - (while (search-forward "# " nil t) - (let ((p (- (point) 2))) - (end-of-line) - (delete-region p (point)))) - (goto-char (point-min)) - ;; handle "\\\n" continuation lines - (while (not (eobp)) - (end-of-line) - (if (= (preceding-char) ?\\) - (progn (delete-char -1) (delete-char 1) (insert ?\ )) - (forward-char 1))) - (goto-char (point-min)) - (while (re-search-forward - "^\\(a\\(lias\\)?\\|g\\(roup\\)?\\|source\\)[ \t]+" nil t) - (beginning-of-line) - (if (looking-at "source[ \t]+\\([^ \t\n]+\\)") - (progn - (end-of-line) - (build-mail-abbrevs - (substitute-in-file-name - (buffer-substring (match-beginning 1) (match-end 1))) - t)) - (re-search-forward "[ \t]+\\([^ \t\n]+\\)") - (let* ((name (buffer-substring - (match-beginning 1) (match-end 1))) - (start (progn (skip-chars-forward " \t") (point)))) - (end-of-line) -; (message "** %s \"%s\"" name (buffer-substring start (point)))(sit-for 1) - (define-mail-abbrev - name - (buffer-substring start (point)) - t)))) - ;; Resolve forward references in .mailrc file. - ;; This would happen automatically before the first abbrev was - ;; expanded, but why not do it now. - (or recursivep (mail-resolve-all-aliases)) - mail-abbrevs) - (if buffer (kill-buffer buffer)) - (set-buffer obuf))) - (message "Parsing %s... done" file)) - -(defvar mail-alias-separator-string ", " - "*A string inserted between addresses in multi-address mail aliases. -This has to contain a comma, so \", \" is a reasonable value. You might -also want something like \",\\n \" to get each address on its own line.") - -;; define-mail-abbrev sets this flag, which causes mail-resolve-all-aliases -;; to be called before expanding abbrevs if it's necessary. -(defvar mail-abbrev-aliases-need-to-be-resolved t) - -;; originally defined in mailalias.el ; build-mail-abbrevs calls this with -;; stuff parsed from the .mailrc file. -;; -;;;###autoload -(defun define-mail-abbrev (name definition &optional from-mailrc-file) - "Define NAME as a mail alias abbrev that translates to DEFINITION. -If DEFINITION contains multiple addresses, separate them with commas." - ;; When this is called from build-mail-abbrevs, the third argument is - ;; true, and we do some evil space->comma hacking like /bin/mail does. - (interactive "sDefine mail alias: \nsDefine %s as mail alias for: ") - ;; Read the defaults first, if we have not done so. - (if (vectorp mail-abbrevs) - nil - (setq mail-abbrevs nil) - (define-abbrev-table 'mail-abbrevs '()) - (if (file-exists-p mail-personal-alias-file) - (build-mail-abbrevs))) - ;; strip garbage from front and end - (if (string-match "\\`[ \t\n,]+" definition) - (setq definition (substring definition (match-end 0)))) - (if (string-match "[ \t\n,]+\\'" definition) - (setq definition (substring definition 0 (match-beginning 0)))) - (let* ((result '()) - (L (length definition)) - (start (if (> L 0) 0)) - end) - (while start - ;; If we're reading from the mailrc file, then addresses are delimited - ;; by spaces, and addresses with embedded spaces must be surrounded by - ;; double-quotes. Otherwise, addresses are separated by commas. - (if from-mailrc-file - (if (eq ?\" (aref definition start)) - (setq start (1+ start) - end (string-match "\"[ \t,]*" definition start)) - (setq end (string-match "[ \t,]+" definition start))) - (setq end (string-match "[ \t\n,]*,[ \t\n,]*" definition start))) - (setq result (cons (substring definition start end) result)) - (setq start (and end - (/= (match-end 0) L) - (match-end 0)))) - (setq definition (mapconcat (function identity) - (nreverse result) - mail-alias-separator-string))) - (setq mail-abbrev-aliases-need-to-be-resolved t) - (setq name (downcase name)) - ;; use an abbrev table instead of an alist for mail-abbrevs. - (let ((abbrevs-changed abbrevs-changed)) ; protect this from being changed. - (define-abbrev mail-abbrevs name definition 'mail-abbrev-expand-hook))) - - -(defun mail-resolve-all-aliases () - "Resolve all forward references in the mail aliases table." - (if mail-abbrev-aliases-need-to-be-resolved - (progn -;; (message "Resolving mail aliases...") - (if (vectorp mail-abbrevs) - (mapatoms (function mail-resolve-all-aliases-1) mail-abbrevs)) - (setq mail-abbrev-aliases-need-to-be-resolved nil) -;; (message "Resolving mail aliases... done.") - ))) - -(defun mail-resolve-all-aliases-1 (sym &optional so-far) - (if (memq sym so-far) - (error "mail alias loop detected: %s" - (mapconcat 'symbol-name (cons sym so-far) " <- "))) - (let ((definition (and (boundp sym) (symbol-value sym)))) - (if definition - (let ((result '()) - (start 0)) - (while start - (let ((end (string-match "[ \t\n]*,[, \t\n]*" definition start))) - (setq result (cons (substring definition start end) result) - start (and end (match-end 0))))) - (setq definition - (mapconcat (function (lambda (x) - (or (mail-resolve-all-aliases-1 - (intern-soft (downcase x) mail-abbrevs) - (cons sym so-far)) - x))) - (nreverse result) - mail-alias-separator-string)) - (set sym definition)))) - (symbol-value sym)) - - -(defun mail-abbrev-expand-hook () - "For use as the fourth arg to `define-abbrev'. -After expanding a mail-abbrev, if Auto Fill mode is on and we're past the -fill-column, break the line at the previous comma, and indent the next line." - ;; Disable abbrev mode to avoid recursion in indent-relative expanding - ;; part of the abbrev expansion as an abbrev itself. - (let ((abbrev-mode nil)) - (save-excursion - (let ((p (point)) - bol comma fp) - (beginning-of-line) - (setq bol (point)) - (goto-char p) - (while (and auto-fill-function - (>= (current-column) fill-column) - (search-backward "," bol t)) - (setq comma (point)) - (forward-char 1) ; Now we are just past the comma. - (insert "\n") - (delete-horizontal-space) - (setq p (point)) - (indent-relative) - (setq fp (buffer-substring p (point))) - ;; Go to the end of the new line. - (end-of-line) - (if (> (current-column) fill-column) - ;; It's still too long; do normal auto-fill. - (let ((fill-prefix (or fp "\t"))) - (do-auto-fill))) - ;; Resume the search. - (goto-char comma) - ))))) - -;;; Syntax tables and abbrev-expansion - -(defvar mail-abbrev-mode-regexp - "^\\(Resent-\\)?\\(To\\|From\\|CC\\|BCC\\|Reply-to\\):" - "*Regexp to select mail-headers in which mail abbrevs should be expanded. -This string will be handed to `looking-at' with point at the beginning -of the current line; if it matches, abbrev mode will be turned on, otherwise -it will be turned off. (You don't need to worry about continuation lines.) -This should be set to match those mail fields in which you want abbreviations -turned on.") - -(defvar mail-mode-header-syntax-table - (let ((tab (copy-syntax-table text-mode-syntax-table))) - ;; This makes the characters "@%!._-" be considered symbol-constituents - ;; but not word-constituents, so forward-sexp will move you over an - ;; entire address, but forward-word will only move you over a sequence - ;; of alphanumerics. (Clearly the right thing.) - (modify-syntax-entry ?@ "_" tab) - (modify-syntax-entry ?% "_" tab) - (modify-syntax-entry ?! "_" tab) - (modify-syntax-entry ?. "_" tab) - (modify-syntax-entry ?_ "_" tab) - (modify-syntax-entry ?- "_" tab) - (modify-syntax-entry ?< "(>" tab) - (modify-syntax-entry ?> ")<" tab) - tab) - "The syntax table used in send-mail mode when in a mail-address header. -`mail-mode-syntax-table' is used when the cursor is in the message body or in -non-address headers.") - -(defvar mail-abbrev-syntax-table - (let* ((tab (copy-syntax-table mail-mode-header-syntax-table)) - (_ (aref (standard-syntax-table) ?_)) - (w (aref (standard-syntax-table) ?w))) - (map-char-table - (function (lambda (key value) - (if (equal value _) - (set-char-table-range tab key w)))) - tab) - tab) - "The syntax-table used for abbrev-expansion purposes. -This is not actually made the current syntax table of the buffer, but -simply controls the set of characters which may be a part of the name -of a mail alias.") - - -(defun mail-abbrev-in-expansion-header-p () - "Whether point is in a mail-address header field." - (let ((case-fold-search t)) - (and ;; - ;; we are on an appropriate header line... - (save-excursion - (beginning-of-line) - ;; skip backwards over continuation lines. - (while (and (looking-at "^[ \t]") - (not (= (point) (point-min)))) - (forward-line -1)) - ;; are we at the front of an appropriate header line? - (looking-at mail-abbrev-mode-regexp)) - ;; - ;; ...and we are before the mail-header-separator - (< (point) - (save-excursion - (goto-char (point-min)) - (search-forward (concat "\n" mail-header-separator "\n") - nil 0) - (point)))))) - -(defvar mail-mode-abbrev-table) ; quiet the compiler - -(defun sendmail-pre-abbrev-expand-hook () - (and (and mail-abbrevs (not (eq mail-abbrevs t))) - (if (mail-abbrev-in-expansion-header-p) - (progn - ;; - ;; We are in a To: (or CC:, or whatever) header, and - ;; should use word-abbrevs to expand mail aliases. - - ;; Before anything else, resolve aliases if they need it. - (and mail-abbrev-aliases-need-to-be-resolved - (mail-resolve-all-aliases)) - - ;; Now proceed with the abbrev section. - ;; - First, install the mail-abbrevs as the word-abbrev table. - ;; - Then install the mail-abbrev-syntax-table, which - ;; temporarily marks all of the - ;; non-alphanumeric-atom-characters (the "_" - ;; syntax ones) as being normal word-syntax. We do this - ;; because the C code for expand-abbrev only works on words, - ;; and we want these characters to be considered words for - ;; the purpose of abbrev expansion. - ;; - Then we call expand-abbrev again, recursively, to do - ;; the abbrev expansion with the above syntax table. - ;; - Then we do a trick which tells the expand-abbrev frame - ;; which invoked us to not continue (and thus not - ;; expand twice.) This means that any abbrev expansion - ;; will happen as a result of this function's call to - ;; expand-abbrev, and not as a result of the call to - ;; expand-abbrev which invoked *us*. - ;; - Then we set the syntax table to - ;; mail-mode-header-syntax-table, which doesn't have - ;; anything to do with abbrev expansion, but - ;; is just for the user's convenience (see its doc string.) - ;; - - (setq local-abbrev-table mail-abbrevs) - - ;; If the character just typed was non-alpha-symbol-syntax, - ;; then don't expand the abbrev now (that is, don't expand - ;; when the user types -.) Check the character's syntax in - ;; the mail-mode-header-syntax-table. - - (set-syntax-table mail-mode-header-syntax-table) - (or (and (integerp last-command-char) - (eq (char-syntax last-command-char) ?_)) - (let ((pre-abbrev-expand-hook nil)) ; That's us; don't loop. - ;; Use this table so that abbrevs can have hyphens in them. - (set-syntax-table mail-abbrev-syntax-table) - (expand-abbrev) - ;; Now set it back to what it was before. - (set-syntax-table mail-mode-header-syntax-table))) - (setq abbrev-start-location (point-max) ; This is the trick. - abbrev-start-location-buffer (current-buffer))) - - ;; We're not in a mail header where mail aliases should - ;; be expanded, then use the normal mail-mode abbrev table - ;; (if any) and the normal mail-mode syntax table. - - (setq local-abbrev-table (and (boundp 'mail-mode-abbrev-table) - mail-mode-abbrev-table)) - (set-syntax-table mail-mode-syntax-table)) - )) - -;;; utilities - -(defun merge-mail-abbrevs (file) - "Merge mail aliases from the given file with existing ones." - (interactive (list - (let ((insert-default-directory t) - (default-directory (expand-file-name "~/")) - (def mail-personal-alias-file)) - (read-file-name - (format "Read additional aliases from file: (default %s) " - def) - default-directory - (expand-file-name def default-directory) - t)))) - (build-mail-abbrevs file)) - -(defun rebuild-mail-abbrevs (&optional file) - "Rebuild all the mail aliases from the given file." - (interactive (list - (let ((insert-default-directory t) - (default-directory (expand-file-name "~/")) - (def mail-personal-alias-file)) - (read-file-name - (format "Read mail aliases from file: (default %s) " def) - default-directory - (expand-file-name def default-directory) - t)))) - (if (null file) - (setq file buffer-file-name)) - (setq mail-abbrevs nil) - (build-mail-abbrevs file)) - -(defun mail-interactive-insert-alias (&optional alias) - "Prompt for and insert a mail alias." - (interactive (progn - (if (not (vectorp mail-abbrevs)) (mail-abbrevs-setup)) - (list (completing-read "Expand alias: " mail-abbrevs nil t)))) - (if (not (vectorp mail-abbrevs)) (mail-abbrevs-setup)) - (insert (or (and alias (symbol-value (intern-soft alias mail-abbrevs))) "")) - (mail-abbrev-expand-hook)) - -(defun mail-abbrev-next-line (&optional arg) - "Expand any mail abbrev, then move cursor vertically down ARG lines. -If there is no character in the target line exactly under the current column, -the cursor is positioned after the character in that line which spans this -column, or at the end of the line if it is not long enough. -If there is no line in the buffer after this one, -a newline character is inserted to create a line -and the cursor moves to that line. - -The command \\[set-goal-column] can be used to create -a semipermanent goal column to which this command always moves. -Then it does not try to move vertically. This goal column is stored -in `goal-column', which is nil when there is none. - -If you are thinking of using this in a Lisp program, consider -using `forward-line' instead. It is usually easier to use -and more reliable (no dependence on goal column, etc.)." - (interactive "p") - (if (looking-at "[ \t]*\n") (expand-abbrev)) - (setq this-command 'next-line) - (next-line arg)) - -(defun mail-abbrev-end-of-buffer (&optional arg) - "Expand any mail abbrev, then move point to end of buffer. -Leave mark at previous position. -With arg N, put point N/10 of the way from the true end. - -Don't use this command in Lisp programs! -\(goto-char (point-max)) is faster and avoids clobbering the mark." - (interactive "P") - (if (looking-at "[ \t]*\n") (expand-abbrev)) - (setq this-command 'end-of-buffer) - (end-of-buffer arg)) - -(define-key mail-mode-map "\C-c\C-a" 'mail-interactive-insert-alias) - -;;(define-key mail-mode-map "\C-n" 'mail-abbrev-next-line) -;;(define-key mail-mode-map "\M->" 'mail-abbrev-end-of-buffer) - -(provide 'mailabbrev) - -;;; mailabbrev.el ends here. diff --git a/lisp/mail/mailalias.el b/lisp/mail/mailalias.el deleted file mode 100644 index 0969f50ae29..00000000000 --- a/lisp/mail/mailalias.el +++ /dev/null @@ -1,441 +0,0 @@ -;;; mailalias.el --- expand and complete mailing address aliases - -;; Copyright (C) 1985, 1987, 1995, 1996 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; 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: - -;; Basic functions for defining and expanding mail aliases. -;; These seal off the interface to the alias-definition parts of a -;; .mailrc file formatted for BSD's Mail or USL's mailx. - -;;; Code: - -(require 'sendmail) - -(defvar mail-names t - "Alist of local users, aliases and directory entries as available. -When t this still needs to be initialized. -This is the basis for `mail-complete'.") - -(defvar mail-local-names t - "Alist of local users. -When t this still needs to be initialized.") - -(defvar mail-directory-names t - "Alist of mail address directory entries. -When t this still needs to be initialized.") - -(defvar mail-address-field-regexp - "^\\(Resent-\\)?\\(To\\|From\\|CC\\|BCC\\|Reply-to\\):") - -(defvar mail-complete-alist - `((,mail-address-field-regexp mail-get-names pattern) - ("Newsgroups:" . (if (boundp 'gnus-active-hashtb) - gnus-active-hashtb - (if (boundp news-group-article-assoc) - news-group-article-assoc))) - ("Followup-To:" . (mail-sentto-newsgroups)) - ;;("Distribution:" ???) - ) - "Alist of header field and expression to return alist for completion. -Expression may reference variable `pattern' which is the string being completed. -If not on matching header, `mail-complete-function' gets called instead.") - -(defvar mail-complete-function 'ispell-complete-word - "Function to call when completing outside `mail-complete-alist'-header.") - - -(defvar mail-directory-function nil - "Function to get completions from directory service or `nil' for none. -See `mail-directory-requery'.") - - -;; This is for when the directory is huge, or changes frequently. -(defvar mail-directory-requery nil - "When non-`nil' call `mail-directory-function' for each completion. -In that case, one argument gets passed to the function, the partial string -entered so far.") - - -(defvar mail-directory-process nil - "Unix command when `mail-directory-function' is `mail-directory-process'. -This is a list of the form (COMMAND ARG ...), where each of the list elements -is evaluated. When `mail-directory-requery' is non-`nil', during -evaluation the variable `pattern' contains the partial input being completed. -This might look like - - '(remote-shell-program \"HOST\" \"-nl\" \"USER\" \"COMMAND\") - -or - - '(remote-shell-program \"HOST\" \"-n\" \"COMMAND '^\" pattern \"'\")") - -(defvar mail-directory-stream () - "List of (HOST SERVICE) for stream connection to mail directory.") - -(defvar mail-directory-parser nil - "How to interpret the output of `mail-directory-function'. -Three types of values are possible: - - - nil means to gather each line as one name - - regexp means first \\(grouping\\) in successive matches is name - - function called at beginning of buffer that returns an alist of names") - - -;; Called from sendmail-send-it, or similar functions, -;; only if some mail aliases are defined. -(defun expand-mail-aliases (beg end &optional exclude) - "Expand all mail aliases in suitable header fields found between BEG and END. -Suitable header fields are `To', `From', `CC' and `BCC', `Reply-to', and -their `Resent-' variants. - -Optional second arg EXCLUDE may be a regular expression defining text to be -removed from alias expansions." - (sendmail-sync-aliases) - (if (eq mail-aliases t) - (progn (setq mail-aliases nil) (build-mail-aliases))) - (goto-char beg) - (setq end (set-marker (make-marker) end)) - (let ((case-fold-search nil)) - (while (let ((case-fold-search t)) - (re-search-forward mail-address-field-regexp end t)) - (skip-chars-forward " \t") - (let ((beg1 (point)) - end1 pos epos seplen - ;; DISABLED-ALIASES records aliases temporarily disabled - ;; while we scan text that resulted from expanding those aliases. - ;; Each element is (ALIAS . TILL-WHEN), where TILL-WHEN - ;; is where to reenable the alias (expressed as number of chars - ;; counting from END1). - (disabled-aliases nil)) - (re-search-forward "^[^ \t]" end 'move) - (beginning-of-line) - (skip-chars-backward " \t\n") - (setq end1 (point-marker)) - (goto-char beg1) - (while (< (point) end1) - (setq pos (point)) - ;; Reenable any aliases which were disabled for ranges - ;; that we have passed out of. - (while (and disabled-aliases (> pos (- end1 (cdr (car disabled-aliases))))) - (setq disabled-aliases (cdr disabled-aliases))) - ;; EPOS gets position of end of next name; - ;; SEPLEN gets length of whitespace&separator that follows it. - (if (re-search-forward "[ \t]*[\n,][ \t]*" end1 t) - (setq epos (match-beginning 0) - seplen (- (point) epos)) - (setq epos (marker-position end1) seplen 0)) - (let (translation - (string (buffer-substring-no-properties pos epos))) - (if (and (not (assoc string disabled-aliases)) - (setq translation - (cdr (assoc string mail-aliases)))) - (progn - ;; This name is an alias. Disable it. - (setq disabled-aliases (cons (cons string (- end1 epos)) - disabled-aliases)) - ;; Replace the alias with its expansion - ;; then rescan the expansion for more aliases. - (goto-char pos) - (insert translation) - (if exclude - (let ((regexp - (concat "\\b\\(" exclude "\\)\\b")) - (end (point-marker))) - (goto-char pos) - (while (re-search-forward regexp end t) - (replace-match "")) - (goto-char end))) - (delete-region (point) (+ (point) (- epos pos))) - (goto-char pos)) - ;; Name is not an alias. Skip to start of next name. - (goto-char epos) - (forward-char seplen)))) - (set-marker end1 nil))) - (set-marker end nil))) - -;; Called by mail-setup, or similar functions, only if the file specified -;; by mail-personal-alias-file (usually `~/.mailrc') exists. -(defun build-mail-aliases (&optional file) - "Read mail aliases from personal aliases file and set `mail-aliases'. -By default, this is the file specified by `mail-personal-alias-file'." - (setq file (expand-file-name (or file mail-personal-alias-file))) - (let ((buffer nil) - (obuf (current-buffer))) - (unwind-protect - (progn - (setq buffer (generate-new-buffer " mailrc")) - (set-buffer buffer) - (while file - (cond ((get-file-buffer file) - (insert (save-excursion - (set-buffer (get-file-buffer file)) - (buffer-substring-no-properties - (point-min) (point-max))))) - ((file-exists-p file) (insert-file-contents file)) - ((file-exists-p (setq file (concat "~/" file))) - (insert-file-contents file)) - (t (setq file nil))) - ;; Don't lose if no final newline. - (goto-char (point-max)) - (or (eq (preceding-char) ?\n) (newline)) - (goto-char (point-min)) - ;; handle "\\\n" continuation lines - (while (not (eobp)) - (end-of-line) - (if (= (preceding-char) ?\\) - (progn (delete-char -1) (delete-char 1) (insert ?\ )) - (forward-char 1))) - (goto-char (point-min)) - ;; handle `source' directives -- Eddy/1994/May/25 - (cond ((re-search-forward "^source[ \t]+" nil t) - (re-search-forward "\\S-+") - (setq file (buffer-substring-no-properties - (match-beginning 0) (match-end 0))) - (beginning-of-line) - (insert "# ") ; to ensure we don't re-process this file - (beginning-of-line)) - (t (setq file nil)))) - (goto-char (point-min)) - (while (re-search-forward - "^\\(a\\|alias\\|g\\|group\\)[ \t]+\\([^ \t]+\\)" nil t) - (let* ((name (match-string 2)) - (start (progn (skip-chars-forward " \t") (point)))) - (end-of-line) - (define-mail-alias - name - (buffer-substring-no-properties start (point)) - t))) - mail-aliases) - (if buffer (kill-buffer buffer)) - (set-buffer obuf)))) - -;; Always autoloadable in case the user wants to define aliases -;; interactively or in .emacs. -;;;###autoload -(defun define-mail-alias (name definition &optional from-mailrc-file) - "Define NAME as a mail alias that translates to DEFINITION. -This means that sending a message to NAME will actually send to DEFINITION. - -Normally, the addresses in DEFINITION must be separated by commas. -If FROM-MAILRC-FILE is non-nil, then addresses in DEFINITION -can be separated by spaces; an address can contain spaces -if it is quoted with double-quotes." - - (interactive "sDefine mail alias: \nsDefine %s as mail alias for: ") - ;; Read the defaults first, if we have not done so. - (sendmail-sync-aliases) - (if (eq mail-aliases t) - (progn - (setq mail-aliases nil) - (if (file-exists-p mail-personal-alias-file) - (build-mail-aliases)))) - ;; strip garbage from front and end - (if (string-match "\\`[ \t\n,]+" definition) - (setq definition (substring definition (match-end 0)))) - (if (string-match "[ \t\n,]+\\'" definition) - (setq definition (substring definition 0 (match-beginning 0)))) - (let ((result '()) - ;; If DEFINITION is null string, avoid looping even once. - (start (and (not (equal definition "")) 0)) - (L (length definition)) - end tem) - (while start - ;; If we're reading from the mailrc file, then addresses are delimited - ;; by spaces, and addresses with embedded spaces must be surrounded by - ;; double-quotes. Otherwise, addresses are separated by commas. - (if from-mailrc-file - (if (eq ?\" (aref definition start)) - (setq start (1+ start) - end (string-match "\"[ \t,]*" definition start)) - (setq end (string-match "[ \t,]+" definition start))) - (setq end (string-match "[ \t\n,]*,[ \t\n,]*" definition start))) - (setq result (cons (substring definition start end) result)) - (setq start (and end - (/= (match-end 0) L) - (match-end 0)))) - (setq definition (mapconcat (function identity) - (nreverse result) - ", ")) - (setq tem (assoc name mail-aliases)) - (if tem - (rplacd tem definition) - (setq mail-aliases (cons (cons name definition) mail-aliases) - mail-names t)))) - -;;;###autoload -(defun mail-complete (arg) - "Perform completion on header field or word preceding point. -Completable headers are according to `mail-complete-alist'. If none matches -current header, calls `mail-complete-function' and passes prefix arg if any." - (interactive "P") - ;; Read the defaults first, if we have not done so. - (sendmail-sync-aliases) - (if (eq mail-aliases t) - (progn - (setq mail-aliases nil) - (if (file-exists-p mail-personal-alias-file) - (build-mail-aliases)))) - (let ((list mail-complete-alist)) - (if (and (save-excursion (search-forward - (concat "\n" mail-header-separator "\n") - nil t)) - (save-excursion - (if (re-search-backward "^[^\t]" nil t) - (while list - (if (looking-at (car (car list))) - (setq arg (cdr (car list)) - list ()) - (setq list (cdr list))))) - arg)) - (let* ((end (point)) - (beg (save-excursion - (skip-chars-backward "^ \t<,:") - (point))) - (pattern (buffer-substring beg end)) - completion) - (setq list (eval arg) - completion (try-completion pattern list)) - (cond ((eq completion t)) - ((null completion) - (message "Can't find completion for \"%s\"" pattern) - (ding)) - ((not (string= pattern completion)) - (delete-region beg end) - (insert completion)) - (t - (message "Making completion list...") - (with-output-to-temp-buffer "*Completions*" - (display-completion-list - (all-completions pattern list))) - (message "Making completion list...%s" "done")))) - (funcall mail-complete-function arg)))) - -(defun mail-get-names (pattern) - "Fetch local users and global mail adresses for completion. -Consults `/etc/passwd' and a directory service if one is set up via -`mail-directory-function'." - (if (eq mail-local-names t) - (save-excursion - (set-buffer (generate-new-buffer " passwd")) - (insert-file-contents "/etc/passwd" nil nil nil t) - (setq mail-local-names) - (while (not (eobp)) - ;;Recognize lines like - ;; nobody:*:65534:65534::/: - ;; +demo::::::/bin/csh - ;; +ethanb - ;;while skipping - ;; +@SOFTWARE - (if (looking-at "\\+?\\([^:@\n+]+\\)") - (add-to-list 'mail-local-names (list (match-string 1)))) - (beginning-of-line 2)) - (kill-buffer (current-buffer)))) - (if (or (eq mail-names t) - (eq mail-directory-names t)) - (let (directory) - (and mail-directory-function - (eq mail-directory-names t) - (setq directory - (mail-directory (if mail-directory-requery pattern)))) - (if (or directory - (eq mail-names t)) - (setq mail-names - (sort (append (if (consp mail-aliases) mail-aliases) - (if (consp mail-local-names) - mail-local-names) - directory) - (lambda (a b) - ;; should cache downcased strings - (string< (downcase (car a)) - (downcase (car b))))))) - (or mail-directory-requery - (setq mail-directory-names directory)))) - mail-names) - - -(defun mail-directory (pattern) - "Call directory to get names matching PATTERN or all if `nil'. -Calls `mail-directory-function' and applies `mail-directory-parser' to output." - (save-excursion - (message "Querying directory...") - (set-buffer (generate-new-buffer " *mail-directory*")) - (funcall mail-directory-function pattern) - (goto-char 1) - (let (directory) - (if (stringp mail-directory-parser) - (while (re-search-forward mail-directory-parser nil t) - (setq directory - `((,(match-string 1)) - ,@directory))) - (if mail-directory-parser - (setq directory (funcall mail-directory-parser)) - (while (not (eobp)) - (setq directory - `((,(buffer-substring (point) - (progn - (forward-line) - (if (bolp) - (1- (point)) - (point))))) - ,@directory))))) - (kill-buffer (current-buffer)) - (message "Querying directory...done") - directory))) - - -(defun mail-directory-process (pattern) - "Call a Unix process to output names in directory. -See `mail-directory-process'." - (apply 'call-process (eval (car mail-directory-process)) nil t nil - (mapcar 'eval (cdr mail-directory-process)))) - -;; This should handle a dialog. Currently expects port to spit out names. -(defun mail-directory-stream (pattern) - "Open a stream to retrieve names in directory. -See `mail-directory-stream'." - (let (mailalias-done) - (set-process-sentinel - (apply 'open-network-stream "mailalias" (current-buffer) - mail-directory-stream) - (lambda (x x) - (setq mailalias-done t))) - (while (not mailalias-done) - (sit-for .1)))) - -(defun mail-sentto-newsgroups () - "Return all entries from Newsgroups: header as completion alist." - (save-excursion - (if (mail-position-on-field "newsgroups" t) - (let ((point (point)) - list) - (while (< (skip-chars-backward "^:, \t\n") 0) - (setq list `((,(buffer-substring (point) point)) - ,@list)) - (skip-chars-backward ", \t\n") - (setq point (point))) - list)))) - -(provide 'mailalias) - -;;; mailalias.el ends here diff --git a/lisp/mail/mailheader.el b/lisp/mail/mailheader.el deleted file mode 100644 index 142b29c4f35..00000000000 --- a/lisp/mail/mailheader.el +++ /dev/null @@ -1,183 +0,0 @@ -;;; mailheader.el --- Mail header parsing, merging, formatting - -;; Copyright (C) 1996 by Free Software Foundation, Inc. - -;; Author: Erik Naggum <erik@arcana.naggum.no> -;; Keywords: tools, mail, news - -;; 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 package provides an abstraction to RFC822-style messages, used in -;; mail, news, and some other systems. The simple syntactic rules for such -;; headers, such as quoting and line folding, are routinely reimplemented -;; in many individual packages. This package removes the need for this -;; redundancy by representing message headers as association lists, -;; offering functions to extract the set of headers from a message, to -;; parse individual headers, to merge sets of headers, and to format a set -;; of headers. - -;; The car of each element in the message-header alist is a symbol whose -;; print name is the name of the header, in all lower-case. The cdr of an -;; element depends on the operation. After extracting headers from a -;; messge, it is a string, the value of the header. An extracted set of -;; headers may be parsed further, which may turn it into a list, whose car -;; is the original value and whose subsequent elements depend on the -;; header. For formatting, it is evaluated to obtain the strings to be -;; inserted. For merging, one set of headers consists of strings, while -;; the other set will be evaluated with the symbols in the first set of -;; headers bound to their respective values. - -;;; Code: - -(eval-when-compile - (require 'cl)) - -;; Make the byte-compiler shut up. -(defvar headers) - -(defun mail-header-extract () - "Extract headers from current buffer after point. -Returns a header alist, where each element is a cons cell (name . value), -where NAME is a symbol, and VALUE is the string value of the header having -that name." - (let ((message-headers ()) (top (point)) - start end) - (while (and (setq start (point)) - (> (skip-chars-forward "^\0- :") 0) - (= (following-char) ?:) - (setq end (point)) - (progn (forward-char) - (> (skip-chars-forward " \t") 0))) - (let ((header (intern (downcase (buffer-substring start end)))) - (value (list (buffer-substring - (point) (progn (end-of-line) (point)))))) - (while (progn (forward-char) (> (skip-chars-forward " \t") 0)) - (push (buffer-substring (point) (progn (end-of-line) (point))) - value)) - (push (if (cdr value) - (cons header (mapconcat #'identity (nreverse value) " ")) - (cons header (car value))) - message-headers))) - (goto-char top) - (nreverse message-headers))) - -(defun mail-header-extract-no-properties () - "Extract headers from current buffer after point, without properties. -Returns a header alist, where each element is a cons cell (name . value), -where NAME is a symbol, and VALUE is the string value of the header having -that name." - (mapcar - (lambda (elt) - (set-text-properties 0 (length (cdr elt)) nil (cdr elt)) - elt) - (mail-header-extract))) - -(defun mail-header-parse (parsing-rules headers) - "Apply PARSING-RULES to HEADERS. -PARSING-RULES is an alist whose keys are header names (symbols) and whose -value is a parsing function. The function takes one argument, a string, -and return a list of values, which will destructively replace the value -associated with the key in HEADERS, after being prepended with the original -value." - (dolist (rule parsing-rules) - (let ((header (assq (car rule) headers))) - (when header - (if (consp (cdr header)) - (setf (cddr header) (funcall (cdr rule) (cadr header))) - (setf (cdr header) - (cons (cdr header) (funcall (cdr rule) (cdr header)))))))) - headers) - -(defsubst mail-header (header &optional header-alist) - "Return the value associated with header HEADER in HEADER-ALIST. -If the value is a string, it is the original value of the header. If the -value is a list, its first element is the original value of the header, -with any subsequent elements bing the result of parsing the value. -If HEADER-ALIST is nil, the dynamically bound variable `headers' is used." - (cdr (assq header (or header-alist headers)))) - -(defun mail-header-set (header value &optional header-alist) - "Set the value associated with header HEADER to VALUE in HEADER-ALIST. -HEADER-ALIST defaults to the dynamically bound variable `headers' if nil. -See `mail-header' for the semantics of VALUE." - (let* ((alist (or header-alist headers)) - (entry (assq header alist))) - (if entry - (setf (cdr entry) value) - (nconc alist (list (cons header value))))) - value) - -(defsetf mail-header (header &optional header-alist) (value) - `(mail-header-set ,header ,value ,header-alist)) - -(defun mail-header-merge (merge-rules headers) - "Return a new header alist with MERGE-RULES applied to HEADERS. -MERGE-RULES is an alist whose keys are header names (symbols) and whose -values are forms to evaluate, the results of which are the new headers. It -should be a string or a list of string. The first element may be nil to -denote that the formatting functions must use the remaining elements, or -skip the header altogether if there are no other elements. - The macro `mail-header' can be used to access headers in HEADERS." - (mapcar - (lambda (rule) - (cons (car rule) (eval (cdr rule)))) - merge-rules)) - -(defvar mail-header-format-function - (lambda (header value) - "Function to format headers without a specified formatting function." - (insert (capitalize (symbol-name header)) - ": " - (if (consp value) (car value) value) - "\n"))) - -(defun mail-header-format (format-rules headers) - "Use FORMAT-RULES to format HEADERS and insert into current buffer. -FORMAT-RULES is an alist whose keys are header names (symbols), and whose -values are functions that format the header, the results of which are -inserted, unless it is nil. The function takes two arguments, the header -symbol, and the value of that header. If the function itself is nil, the -default action is to insert the value of the header, unless it is nil. -The headers are inserted in the order of the FORMAT-RULES. -A key of t represents any otherwise unmentioned headers. -A key of nil has as its value a list of defaulted headers to ignore." - (let ((ignore (append (cdr (assq nil format-rules)) - (mapcar #'car format-rules)))) - (dolist (rule format-rules) - (let* ((header (car rule)) - (value (mail-header header))) - (cond ((null header) 'ignore) - ((eq header t) - (dolist (defaulted headers) - (unless (memq (car defaulted) ignore) - (let* ((header (car defaulted)) - (value (cdr defaulted))) - (if (cdr rule) - (funcall (cdr rule) header value) - (funcall mail-header-format-function header value)))))) - (value - (if (cdr rule) - (funcall (cdr rule) header value) - (funcall mail-header-format-function header value)))))) - (insert "\n"))) - -(provide 'mailheader) - -;;; mailheader.el ends here diff --git a/lisp/mail/mailpost.el b/lisp/mail/mailpost.el deleted file mode 100644 index 5ff33478698..00000000000 --- a/lisp/mail/mailpost.el +++ /dev/null @@ -1,103 +0,0 @@ -;;; mailpost.el --- RMAIL coupler to /usr/uci/post mailer - -;; This is in the public domain -;; since Delp distributed it without a copyright notice in 1986. - -;; Author: Gary Delp <delp@huey.Udel.Edu> -;; Maintainer: FSF -;; Created: 13 Jan 1986 -;; Keywords: mail - -;;; Commentary: - -;; Yet another mail interface. this for the rmail system to provide -;; the missing sendmail interface on systems without /usr/lib/sendmail, -;; but with /usr/uci/post. - -;;; Code: - -(require 'mailalias) -(require 'sendmail) - -;; (setq send-mail-function 'post-mail-send-it) - -(defun post-mail-send-it () - "The MH -post interface for `rmail-mail' to call. -To use it, include \"(setq send-mail-function 'post-mail-send-it)\" in -site-init." - (let ((errbuf (if mail-interactive - (generate-new-buffer " post-mail errors") - 0)) - (temfile "/tmp/,rpost") - (tembuf (generate-new-buffer " post-mail temp")) - (case-fold-search nil) - delimline - (mailbuf (current-buffer))) - (unwind-protect - (save-excursion - (set-buffer tembuf) - (erase-buffer) - (insert-buffer-substring mailbuf) - (goto-char (point-max)) - ;; require one newline at the end. - (or (= (preceding-char) ?\n) - (insert ?\n)) - ;; Change header-delimiter to be what post-mail expects. - (goto-char (point-min)) - (search-forward (concat "\n" mail-header-separator "\n")) - (replace-match "\n\n") - (backward-char 1) - (setq delimline (point-marker)) - (if mail-aliases - (expand-mail-aliases (point-min) delimline)) - (goto-char (point-min)) - ;; ignore any blank lines in the header - (while (and (re-search-forward "\n\n\n*" delimline t) - (< (point) delimline)) - (replace-match "\n")) - ;; Find and handle any FCC fields. - (let ((case-fold-search t)) - (goto-char (point-min)) - (if (re-search-forward "^FCC:" delimline t) - (mail-do-fcc delimline)) - ;; If there is a From and no Sender, put it a Sender. - (goto-char (point-min)) - (and (re-search-forward "^From:" delimline t) - (not (save-excursion - (goto-char (point-min)) - (re-search-forward "^Sender:" delimline t))) - (progn - (forward-line 1) - (insert "Sender: " (user-login-name) "\n"))) - ;; don't send out a blank subject line - (goto-char (point-min)) - (if (re-search-forward "^Subject:[ \t]*\n" delimline t) - (replace-match "")) - (if mail-interactive - (save-excursion - (set-buffer errbuf) - (erase-buffer)))) - (write-file (setq temfile (make-temp-name temfile))) - (set-file-modes temfile 384) - (apply 'call-process - (append (list (if (boundp 'post-mail-program) - post-mail-program - "/usr/uci/lib/mh/post") - nil errbuf nil - "-nofilter" "-msgid") - (if mail-interactive '("-watch") '("-nowatch")) - (list temfile))) - (if mail-interactive - (save-excursion - (set-buffer errbuf) - (goto-char (point-min)) - (while (re-search-forward "\n\n* *" nil t) - (replace-match "; ")) - (if (not (zerop (buffer-size))) - (error "Sending...failed to %s" - (buffer-substring (point-min) (point-max))))))) - (kill-buffer tembuf) - (if (bufferp errbuf) - (switch-to-buffer errbuf))))) - -;;; mailpost.el ends here diff --git a/lisp/mail/metamail.el b/lisp/mail/metamail.el deleted file mode 100644 index 98ad5fb3a86..00000000000 --- a/lisp/mail/metamail.el +++ /dev/null @@ -1,200 +0,0 @@ -;;; metamail.el --- Metamail interface for GNU Emacs - -;; Copyright (C) 1993, 1996 Masanobu UMEDA - -;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp> -;; Version: $Header: metamail.el,v 1.10 96/04/18 11:27:08 umerin Exp $ -;; Keywords: mail, news, mime, multimedia - -;; 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: - -;; The latest version will be at: -;; ftp://ftp.kyutech.ac.jp/pub/MultiMedia/mime/emacs-mime-tools.shar - -;; Note: Metamail does not have all options which is compatible with -;; the environment variables. For that reason, matamail.el have to -;; hack the environment variables. In addition, there is no way to -;; display all header fields without extra informative body messages -;; which are suppressed by "-q" option. - -;; The following definition is what I'm using with GNUS 4: -;;(setq gnus-show-mime-method -;; (function -;; (lambda () -;; (metamail-interpret-header) -;; (let ((metamail-switches ;Suppress header fields in a body. -;; (append metamail-switches '("-q")))) -;; (metamail-interpret-body))))) - -;; The idea of using metamail to process MIME messages is from -;; gnus-mime.el by Spike <Spike@world.std.com>. - -;;; Code: - -(defvar metamail-program-name "metamail" - "*Metamail program name.") - -(defvar metamail-mailer-name "emacs" - "*Mailer name set to MM_MAILER environment variable.") - -(defvar metamail-environment '("KEYHEADS=*" "MM_QUIET=1") - "*Environment variables passed to `metamail'. -It must be a list of strings that have the format ENVVARNAME=VALUE. -It is not expected to be altered globally by `set' or `setq'. -Instead, change its value temporary using `let' or `let*' form.") - -(defvar metamail-switches '("-x" "-d" "-z") - "*Switches for `metamail' program. -`-z' is required to remove zap file. -It is not expected to be altered globally by `set' or `setq'. -Instead, change its value temporary using `let' or `let*' form. -`-m MAILER' argument is automatically generated from the -`metamail-mailer-name' variable.") - -;;;###autoload -(defun metamail-interpret-header () - "Interpret a header part of a MIME message in current buffer. -Its body part is not interpreted at all." - (interactive) - (save-excursion - (let* ((buffer-read-only nil) - (metamail-switches ;Inhibit processing an empty body. - (append metamail-switches '("-c" "text/plain" "-E" "7bit"))) - (end (progn - (goto-char (point-min)) - (search-forward "\n\n" nil 'move) - ;; An extra newline is inserted by metamail if there - ;; is no body part. So, insert a dummy body by - ;; itself. - (insert "\n") - (point)))) - (metamail-region (point-min) end nil nil 'nodisplay) - ;; Remove an extra newline inserted by myself. - (goto-char (point-min)) - (if (search-forward "\n\n\n" nil t) - (delete-char -1)) - ))) - -;;;###autoload -(defun metamail-interpret-body (&optional viewmode nodisplay) - "Interpret a body part of a MIME message in current buffer. -Optional argument VIEWMODE specifies the value of the -EMACS_VIEW_MODE environment variable (defaulted to 1). -Optional argument NODISPLAY non-nil means buffer is not -redisplayed as output is inserted. -Its header part is not interpreted at all." - (interactive "p") - (save-excursion - (let ((contype nil) - (encoding nil) - (end (progn - (goto-char (point-min)) - (search-forward "\n\n" nil t) - (point)))) - ;; Find Content-Type and Content-Transfer-Encoding from the header. - (save-restriction - (narrow-to-region (point-min) end) - (setq contype - (or (mail-fetch-field "Content-Type") "text/plain")) - (setq encoding - (or (mail-fetch-field "Content-Transfer-Encoding") "7bit"))) - ;; Interpret the body part only. - (let ((metamail-switches ;Process body part only. - (append metamail-switches - (list "-b" "-c" contype "-E" encoding)))) - (metamail-region end (point-max) viewmode nil nodisplay)) - ;; Mode specific hack. - (cond ((eq major-mode 'rmail-mode) - ;; Adjust the marker of this message if in Rmail mode buffer. - (set-marker (aref rmail-message-vector (1+ rmail-current-message)) - (point-max)))) - ))) - -;;;###autoload -(defun metamail-buffer (&optional viewmode buffer nodisplay) - "Process current buffer through `metamail'. -Optional argument VIEWMODE specifies the value of the -EMACS_VIEW_MODE environment variable (defaulted to 1). -Optional argument BUFFER specifies a buffer to be filled (nil -means current). -Optional argument NODISPLAY non-nil means buffer is not -redisplayed as output is inserted." - (interactive "p") - (metamail-region (point-min) (point-max) viewmode buffer nodisplay)) - -;;;###autoload -(defun metamail-region (beg end &optional viewmode buffer nodisplay) - "Process current region through 'metamail'. -Optional argument VIEWMODE specifies the value of the -EMACS_VIEW_MODE environment variable (defaulted to 1). -Optional argument BUFFER specifies a buffer to be filled (nil -means current). -Optional argument NODISPLAY non-nil means buffer is not -redisplayed as output is inserted." - (interactive "r\np") - (let ((curbuf (current-buffer)) - (buffer-read-only nil) - (metafile (make-temp-name "/tmp/metamail")) - (option-environment - (list (concat "EMACS_VIEW_MODE=" - (if (numberp viewmode) viewmode 1))))) - (save-excursion - ;; Gee! Metamail does not ouput to stdout if input comes from - ;; stdin. - (let ((selective-display nil) ;Disable ^M to nl translation. - (kanji-fileio-code 2) ;Write in JIS code when nemacs. - (file-coding-system ;Write in JUNET style when mule. - (if (featurep 'mule) *junet*))) - (write-region beg end metafile nil 'nomessage)) - (if buffer - (set-buffer buffer)) - (setq buffer-read-only nil) - ;; Clear destination buffer. - (if (eq curbuf (current-buffer)) - (delete-region beg end) - (delete-region (point-min) (point-max))) - ;; We have to pass the environment variable KEYHEADS to display - ;; all header fields. Metamail should have an optional argument - ;; to pass such information directly. - (let ((process-environment - (append process-environment - metamail-environment option-environment))) - ;; Specify character coding system. - (if (boundp 'NEMACS) - (define-program-kanji-code nil metamail-program-name 2)) ;JIS - (if (featurep 'mule) - (define-program-coding-system nil metamail-program-name *junet*)) - (apply (function call-process) - metamail-program-name - nil - t ;Output to current buffer - (not nodisplay) ;Force redisplay - (append metamail-switches - (list "-m" (or metamail-mailer-name "emacs")) - (list metafile)))) - ;; `metamail' may not delete the temporary file! - (condition-case error - (delete-file metafile) - (error nil)) - ))) - -(provide 'metamail) - -;;; metamail.el ends here diff --git a/lisp/mail/mh-comp.el b/lisp/mail/mh-comp.el deleted file mode 100644 index 25117cac6c2..00000000000 --- a/lisp/mail/mh-comp.el +++ /dev/null @@ -1,1052 +0,0 @@ -;;; mh-comp --- mh-e functions for composing messages -;; Time-stamp: <95/08/19 17:48:59 gildea> - -;; Copyright (C) 1993, 1995 Free Software Foundation, Inc. - -;; This file is part of mh-e, 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.7 1995/11/03 02:28:52 kwzh Exp erik $ - -;;; Code: - -(provide 'mh-comp) -(require 'mh-utils) - -;;; 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-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.") - -;;; Copied from sendmail.el for Hyperbole -(defvar mail-header-separator "--------" - "*Line used by MH to separate headers from text in messages being composed.") - -;;; Personal preferences: - -(defvar mh-delete-yanked-msg-window nil - "*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.") - -(defvar mh-yank-from-start-of-msg t - "*Controls which part of a message is yanked by \\<mh-letter-mode-map>\\[mh-yank-cur-msg]. -If non-nil, include the entire message. If the symbol `body', then yank the -message minus the header. If nil, yank only the portion of the message -following the point. If the show buffer has a region, this variable is -ignored.") - -(defvar 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].") - -(defvar 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.") - -(defvar mh-signature-file-name "~/.signature" - "*Name of file containing the user's signature. -Inserted into message by \\<mh-letter-mode-map>\\[mh-insert-signature].") - -(defvar 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.") - -(defvar mh-comp-formfile "components" - "Name of file to be used as a skeleton for composing messages. -Default is \"components\". If not a complete path 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 a complete path name, the file -is searched for first in the user's MH directory, then in the -system MH lib directory.") - -;;; Hooks: - -(defvar mh-letter-mode-hook nil - "Invoked in `mh-letter-mode' on a new letter.") - -(defvar mh-compose-letter-function nil - "Invoked when setting up a letter draft. -It is passed three arguments: TO recipients, SUBJECT, and CC recipients.") - -(defvar mh-before-send-letter-hook nil - "Invoked at the beginning of the \\<mh-letter-mode-map>\\[mh-send-letter] command.") - - -(defvar mh-rejected-letter-start - (concat "^ ----- Unsent message follows -----$" ;from sendmail V5 - "\\|^ ----- 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 - ) - "Regexp specifying the beginning of the wrapper around a returned letter. -This wrapper is generated by the mail system when rejecting a letter.") - -(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)) - - -;;;###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 () - "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." - (mh-find-path) - (let ((mh-error-if-no-draft t)) - (mh-send "" "" ""))) - - -(defun mh-edit-again (msg) - "Clean-up a draft or a message 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)) - (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) - (goto-char (point-min)) - (save-buffer) - (mh-compose-and-send-mail draft "" from-folder nil nil nil nil nil nil - config))) - - -(defun mh-extract-rejected-mail (msg) - "Extract a letter 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."))) - (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))) - - -(defun mh-forward (to cc &optional msg-or-seq) - "Forward a message or message sequence. Defaults to displayed message. -If optional prefix argument provided, then prompt for the message sequence. -See also documentation for `\\[mh-send]' function." - (interactive (list (mh-read-address "To: ") - (mh-read-address "Cc: ") - (if current-prefix-arg - (mh-read-seq-default "Forward" t) - (mh-get-msg-num t)))) - (or msg-or-seq - (setq msg-or-seq (mh-get-msg-num t))) - (let* ((folder mh-current-folder) - (config (current-window-configuration)) - ;; 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" - mh-current-folder msg-or-seq) - (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) - (goto-char (point-min)) - (re-search-forward "^------- Forwarded Message") - (forward-line 1) - (skip-chars-forward " \t\n") - (save-restriction - (narrow-to-region (point) (point-max)) - (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))) - (mh-insert-fields "Subject:" forw-subject) - (goto-char (point-min)) - (re-search-forward "^------- Forwarded Message") - (forward-line -1) - (delete-other-windows) - (if (numberp msg-or-seq) - (mh-add-msgs-to-seq msg-or-seq 'forwarded t) - (mh-add-msgs-to-seq (mh-seq-to-msgs msg-or-seq) 'forwarded t)) - (mh-compose-and-send-mail draft "" folder msg-or-seq - to forw-subject cc - mh-note-forw "Forwarded:" - config))))) - -(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)) - - -(defun mh-redistribute (to cc &optional msg) - "Redistribute a letter. -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 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)) - (kill-buffer draft) - (message "Redistributing...done")))) - - -(defun mh-reply (message &optional includep) - "Reply to MESSAGE (default: current message). -If optional prefix argument INCLUDEP provided, then include the message -in the reply using filter mhl.reply in your MH directory. -Prompts for type of addresses to reply to: - from sender only, - to sender and primary recipients, - cc/all sender and all recipients. -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) current-prefix-arg)) - (let ((minibuffer-help-form - "from => Sender only\nto => Sender and primary recipients\ncc or all => Sender and all recipients")) - (let ((reply-to (or mh-reply-default-reply-to - (completing-read "Reply to whom: " - '(("from") ("to") ("cc") ("all")) - nil - t))) - (folder mh-current-folder) - (show-buffer mh-show-buffer) - (config (current-window-configuration))) - (message "Composing a reply...") - (mh-exec-cmd "repl" "-build" "-noquery" "-nodraftfolder" - (if (stringp mh-repl-formfile) ;must be string, but we're paranoid - (list "-form" mh-repl-formfile)) - mh-current-folder message - (cond ((or (equal reply-to "from") (equal reply-to "")) - '("-nocc" "all")) - ((equal reply-to "to") - '("-cc" "to")) - ((or (equal reply-to "cc") (equal reply-to "all")) - '("-cc" "all" "-nocc" "me"))) - (if includep - '("-filter" "mhl.reply"))) - (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 - (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)))))) - - -(defun mh-send (to cc subject) - "Compose and send a letter. -The file named by `mh-comp-formfile' will be used as the form. -Do not call this function from outside mh-e; use \\[mh-smail] instead. - -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, subject, and cc." - (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))) - - -(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. -See also documentation for `\\[mh-send]' function." - (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) - (t - (error (format "Can't find components file \"%s\"" - components))))) - nil))) - (mh-insert-fields "To:" to "Subject:" subject "Cc:" cc) - (goto-char (point-max)) - (message "Composing a message...done") - (mh-compose-and-send-mail draft "" folder msg-num - to subject cc - nil nil config)))) - - -(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 () - ;; Returns 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 the MESSAGE in BUFFER listing with the character NOTE and annotate - ;; the saved 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 (symbolp msg) - (mh-notate-seq msg note (1+ mh-cmd-note)) - (mh-notate msg note (1+ mh-cmd-note))))))) - - -(defun mh-insert-fields (&rest name-values) - ;; Insert the NAME-VALUE pairs in the current buffer. - ;; If field NAME exists, append 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 " " value)) - (t - (insert field-name " " value "\n"))) - (setq name-values (cdr (cdr name-values))))))) - - -(defun mh-position-on-field (field &optional ignore) - ;; 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. - (if (mh-goto-header-field field) - (progn - (mh-header-field-end) - t))) - - -(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 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-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-goto-header-end (arg) - ;; Find the end of the message header in the current buffer and position - ;; the cursor at the ARG'th newline after the header. - (if (re-search-forward "^-*$" nil nil) - (forward-line arg))) - - -(defun mh-read-address (prompt) - ;; Read a To: or Cc: address, prompting in the minibuffer with PROMPT. - ;; May someday do completion on aliases. - (read-string prompt)) - - - -;;; Mode for composing and sending a draft message. - -(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. - -(put 'mh-letter-mode 'mode-class 'special) - -;;;###autoload -(defun mh-letter-mode () - "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. -See the documentation for \\[mh-edit-mhn] for information on composing MIME -messages. - -\\{mh-letter-mode-map} - -Variables controlling this mode (defaults in parentheses): - - mh-delete-yanked-msg-window (nil) - If non-nil, \\[mh-yank-cur-msg] will delete any windows displaying - the yanked message. - - mh-yank-from-start-of-msg (t) - If non-nil, \\[mh-yank-cur-msg] will include the entire message. - If `body', just yank the body (no header). - If nil, only the portion of the message following the point will be yanked. - If there is a region, this variable is ignored. - - mh-ins-buf-prefix (\"> \") - String to insert before each non-blank line of a message as it is - inserted in a draft letter. - - mh-signature-file-name (\"~/.signature\") - File to be inserted into message by \\[mh-insert-signature]. - -Upon invoking mh-letter-mode, text-mode-hook and mh-letter-mode-hook are -invoked with no args, if those values are non-nil." - - (interactive) - (or mh-user-path (mh-find-path)) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "^[ \t]*[-_][-_][-_]+$\\|" paragraph-start)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate - (concat "^[ \t]*[-_][-_][-_]+$\\|" paragraph-separate)) - (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 "--------") ;for Hyperbole - (use-local-map mh-letter-mode-map) - (setq major-mode 'mh-letter-mode) - (mh-set-mode-name "MH-Letter") - (set-syntax-table mh-letter-mode-syntax-table) - (run-hooks 'text-mode-hook) - ;; if text-mode-hook turned on auto-fill, tune it for messages - (cond ((and (boundp 'auto-fill-hook) auto-fill-hook) ;emacs 18 - (make-local-variable 'auto-fill-hook) - (setq auto-fill-hook 'mh-auto-fill-for-letter))) - (cond ((and (boundp 'auto-fill-function) auto-fill-function) ;emacs 19 - (make-local-variable 'auto-fill-function) - (setq auto-fill-function 'mh-auto-fill-for-letter))) - (run-hooks 'mh-letter-mode-hook)) - - -(defun mh-auto-fill-for-letter () - ;; Auto-fill in letters treats the header specially by inserting a tab - ;; before continuation line. - (if (mh-in-header-p) - (let ((fill-prefix "\t")) - (do-auto-fill)) - (do-auto-fill))) - - -(defun mh-in-header-p () - ;; Return non-nil if the point is in the header of a draft message. - (save-excursion - (let ((cur-point (point))) - (goto-char (point-min)) - (re-search-forward "^-*$" nil t) - (< cur-point (point))))) - - -(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))))) - - -(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))))) - - -(defun mh-insert-signature () - "Insert the file named by mh-signature-file-name at the current point." - (interactive) - (insert-file-contents mh-signature-file-name) - (force-mode-line-update)) - - -(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-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. - ;; 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. - ;; SEND-ARGS is an optional argument passed to the send command. - ;; 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) - (mh-letter-mode) - (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-send-letter (&optional arg) - "Send the draft letter in the current buffer. -If optional prefix argument is provided, monitor delivery. -Run mh-before-send-letter-hook before doing anything." - (interactive "P") - (run-hooks 'mh-before-send-letter-hook) - (save-buffer) - (message "Sending...") - (let ((draft-buffer (current-buffer)) - (file-name buffer-file-name) - (config mh-previous-window-config)) - (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")))) - - -(defun mh-insert-letter (folder message verbatim) - "Insert a message into the current letter. -Removes the message's headers using mh-invisible-headers. Prefixes -each non-blank line with mh-ins-buf-prefix. 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 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))) - (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear" - (expand-file-name message - (mh-expand-file-name folder))) - (cond ((not verbatim) - (mh-clean-msg-header start mh-invisible-headers mh-visible-headers) - (set-mark start) ; since mh-clean-msg-header moves it - (mh-insert-prefix-string mh-ins-buf-prefix)))))) - - -(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' is non-nil, any window displaying the -yanked message will be deleted." - (interactive) - (if (and mh-sent-from-folder mh-sent-from-msg) - (let ((to-point (point)) - (to-buffer (current-buffer))) - (set-buffer mh-sent-from-folder) - (if mh-delete-yanked-msg-window - (delete-windows-on mh-show-buffer)) - (set-buffer mh-show-buffer) ; Find displayed message - (let ((mh-ins-str (cond ((if (boundp 'mark-active) - mark-active ;Emacs 19 - (mark)) ;Emacs 18 - (buffer-substring (region-beginning) - (region-end))) - ((eq 'body mh-yank-from-start-of-msg) - (buffer-substring - (save-excursion - (goto-char (point-min)) - (mh-goto-header-end 1) - (point)) - (point-max))) - (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) - (push-mark) - (insert mh-ins-str) - (mh-insert-prefix-string mh-ins-buf-prefix) - (insert "\n")))) - (error "There is no current message"))) - - -(defun mh-insert-prefix-string (mh-ins-string) - ;; Run mail-citation-hook to insert a prefix string before each line - ;; in the buffer. Generality for supercite users. - (set-mark (point-max)) - (goto-char (point-min)) - (cond (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)) - (let ((zmacs-regions nil)) ;so "(mark)" works in XEmacs - (while (< (point) (mark)) - (insert mh-ins-string) - (forward-line 1)))))) - - -(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"))) - - -;;; Build the letter-mode keymap: - -(define-key mh-letter-mode-map "\C-c\C-f\C-b" 'mh-to-field) -(define-key mh-letter-mode-map "\C-c\C-f\C-c" 'mh-to-field) -(define-key mh-letter-mode-map "\C-c\C-f\C-d" 'mh-to-field) -(define-key mh-letter-mode-map "\C-c\C-f\C-f" 'mh-to-fcc) -(define-key mh-letter-mode-map "\C-c\C-f\C-r" 'mh-to-field) -(define-key mh-letter-mode-map "\C-c\C-f\C-s" 'mh-to-field) -(define-key mh-letter-mode-map "\C-c\C-f\C-t" 'mh-to-field) -(define-key mh-letter-mode-map "\C-c\C-fb" 'mh-to-field) -(define-key mh-letter-mode-map "\C-c\C-fc" 'mh-to-field) -(define-key mh-letter-mode-map "\C-c\C-fd" 'mh-to-field) -(define-key mh-letter-mode-map "\C-c\C-ff" 'mh-to-fcc) -(define-key mh-letter-mode-map "\C-c\C-fr" 'mh-to-field) -(define-key mh-letter-mode-map "\C-c\C-fs" 'mh-to-field) -(define-key mh-letter-mode-map "\C-c\C-ft" 'mh-to-field) -(define-key mh-letter-mode-map "\C-c\C-i" 'mh-insert-letter) -(define-key mh-letter-mode-map "\C-c\C-q" 'mh-fully-kill-draft) -(define-key mh-letter-mode-map "\C-c\C-\\" 'mh-fully-kill-draft) ;if no C-q -(define-key mh-letter-mode-map "\C-c\C-s" 'mh-insert-signature) -(define-key mh-letter-mode-map "\C-c\C-^" 'mh-insert-signature) ;if no C-s -(define-key mh-letter-mode-map "\C-c\C-w" 'mh-check-whom) -(define-key mh-letter-mode-map "\C-c\C-y" 'mh-yank-cur-msg) -(define-key mh-letter-mode-map "\C-c\C-c" 'mh-send-letter) -(define-key mh-letter-mode-map "\C-c\C-m\C-f" 'mh-mhn-compose-forw) -(define-key mh-letter-mode-map "\C-c\C-m\C-e" 'mh-mhn-compose-anon-ftp) -(define-key mh-letter-mode-map "\C-c\C-m\C-t" 'mh-mhn-compose-external-compressed-tar) -(define-key mh-letter-mode-map "\C-c\C-m\C-i" 'mh-mhn-compose-insertion) -(define-key mh-letter-mode-map "\C-c\C-e" 'mh-edit-mhn) -(define-key mh-letter-mode-map "\C-c\C-m\C-u" 'mh-revert-mhn-edit) - -;; "C-c /" prefix is used in mh-letter-mode by pgp.el - -;;; autoloads from mh-mime - -(autoload '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. -See also \\[mh-edit-mhn]." t) - -(autoload '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. -See also \\[mh-edit-mhn]." t) - -(autoload '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. -See also \\[mh-edit-mhn]." t) - -(autoload '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 another message in this one. -See also \\[mh-edit-mhn]." t) - -(autoload '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 mhn program is part of MH version 6.8 or later. -The `\\[mh-revert-mhn-edit]' command undoes this command. -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)." t) - -(autoload 'mh-revert-mhn-edit "mh-mime" - "Undoes the effect of \\[mh-edit-mhn] by reverting to the backup file. -Optional non-nil argument means don't ask for confirmation." t) diff --git a/lisp/mail/mh-e.el b/lisp/mail/mh-e.el deleted file mode 100644 index 0a32ca2768d..00000000000 --- a/lisp/mail/mh-e.el +++ /dev/null @@ -1,1484 +0,0 @@ -;;; mh-e.el --- GNU Emacs interface to the MH mail system - -;; Copyright (C) 1985,86,87,88,90,92,93,94,95 Free Software Foundation, Inc. - -;; Maintainer: Stephen Gildea <gildea@lcs.mit.edu> -;; Version: 5.0.2 -;; Keywords: mail -;; Bug-reports: include `M-x mh-version' output in any correspondence - -;; This file is part of mh-e, 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. - -;; 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. - -;; mh-e is an Emacs interface to the MH mail system. -;; The mailing list mh-e@x.org is for discussion of mh-e and -;; announcements of new versions. Send a "subscribe" message to -;; mh-e-request@x.org to be added. Do not report bugs here; mail -;; them directly to the author (see top of mh-e.el source). -;; Include the output of M-x mh-version in any bug report. - -;; mh-e works with GNU Emacs 18 or 19, and MH 6. - -;; NB. 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. - -;; 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) - -;;; 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 -(defconst mh-e-RCS-id "$Id: mh-e.el,v 1.13 1996/01/25 01:02:59 kwzh Exp kwzh $") - -;;; Code: - -(provide 'mh-e) -(require 'mh-utils) - - -;;; Hooks: - -(defvar mh-folder-mode-hook nil - "Invoked in MH-Folder mode on a new folder.") - -(defvar mh-inc-folder-hook nil - "Invoked by \\<mh-folder-mode-map>`\\[mh-inc-folder]' after incorporating mail into a folder.") - -(defvar mh-show-hook nil - "Invoked after \\<mh-folder-mode-map>`\\[mh-show]' shows a message.") - -(defvar mh-show-mode-hook nil - "Invoked in MH-Show mode on each message.") - -(defvar mh-delete-msg-hook nil - "Invoked after marking each message for deletion.") - -(defvar mh-refile-msg-hook nil - "Invoked after marking each message for refiling.") - -(defvar mh-before-quit-hook nil - "Invoked by \\<mh-folder-mode-map>`\\[mh-quit]' before quitting mh-e. See also mh-quit-hook.") - -(defvar mh-quit-hook nil - "Invoked after \\<mh-folder-mode-map>`\\[mh-quit]' quits mh-e. See also mh-before-quit-hook.") - - - -;;; Personal preferences: - -(defvar 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]'.") - -(defvar 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. -Automatically becomes buffer-local when set in any fashion.") -(make-variable-buffer-local 'mh-scan-prog) - -(defvar 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.") - -(defvar mh-print-background nil - "*Print messages in the background if non-nil. -WARNING: do not delete the messages until printing is finished; -otherwise, your output may be truncated.") - -(defvar mh-recenter-summary-p nil - "*Recenter summary window when the show window is toggled off if non-nil.") - -(defvar mh-do-not-confirm nil - "*Non-nil means do not prompt for confirmation before some mh-e commands. -Affects non-recoverable commands such as mh-kill-folder and mh-undo-folder.") - -(defvar 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.") - -;;; 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. - -(defvar mh-good-msg-regexp "^....[^D^]" - "Regexp specifying the scan lines that are 'good' messages.") - -(defvar mh-deleted-msg-regexp "^....D" - "Regexp matching scan lines of deleted messages.") - -(defvar mh-refiled-msg-regexp "^....\\^" - "Regexp matching scan lines of refiled messages.") - -(defvar mh-valid-scan-line "^ *[0-9]" - "Regexp matching scan lines for messages (not error messages).") - -(defvar mh-cur-scan-msg-regexp "^....\\+" - "Regexp matching scan line for the cur message.") - -(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.") - - -;;; Internal variables: - -(defvar mh-last-destination nil) ;Destination of last refile or 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-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) ;Indiction this is not the full folder. - -;;; Macros and generic functions: - -(defun mh-mapc (func list) - (while list - (funcall func (car list)) - (setq list (cdr list)))) - - - -;;; Entry points: - -;;;###autoload -(defun mh-rmail (&optional arg) - "Inc(orporate) new mail with MH, or, with arg, scan an MH mail folder. -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))) - - -;;; mh-smail and mh-smail-other-window have been moved to the new file -;;; mh-comp.el, but Emacs 18 still looks for them here, so provide a -;;; definition here, too, for a while. - -(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." - (interactive) - (mh-find-path) - (require 'mh-comp) - (call-interactively 'mh-send)) - - -(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." - (interactive) - (mh-find-path) - (require 'mh-comp) - (call-interactively 'mh-send-other-window)) - - - -;;; User executable mh-e commands: - - -(defun mh-delete-msg (msg-or-seq) - "Mark the specified MESSAGE(s) 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." - (interactive (list (if current-prefix-arg - (mh-read-seq-default "Delete" 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 MESSAGE(s) 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 [local-]write-file-hooks - - -(defun mh-first-msg () - "Move to the first message." - (interactive) - (goto-char (point-min)) - (while (and (not (eobp)) (not (looking-at mh-valid-scan-line))) - (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' 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) - (mh-invalidate-show-buffer)) - (let ((mhl-formfile nil) - (mh-clean-message-header 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 prefix argument 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'. -Runs `mh-inc-folder-hook' 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 ((config (current-window-configuration))) - (if (not maildrop-name) - (cond ((not (get-buffer mh-inbox)) - (mh-make-folder mh-inbox) - (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) - (run-hooks 'mh-inc-folder-hook)) - - -(defun mh-last-msg () - "Move to the last message." - (interactive) - (goto-char (point-max)) - (while (and (not (bobp)) (looking-at "^$")) - (forward-line -1))) - - -(defun mh-next-undeleted-msg (&optional arg) - "Move to the NTH next undeleted message in window." - (interactive "p") - (setq mh-next-direction 'forward) - (forward-line 1) - (cond ((re-search-forward mh-good-msg-regexp nil 0 arg) - (beginning-of-line) - (mh-maybe-show)) - (t - (forward-line -1) - (if (get-buffer mh-show-buffer) - (delete-windows-on mh-show-buffer))))) - - -(defun mh-refile-msg (msg-or-seq folder) - "Refile MESSAGE(s) (default: displayed message) into FOLDER. -If optional prefix argument provided, then prompt for message sequence." - (interactive - (list (if current-prefix-arg - (mh-read-seq-default "Refile" 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)) - (symbol-name (cdr mh-last-destination))) - "") - t)))) - (setq mh-last-destination (cons 'refile folder)) - (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. -Start by running mh-before-quit-hook. Restore the previous window -configuration, if one exists. Finish by running mh-quit-hook." - (interactive) - (run-hooks 'mh-before-quit-hook) - (mh-update-sequences) - (mh-invalidate-show-buffer) - (bury-buffer (current-buffer)) - (if (get-buffer mh-show-buffer) - (bury-buffer mh-show-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." - (interactive "P") - (scroll-other-window arg)) - - -(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 NTH previous undeleted message in window." - (interactive "p") - (setq mh-next-direction 'backward) - (beginning-of-line) - (cond ((re-search-backward mh-good-msg-regexp nil 0 arg) - (mh-maybe-show)) - (t - (if (get-buffer mh-show-buffer) - (delete-windows-on mh-show-buffer))))) - - -(defun mh-rescan-folder (&optional range) - "Rescan a folder after optionally processing the outstanding commands. -If optional prefix argument is provided, prompt for the range of -messages to display. Otherwise show the entire folder." - (interactive (list (if current-prefix-arg - (mh-read-msg-range "Range to scan [all]? ") - nil))) - (setq mh-next-direction 'forward) - (mh-scan-folder mh-current-folder (or range "all"))) - - -(defun mh-write-msg-to-file (msg file no-headers) - "Append MESSAGE to the end of a FILE. -If NO-HEADERS (prefix argument) 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)) - (file-name-directory (car (cdr mh-last-destination))) - 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)) - (car (cdr mh-last-destination)) - (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))) - (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 - (mh-set-scan-mode) - (mh-show))) - - -(defun mh-undo (msg-or-seq) - "Undo the pending deletion or refile of the specified MESSAGE(s). -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 "Undo" t) - (mh-get-msg-num t)))) - (cond ((numberp msg-or-seq) - (let ((original-position (point))) - (beginning-of-line) - (while (not (or (looking-at mh-deleted-msg-regexp) - (looking-at mh-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-deleted-msg-regexp) - (looking-at mh-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))) - ;; update the mh-refile-list so mh-outstanding-commands-p will work - (mh-mapc (function - (lambda (elt) - (if (not (mh-seq-to-msgs elt)) - (setq mh-refile-list (delq elt mh-refile-list))))) - mh-refile-list) - (if (not (mh-outstanding-commands-p)) - (mh-set-folder-modified-p nil))) - - -;;;###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) - (insert " mh-e info:\n\nversion: " mh-e-RCS-id - "\nEmacs: " emacs-version " on " (symbol-name system-type) " ") - (condition-case () - (call-process "uname" nil t nil "-a") - (file-error)) - (insert "\n\n MH info:\n\n" (expand-file-name "inc" mh-progs) ":\n") - (let ((help-start (point))) - (condition-case err-data - (mh-exec-cmd-output "inc" nil "-help") - (file-error (insert (mapconcat 'concat (cdr err-data) ": ")))) - (goto-char help-start) - (search-forward "version: " nil t) - (beginning-of-line) - (delete-region help-start (point)) - (goto-char (point-min))) - (display-buffer mh-temp-buffer)) - - -(defun mh-visit-folder (folder &optional range) - "Visit FOLDER and display RANGE of messages. -Do not call this function from outside mh-e; see \\[mh-rmail] instead." - (interactive (list (mh-prompt-for-folder "Visit" mh-inbox t) - (mh-read-msg-range "Range [all]? "))) - (let ((config (current-window-configuration))) - (mh-scan-folder folder (or range "all")) - (setq mh-previous-window-config config)) - nil) - - -(defun mh-compat-quit () - "The \"b\" key is obsolescent; will assume you want \"\\[mh-quit]\" ..." - ;; Was going to make it run mh-burst-digest, but got complaint that - ;; 'b' should mean 'back', as it does in info, less, and rn. - ;; This is a temporary compatibility function. - (interactive) - (message "%s" (documentation this-command)) - (sit-for 1) - (call-interactively 'mh-quit)) - - -(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-good-msg-regexp) - (mh-notate nil mh-note-cur mh-cmd-note))) - (or folder-set - (save-excursion - (mh-exec-cmd-quiet t "folder" mh-current-folder "-fast")))))) - - - - -;;; Support routines. - -(defun mh-delete-a-msg (msg) - ;; Delete the MESSAGE. - (save-excursion - (mh-goto-msg msg nil t) - (if (looking-at mh-refiled-msg-regexp) - (error "Message %d is refiled. Undo refile before deleting." msg)) - (if (looking-at mh-deleted-msg-regexp) - nil - (mh-set-folder-modified-p t) - (setq mh-delete-list (cons msg mh-delete-list)) - (mh-add-msgs-to-seq msg 'deleted t) - (mh-notate msg mh-note-deleted mh-cmd-note) - (run-hooks 'mh-delete-msg-hook)))) - -(defun mh-refile-a-msg (msg destination) - ;; Refile MESSAGE in FOLDER. FOLDER is a symbol, not a string. - (save-excursion - (mh-goto-msg msg nil t) - (cond ((looking-at mh-deleted-msg-regexp) - (error "Message %d is deleted. Undo delete before moving." msg)) - ((looking-at mh-refiled-msg-regexp) - (if (y-or-n-p - (format "Message %d already refiled. Copy to %s as well? " - msg destination)) - (mh-exec-cmd "refile" (mh-get-msg-num t) "-link" - "-src" mh-current-folder - (symbol-name destination)) - (message "Message not copied."))) - (t - (mh-set-folder-modified-p t) - (if (not (memq destination mh-refile-list)) - (setq mh-refile-list (cons destination mh-refile-list))) - (if (not (memq msg (mh-seq-to-msgs destination))) - (mh-add-msgs-to-seq msg destination t)) - (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-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)) - (setq mh-showing nil) - (force-mode-line-update) - (if mh-recenter-summary-p - (mh-recenter nil))) - - -(defun mh-undo-msg (msg) - ;; Undo the deletion or refile of one MESSAGE. - (cond ((memq msg mh-delete-list) - (setq mh-delete-list (delq msg mh-delete-list)) - (mh-delete-msg-from-seq msg 'deleted t)) - (t - (mh-mapc (function (lambda (dest) - (mh-delete-msg-from-seq msg dest t))) - mh-refile-list))) - (mh-notate msg ? mh-cmd-note)) - - - - -;;; The folder data abstraction. - -(defun mh-make-folder (name) - ;; Create and initialize a new mail folder called NAME and make it the - ;; current folder. - (switch-to-buffer name) - (setq buffer-read-only nil) - (erase-buffer) - (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) - -(defun mh-folder-mode () - "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. - -Here is a list of the standard keys for mh-e commands, grouped by function. -This list is purposefully not customized; mh-e has a long history, and many -alternate key bindings as a result. This list is to encourage users to use -standard keys so the other keys can perhaps someday be put to new uses. - -t toggle show or scan-only mode -RET show message, or back to top if already showing - -SPC page message forward -DEL page message back - -n next message -p previous message -g go to message by number - -d mark for deletion -o, ^ mark for output (refile) to another folder -? show folder of pending refile -u undo delete or refile marking - -x execute marked deletes and refiles -i incorporate new mail - -m mail a new message -r reply to a message -f forward a message - -q quit mh-e - -M-f visit new folder -M-r rescan this folder - -Here are all the commands with their current binding, listed in key order: -\\{mh-folder-mode-map} - -Variables controlling mh-e operation are (defaults in parentheses): - - mh-recursive-folders (nil) - Non-nil means commands which operate on folders do so recursively. - - mh-bury-show-buffer (t) - Non-nil means that the buffer used to display message is buried. - It will never be offered as the default other buffer. - - mh-clean-message-header (nil) - Non-nil means remove header lines matching the regular expression - specified in mh-invisible-headers from messages. - - mh-visible-headers (nil) - If non-nil, it contains a regexp specifying the headers that are shown in - a message if mh-clean-message-header is non-nil. Setting this variable - overrides mh-invisible-headers. - - mh-do-not-confirm (nil) - Non-nil means do not prompt for confirmation before executing some - non-recoverable commands such as mh-kill-folder and mh-undo-folder. - - mhl-formfile (nil) - Name of format file to be used by mhl to show messages. - A value of T means use the default format file. - Nil means don't use mhl to format messages. - - mh-lpr-command-format (\"lpr -p -J '%s'\") - Format for command used to print a message on a system printer. - - 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. - Automatically becomes buffer-local when set in any fashion. - - mh-print-background (nil) - Print messages in the background if non-nil. - WARNING: do not delete the messages until printing is finished; - otherwise, your output may be truncated. - - mh-recenter-summary-p (nil) - If non-nil, then the scan listing is recentered when the window displaying - a messages is toggled off. - - mh-summary-height (4) - Number of lines in the summary window including the mode line. - -The value of mh-folder-mode-hook is called when a new folder is set up." - - (kill-all-local-variables) - (use-local-map mh-folder-mode-map) - (setq major-mode 'mh-folder-mode) - (mh-set-mode-name "MH-Folder") - (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 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-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 ; Indiction this is not the full folder - 'mh-previous-window-config nil) ; Previous window configuration - (setq truncate-lines t) - (auto-save-mode -1) - (setq buffer-offer-save t) - (if (boundp 'local-write-file-hooks) - (setq local-write-file-hooks '(mh-execute-commands)) ;Emacs 19 - (make-local-variable 'write-file-hooks) - (setq write-file-hooks '(mh-execute-commands))) ;Emacs 18 - (make-local-variable 'revert-buffer-function) - (setq revert-buffer-function 'mh-undo-folder) - (or (assq 'mh-showing minor-mode-alist) - (setq minor-mode-alist - (cons '(mh-showing " Show") minor-mode-alist))) - (run-hooks 'mh-folder-mode-hook)) - - -(defun mh-make-local-vars (&rest pairs) - ;; Take VARIABLE-VALUE pairs and make local variables initialized to the - ;; value. - (while pairs - (make-variable-buffer-local (car pairs)) - (set (car pairs) (car (cdr pairs))) - (setq pairs (cdr (cdr pairs))))) - - -(defun mh-scan-folder (folder range) - ;; Scan the FOLDER over the RANGE. Return in the folder's buffer. - (cond ((null (get-buffer folder)) - (mh-make-folder folder)) - (t - (mh-process-or-undo-commands folder) - (switch-to-buffer folder))) - (mh-regenerate-headers range) - (cond ((zerop (buffer-size)) - (if (equal range "all") - (message "Folder %s is empty" folder) - (message "No messages in %s, range %s" folder range)) - (sit-for 5))) - (mh-goto-cur-msg)) - - -(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) - scan-start) - (message "Scanning %s..." folder) - (with-mh-folder-updating (nil) - (if update - (goto-char (point-max)) - (erase-buffer)) - (setq scan-start (point)) - (mh-exec-cmd-output mh-scan-prog nil - "-noclear" "-noheader" - "-width" (window-width) - folder range) - (goto-char scan-start) - (cond ((looking-at "scan: no messages in") - (keep-lines mh-valid-scan-line)) ; Flush random scan lines - ((looking-at "scan: ")) ; Keep error messages - (t - (keep-lines mh-valid-scan-line))) ; 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-get-new-mail (maildrop-name) - ;; Read new mail from a maildrop into the current buffer. - ;; Return in the current buffer. - (let ((point-before-inc (point)) - (folder mh-current-folder) - (new-mail-p 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))) - (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 - "-file" (expand-file-name maildrop-name) - "-width" (window-width) - "-truncate") - (mh-exec-cmd-output mh-inc-prog nil - "-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 ""))) - ((re-search-forward "^inc:" nil t) ; Error messages - (error "inc error")) - (t - (mh-remove-cur-notation) - (setq new-mail-p t))) - (keep-lines mh-valid-scan-line) ; Flush random scan lines - (setq mh-seq-list (mh-read-folder-sequences folder t)) - (mh-notate-user-sequences) - (if new-mail-p - (progn - (mh-make-folder-mode-line) - (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. It used to be used to pass - ;; in what is now stored in the buffer-local variable - ;; mh-mode-line-annotation. - (save-excursion - (mh-first-msg) - (setq mh-first-msg-num (mh-get-msg-num nil)) - (mh-last-msg) - (setq mh-last-msg-num (mh-get-msg-num nil)) - (setq mh-msg-count (count-lines (point-min) (point-max))) - (setq mode-line-buffer-identification - (list (format "{%%b%s} %d msg%s" - (if mh-mode-line-annotation - (format "/%s" mh-mode-line-annotation) - "") - mh-msg-count - (if (zerop mh-msg-count) - "s" - (if (> mh-msg-count 1) - (format "s (%d-%d)" mh-first-msg-num - mh-last-msg-num) - (format " (%d)" mh-first-msg-num)))))))) - - -(defun mh-unmark-all-headers (remove-all-flags) - ;; Remove all '+' flags from the headers, and if called with a non-nil - ;; argument, 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 (eql char (aref mh-note-deleted 0)) - (eql char (aref mh-note-refiled 0)))) - (eql char (aref mh-note-cur 0))) - (progn - (delete-char 1) - (insert " "))) - (if remove-all-flags - (progn - (forward-char 1) - (if (eql (following-char) (aref mh-note-seq 0)) - (progn - (delete-char 1) - (insert " "))))) - (forward-line))))) - - -(defun mh-remove-cur-notation () - ;; Remove old cur notation (cf mh-goto-cur-msg code). - (let ((cur-msg (car (mh-seq-to-msgs 'cur)))) - (save-excursion - (and cur-msg - (mh-goto-msg cur-msg t t) - (looking-at mh-cur-scan-msg-regexp) - (mh-notate nil ? mh-cmd-note))))) - -(defun mh-goto-cur-msg () - ;; Position the cursor at the current message. - (let ((cur-msg (car (mh-seq-to-msgs 'cur)))) - (cond ((and cur-msg - (mh-goto-msg cur-msg t t)) - (mh-notate nil mh-note-cur mh-cmd-note) - (mh-recenter 0) - (mh-maybe-show cur-msg)) - (t - (mh-last-msg) - (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 - (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 the folder FOLDER. - (message "Processing deletes and refiles for %s..." folder) - (set-buffer folder) - (with-mh-folder-updating (nil) - ;; Update the unseen sequence if it exists - (mh-update-unseen) - - ;; Then refile messages - (mh-mapc - (function - (lambda (dest) - (let ((msgs (mh-seq-to-msgs dest))) - (cond (msgs - (apply 'mh-exec-cmd "refile" - "-src" folder (symbol-name dest) - (mh-coalesce-msg-list msgs)) - (mh-delete-scan-msgs msgs)))))) - mh-refile-list) - (setq mh-refile-list nil) - - ;; Now delete messages - (cond (mh-delete-list - (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")))) - - (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 () - ;; Flush updates to the Unseen sequence out to MH. - ;; Return non-NIL iff set the MH folder. - (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) - (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 each of the msgs in the LIST. - (save-excursion - (while msgs - (if (mh-goto-msg (car msgs) t t) - (mh-delete-line 1)) - (setq msgs (cdr msgs))))) - - -(defun mh-outstanding-commands-p () - ;; Returns 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 (eql (car msgs) (1- prev)))) - (progn ;non-sequential, flush old range - (if (eql 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) - ;; Sort two message indicators. 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)))) - - - -;;; Basic sequence handling - -(defun mh-delete-seq-locally (seq) - ;; Remove mh-e's record of SEQUENCE. - (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 the current 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 SEQUENCE 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 SEQUENCE to contain the list of MSGS. - ;; Do not mark pseudo-sequences or empty sequences. - ;; Signals an error if SEQUENCE 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 (func seq-list) - ;; Apply the FUNCTION to each element in the list of SEQUENCES, - ;; passing the sequence name and the list of messages as arguments. - (while seq-list - (funcall func (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 notation offset seq) - ;; If the MESSAGE is in only the SEQUENCE, then mark the scan listing of the - ;; message with the CHARACTER at the given OFFSET from the beginning of the - ;; listing line. - (let ((in-seqs (mh-seq-containing-msg msg nil))) - (if (and (eq seq (car in-seqs)) (null (cdr in-seqs))) - (mh-notate msg notation offset)))) - - -(defun mh-seq-containing-msg (msg &optional include-internal-p) - ;; Return a list of the sequences containing MESSAGE. - ;; If INCLUDE-INTERNAL-P 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-p - (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 (prompt) - ;; Read a list of blank-separated items. - (let* ((buf (read-string prompt)) - (buf-size (length buf)) - (start 0) - (input ())) - (while (< start buf-size) - (let ((next (read-from-string buf start buf-size))) - (setq input (cons (car next) input)) - (setq start (cdr next)))) - (nreverse input))) - - - -;;; Build the folder-mode keymap: - -(suppress-keymap mh-folder-mode-map) -(define-key mh-folder-mode-map "q" 'mh-quit) -(define-key mh-folder-mode-map "b" 'mh-compat-quit) -(define-key mh-folder-mode-map "?" 'mh-msg-is-in-seq) -(define-key mh-folder-mode-map "%" 'mh-put-msg-in-seq) -(define-key mh-folder-mode-map "|" 'mh-pipe-msg) -(define-key mh-folder-mode-map "\ea" 'mh-edit-again) -(define-key mh-folder-mode-map "\e%" 'mh-delete-msg-from-seq) -(define-key mh-folder-mode-map "\e#" 'mh-delete-seq) -(define-key mh-folder-mode-map "\C-xn" 'mh-narrow-to-seq) -(define-key mh-folder-mode-map "\C-xw" 'mh-widen) -(define-key mh-folder-mode-map "\eb" 'mh-burst-digest) -(define-key mh-folder-mode-map "\eu" 'mh-undo-folder) -(define-key mh-folder-mode-map "\e " 'mh-page-digest) -(define-key mh-folder-mode-map "\e\177" 'mh-page-digest-backwards) -(define-key mh-folder-mode-map "\ed" 'mh-redistribute) -(define-key mh-folder-mode-map "\ee" 'mh-extract-rejected-mail) -(define-key mh-folder-mode-map "\ef" 'mh-visit-folder) -(define-key mh-folder-mode-map "\ek" 'mh-kill-folder) -(define-key mh-folder-mode-map "\el" 'mh-list-folders) -(define-key mh-folder-mode-map "\en" 'mh-store-msg) -(define-key mh-folder-mode-map "\ep" 'mh-pack-folder) -(define-key mh-folder-mode-map "\eq" 'mh-list-sequences) -(define-key mh-folder-mode-map "\es" 'mh-search-folder) -(define-key mh-folder-mode-map "\er" 'mh-rescan-folder) -(define-key mh-folder-mode-map "l" 'mh-print-msg) -(define-key mh-folder-mode-map "t" 'mh-toggle-showing) -(define-key mh-folder-mode-map "c" 'mh-copy-msg) -(define-key mh-folder-mode-map "i" 'mh-inc-folder) -(define-key mh-folder-mode-map "x" 'mh-execute-commands) -(define-key mh-folder-mode-map "e" 'mh-execute-commands) -(define-key mh-folder-mode-map "f" 'mh-forward) -(define-key mh-folder-mode-map "m" 'mh-send) -(define-key mh-folder-mode-map "s" 'mh-send) -(define-key mh-folder-mode-map "r" 'mh-reply) -(define-key mh-folder-mode-map "a" 'mh-reply) -(define-key mh-folder-mode-map "j" 'mh-goto-msg) -(define-key mh-folder-mode-map "g" 'mh-goto-msg) -(define-key mh-folder-mode-map "\e<" 'mh-first-msg) -(define-key mh-folder-mode-map "\e>" 'mh-last-msg) -(define-key mh-folder-mode-map "\177" 'mh-previous-page) -(define-key mh-folder-mode-map " " 'mh-page-msg) -(define-key mh-folder-mode-map "\r" 'mh-show) -(define-key mh-folder-mode-map "." 'mh-show) -(define-key mh-folder-mode-map "," 'mh-header-display) -(define-key mh-folder-mode-map "u" 'mh-undo) -(define-key mh-folder-mode-map "d" 'mh-delete-msg) -(define-key mh-folder-mode-map "\C-d" 'mh-delete-msg-no-motion) -(define-key mh-folder-mode-map "p" 'mh-previous-undeleted-msg) -(define-key mh-folder-mode-map "n" 'mh-next-undeleted-msg) -(define-key mh-folder-mode-map "o" 'mh-refile-msg) -(define-key mh-folder-mode-map "^" 'mh-refile-msg) -(define-key mh-folder-mode-map "\C-o" 'mh-write-msg-to-file) -(define-key mh-folder-mode-map ">" 'mh-write-msg-to-file) -(define-key mh-folder-mode-map "!" 'mh-refile-or-write-again) - -;; "C-c /" prefix is used in mh-folder-mode by pgp.el and mailcrypt - - - -;;;autoload the other mh-e parts - -;;; mh-comp - -(autoload 'mh-smail "mh-comp" - "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." t) - -(autoload 'mh-smail-other-window "mh-comp" - "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." t) - -(autoload 'mh-edit-again "mh-comp" - "Clean-up a draft or a message 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) - -(autoload 'mh-extract-rejected-mail "mh-comp" - "Extract a letter 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) - -(autoload 'mh-forward "mh-comp" - "Forward a message or message sequence. Defaults to displayed message. -If optional prefix argument provided, then prompt for the message sequence. -See also documentation for `\\[mh-send]' function." t) - -(autoload 'mh-redistribute "mh-comp" - "Redistribute a letter. -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) - -(autoload 'mh-reply "mh-comp" - "Reply to a MESSAGE (default: displayed message). -If optional prefix argument INCLUDEP provided, then include the message -in the reply using filter mhl.reply in your MH directory. -Prompts for type of addresses to reply to: - from sender only, - to sender and primary recipients, - cc/all sender and all recipients. -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) - -(autoload 'mh-send "mh-comp" - "Compose and send a letter. -The file named by `mh-comp-formfile' will be used as the form. -Do not call this function from outside mh-e; use \\[mh-smail] instead. -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, subject, and cc." t) - -(autoload '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. -See also documentation for `\\[mh-send]' function." t) - -(autoload 'mh-letter-mode "mh-comp" - "Mode for composing letters in mh-e. -For more details, type \\[describe-mode] while in MH-Letter mode." t) - - -;;; mh-funcs - -(autoload '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) - -(autoload 'mh-copy-msg "mh-funcs" - "Copy to another FOLDER the specified MESSAGE(s) without deleting them. -Default is the displayed message. If optional prefix argument is -provided, then prompt for the message sequence." t) - -(autoload 'mh-kill-folder "mh-funcs" - "Remove the current folder." t) - -(autoload 'mh-list-folders "mh-funcs" - "List mail folders." t) - -(autoload '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) - -(autoload '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) - -(autoload 'mh-page-digest "mh-funcs" - "Advance displayed message to next digested message." t) - -(autoload 'mh-page-digest-backwards "mh-funcs" - "Back up displayed message to previous digested message." t) - -(autoload 'mh-print-msg "mh-funcs" - "Print MESSAGE(s) (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) - -(autoload '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 this function is passed an argument." t) - -(autoload 'mh-undo-folder "mh-funcs" - "Undo all commands in current folder." t) - -(autoload '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) - -(autoload '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) - - -;;; mh-pick - -(autoload 'mh-search-folder "mh-pick" - "Search FOLDER for messages matching a pattern. -Add the messages found to the sequence named `search'." t) - -;;; mh-seq - -(autoload 'mh-delete-seq "mh-seq" - "Delete the SEQUENCE." t) -(autoload 'mh-list-sequences "mh-seq" - "List the sequences defined in FOLDER." t) -(autoload 'mh-msg-is-in-seq "mh-seq" - "Display the sequences that contain MESSAGE (default: displayed message)." t) -(autoload 'mh-narrow-to-seq "mh-seq" - "Restrict display of this folder to just messages in SEQUENCE -Use \\[mh-widen] to undo this command." t) -(autoload 'mh-put-msg-in-seq "mh-seq" - "Add MESSAGE(s) (default: displayed message) to SEQUENCE. -If optional prefix argument provided, then prompt for the message sequence." t) -(autoload 'mh-widen "mh-seq" - "Remove restrictions from current folder, thereby showing all messages." t) -(autoload 'mh-rename-seq "mh-seq" - "Rename SEQUENCE to have NEW-NAME." t) - -;;; mh-e.el ends here diff --git a/lisp/mail/mh-funcs.el b/lisp/mail/mh-funcs.el deleted file mode 100644 index cc1ce6aec1b..00000000000 --- a/lisp/mail/mh-funcs.el +++ /dev/null @@ -1,354 +0,0 @@ -;;; mh-funcs --- mh-e functions not everyone will use right away -;; Time-stamp: <95/08/19 16:44:06 gildea> - -;; Copyright (C) 1993, 1995 Free Software Foundation, Inc. - -;; This file is part of mh-e, 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.4 1995/11/03 02:29:34 kwzh Exp erik $ - -;;; Code: - -(provide 'mh-funcs) -(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 - -(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"))) - - -(defun mh-copy-msg (msg-or-seq folder) - "Copy the specified MESSAGE(s) 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 (if current-prefix-arg - (mh-read-seq-default "Copy" t) - (mh-get-msg-num t)) - (mh-prompt-for-folder "Copy to" "" t))) - (mh-exec-cmd "refile" 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))) - -(defun mh-kill-folder () - "Remove the current folder." - (interactive) - (if (or mh-do-not-confirm - (yes-or-no-p (format "Remove folder %s? " 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)) - (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)) - (kill-buffer folder)) - (message "Folder not removed"))) - - -(defun mh-list-folders () - "List mail folders." - (interactive) - (with-output-to-temp-buffer mh-temp-buffer - (save-excursion - (switch-to-buffer mh-temp-buffer) - (erase-buffer) - (message "Listing folders...") - (mh-exec-cmd-output "folders" t (if mh-recursive-folders - "-recurse" - "-norecurse")) - (goto-char (point-min)) - (message "Listing folders...done")))) - - -(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 - "Range to scan after packing [all]? ") - "all"))) - (mh-pack-folder-1 range) - (mh-goto-cur-msg) - (message "Packing folder...done")) - - -(defun mh-pack-folder-1 (range) - ;; Close and pack the current 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-regenerate-headers range)) - - -(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))))) - - -(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))) - - -(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))) - - -(defun mh-print-msg (msg-or-seq) - "Print MESSAGE(s) (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) - (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) - (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 - (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 " ")) - - -(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 this function is passed an argument." - (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...") - (mh-exec-cmd "sortm" mh-current-folder (if extra-args mh-sortm-args)) - (message "Sorting folder...done") - (mh-scan-folder mh-current-folder "all")) - - -(defun mh-undo-folder (&rest ignore) - "Undo all pending deletes and refiles in current folder." - (interactive) - (cond ((or mh-do-not-confirm - (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)))) - - -(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)))) - -(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"))) - diff --git a/lisp/mail/mh-mime.el b/lisp/mail/mh-mime.el deleted file mode 100644 index dcb12b5588b..00000000000 --- a/lisp/mail/mh-mime.el +++ /dev/null @@ -1,236 +0,0 @@ -;;; mh-mime --- mh-e support for composing MIME messages -;; Time-stamp: <95/08/19 16:45:17 gildea> - -;; Copyright (C) 1993, 1995 Free Software Foundation, Inc. - -;; This file is part of mh-e, 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.5 1995/11/03 02:29:49 kwzh Exp erik $ - -;;; Code: - -(provide 'mh-mime) -(require 'mh-comp) - - -;; 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-edit-mhn-hook nil - "Invoked on the formatted letter by \\<mh-letter-mode-map>\\[mh-edit-mhn].") - -;;;###autoload -(defvar mh-mime-content-types - '(("text/plain") ("text/richtext") - ("multipart/mixed") ("multipart/alternative") ("multipart/digest") - ("multipart/parallel") - ("message/rfc822") ("message/partial") ("message/external-body") - ("application/octet-stream") ("application/postscript") - ("image/jpeg") ("image/gif") - ("audio/basic") - ("video/mpeg")) - "Legal MIME content types. See documentation for \\[mh-edit-mhn].") - -(defun mh-mhn-compose-insertion (pathname type description) - "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 PATHNAME, which tells 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-file-name "Insert contents of: ") - (completing-read "Content-type: " - mh-mime-content-types nil nil nil) - (read-string "Content-description: "))) - (mh-mhn-compose-type pathname type description)) - -(defun mh-mhn-compose-type (pathname type - &optional description attributes comment) - (beginning-of-line) - (insert "#" type) - (and attributes - (insert "; " attributes)) - (and comment - (insert " (" comment ")")) - (insert " [") - (and description - (insert description)) - (insert "] " (expand-file-name pathname)) - (insert "\n")) - - -(defun mh-mhn-compose-anon-ftp (host pathname 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 PATHNAME, 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 pathname: ") - (completing-read "External Content-type: " - mh-mime-content-types nil nil nil) - (read-string "External Content-description: "))) - (mh-mhn-compose-external-type "anon-ftp" host pathname - type description)) - -(defun mh-mhn-compose-external-compressed-tar (host pathname 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 PATHNAME, 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 pathname: ") - (read-string "Tar file Content-description: "))) - (mh-mhn-compose-external-type "anon-ftp" host pathname - "application/octet-stream" - description - "type=tar; conversions=x-compress" - "mode=image")) - - -(defun mh-mhn-compose-external-type (access-type host pathname type - &optional description - attributes extra-params comment) - (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 pathname)) - (insert "; directory=\"" (file-name-directory pathname) "\"") - (and extra-params - (insert "; " extra-params)) - (insert "\n")) - -(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) - ""))))) - (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")) - -(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 mhn program is part of MH version 6.8 or later. -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 argument. - -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)." - (interactive "*P") - (save-buffer) - (message "mhn editing...") - (mh-exec-cmd-error (format "mhdraft=%s" buffer-file-name) - "mhn" (if extra-args mh-mhn-args) buffer-file-name) - (revert-buffer t t) - (message "mhn editing...done") - (run-hooks 'mh-edit-mhn-hook)) - - -(defun mh-revert-mhn-edit (noconfirm) - "Undoes the effect of \\[mh-edit-mhn] by reverting to the backup file. -Optional non-nil argument 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 "mhn 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 "mhn edit revert not confirmed.")) - (let ((buffer-read-only nil)) - (erase-buffer) - (insert-file-contents backup-file)) - (after-find-file nil))) diff --git a/lisp/mail/mh-pick.el b/lisp/mail/mh-pick.el deleted file mode 100644 index a297d5e6f5c..00000000000 --- a/lisp/mail/mh-pick.el +++ /dev/null @@ -1,195 +0,0 @@ -;;; mh-pick --- make a search pattern and search for a message in mh-e -;; Time-stamp: <95/08/19 16:45:16 gildea> - -;; Copyright (C) 1993, 1995 Free Software Foundation, Inc. - -;; This file is part of mh-e, 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.4 1995/11/03 02:30:09 kwzh Exp erik $ - -;;; Code: - -(provide 'mh-pick) -(require 'mh-e) - -(defvar mh-pick-mode-hook nil - "Invoked in `mh-pick-mode' on a new pattern.") - -;;; Internal variables: - -(defvar mh-pick-mode-map (make-sparse-keymap) - "Keymap for searching folder.") - -(defvar mh-searching-folder nil) ;Folder this pick is searching. - -(defun mh-search-folder (folder) - "Search FOLDER for messages matching a pattern. -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)) - -(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)) - -(put 'mh-pick-mode 'mode-class 'special) - -(defun mh-pick-mode () - "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. -\\{mh-pick-mode-map} -Turning on mh-pick-mode calls the value of the variable mh-pick-mode-hook -if that value is non-nil." - (interactive) - (kill-all-local-variables) - (make-local-variable 'mh-searching-folder) - (use-local-map mh-pick-mode-map) - (setq major-mode 'mh-pick-mode) - (mh-set-mode-name "MH-Pick") - (run-hooks 'mh-pick-mode-hook)) - - -(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 - (finding-messages t) - (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 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 seq-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 that can be extracted from the - ;; 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: - -(define-key mh-pick-mode-map "\C-c\C-c" 'mh-do-pick-search) -(define-key mh-pick-mode-map "\C-c\C-f\C-b" 'mh-to-field) -(define-key mh-pick-mode-map "\C-c\C-f\C-c" 'mh-to-field) -(define-key mh-pick-mode-map "\C-c\C-f\C-d" 'mh-to-field) -(define-key mh-pick-mode-map "\C-c\C-f\C-f" 'mh-to-field) -(define-key mh-pick-mode-map "\C-c\C-f\C-r" 'mh-to-field) -(define-key mh-pick-mode-map "\C-c\C-f\C-s" 'mh-to-field) -(define-key mh-pick-mode-map "\C-c\C-f\C-t" 'mh-to-field) -(define-key mh-pick-mode-map "\C-c\C-fb" 'mh-to-field) -(define-key mh-pick-mode-map "\C-c\C-fc" 'mh-to-field) -(define-key mh-pick-mode-map "\C-c\C-fd" 'mh-to-field) -(define-key mh-pick-mode-map "\C-c\C-ff" 'mh-to-field) -(define-key mh-pick-mode-map "\C-c\C-fr" 'mh-to-field) -(define-key mh-pick-mode-map "\C-c\C-fs" 'mh-to-field) -(define-key mh-pick-mode-map "\C-c\C-ft" 'mh-to-field) diff --git a/lisp/mail/mh-seq.el b/lisp/mail/mh-seq.el deleted file mode 100644 index 59db6ee8f19..00000000000 --- a/lisp/mail/mh-seq.el +++ /dev/null @@ -1,237 +0,0 @@ -;;; mh-seq --- mh-e sequences support -;; Time-stamp: <95/08/19 16:45:15 gildea> - -;; Copyright (C) 1993, 1995 Free Software Foundation, Inc. - -;; This file is part of mh-e, 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-seq.el,v 1.5 1996/01/14 07:34:30 erik Exp kwzh $ - -;;; Code: - -(provide 'mh-seq) -(require 'mh-e) - -;;; 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. - - -(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)) - - -(defun mh-list-sequences (folder) - "List the sequences defined in FOLDER." - (interactive (list (mh-prompt-for-folder "List sequences in" - mh-current-folder t))) - (let ((temp-buffer mh-temp-buffer) - (seq-list mh-seq-list)) - (with-output-to-temp-buffer temp-buffer - (save-excursion - (set-buffer temp-buffer) - (erase-buffer) - (message "Listing sequences ...") - (insert "Sequences in folder " folder ":\n") - (while seq-list - (let ((name (mh-seq-name (car seq-list))) - (sorted-seq-msgs - (sort (copy-sequence (mh-seq-msgs (car seq-list))) '<)) - (last-col (- (window-width) 4)) - name-spec) - (insert (setq name-spec (format "%20s:" name))) - (while sorted-seq-msgs - (if (> (current-column) last-col) - (progn - (insert "\n") - (move-to-column (length name-spec)))) - (insert (format " %s" (car sorted-seq-msgs))) - (setq sorted-seq-msgs (cdr sorted-seq-msgs))) - (insert "\n")) - (setq seq-list (cdr seq-list))) - (goto-char (point-min)) - (message "Listing sequences...done"))))) - - -(defun mh-msg-is-in-seq (message) - "Display the sequences that contain MESSAGE (default: current message)." - (interactive (list (mh-get-msg-num t))) - (message "Message %d is in sequences: %s" - message - (mapconcat 'concat - (mh-list-to-string (mh-seq-containing-msg message t)) - " "))) - - -(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) - (let ((eob (point-max))) - (mh-copy-seq-to-point sequence eob) - (narrow-to-region eob (point-max)) - (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) - (setq mh-narrowed-to-seq sequence))) - (t - (error "No messages in sequence `%s'" (symbol-name sequence)))))) - - -(defun mh-put-msg-in-seq (msg-or-seq sequence) - "Add MESSAGE(s) (default: displayed message) to SEQUENCE. -If optional prefix argument provided, then prompt for the message sequence." - (interactive (list (if current-prefix-arg - (mh-read-seq-default "Add messages from" 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 (if (numberp msg-or-seq) - msg-or-seq - (mh-seq-to-msgs msg-or-seq)) - sequence)) - - -(defun mh-widen () - "Remove restrictions from current folder, thereby showing all messages." - (interactive) - (if mh-narrowed-to-seq - (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))) - (setq mh-narrowed-to-seq nil)) - - - -;;; 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. - (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 SEQUENCES. - (mapcar (function (lambda (entry) (list (symbol-name (mh-seq-name entry))))) - seq-list)) - - -(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))) - - -(defun mh-map-to-seq-msgs (func seq &rest args) - ;; Invoke the FUNCTION at each message in the SEQUENCE, passing the - ;; remaining ARGS as arguments. - (save-excursion - (let ((msgs (mh-seq-to-msgs seq))) - (while msgs - (if (mh-goto-msg (car msgs) t t) - (apply func (car msgs) args)) - (setq msgs (cdr msgs)))))) - - -(defun mh-notate-seq (seq notation offset) - ;; Mark the scan listing of all messages in the SEQUENCE with the CHARACTER - ;; at the given OFFSET from the beginning of the listing line. - (mh-map-to-seq-msgs 'mh-notate seq notation offset)) - - -(defun mh-add-to-sequence (seq 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))))) - - -(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-line-to-point (msg location) - ;; 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)))) - diff --git a/lisp/mail/mh-utils.el b/lisp/mail/mh-utils.el deleted file mode 100644 index d2505918c86..00000000000 --- a/lisp/mail/mh-utils.el +++ /dev/null @@ -1,953 +0,0 @@ -;;; mh-utils.el --- mh-e code needed for both sending and reading -;; Time-stamp: <95/10/22 17:58:16 gildea> - -;; Copyright (C) 1993, 1995 Free Software Foundation, Inc. - -;; This file is part of mh-e, 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.9 1996/01/29 23:17:16 kwzh Exp rms $ - -;;; Code: - -;;; 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 mhl program and the components file.") - -;;;###autoload -(put 'mh-progs 'risky-local-variable t) -;;;###autoload -(put 'mh-lib 'risky-local-variable t) - -;;; User preferences: - -(defvar mh-auto-folder-collect t - "*Whether to start collecting MH folder names immediately in the background. -Non-nil means start a background process collecting the names of all -folders as soon as mh-e is loaded.") - -(defvar mh-recursive-folders nil - "*If non-nil, then commands which operate on folders do so recursively.") - -(defvar mh-clean-message-header nil - "*Non-nil means clean headers of messages that are displayed or inserted. -The variables `mh-visible-headers' and `mh-invisible-headers' control what -is removed.") - -(defvar mh-visible-headers nil - "*If non-nil, contains a regexp specifying the headers to keep when cleaning. -Only used if `mh-clean-message-header' is non-nil. Setting this variable -overrides `mh-invisible-headers'.") - -(defvar mh-invisible-headers - "^Received: \\|^Message-Id: \\|^Remailed-\\|^Via: \\|^Mail-from: \\|^Return-Path: \\|^Delivery-Date: \\|^In-Reply-To: \\|^Resent-" - "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.") - -(defvar mh-bury-show-buffer t - "*Non-nil means that the displayed show buffer for a folder is buried.") - -(defvar mh-summary-height 4 - "*Number of lines in MH-Folder window (including the mode line).") - -(defvar mh-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-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 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.") -(put 'mhl-formfile 'info-file "mh-e") - -(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-find-path-hook nil - "Invoked by mh-find-path while reading the user's MH profile.") - -(defvar mh-folder-list-change-hook nil - "Invoked whenever the cached folder list `mh-folder-list' is changed.") - -(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 - "Offset to insert notation.") - -(defvar mh-note-seq "%" - "String whose first character is used to notate messages in a sequence.") - -;;; Internal bookkeeping variables: - -;; The value of `mh-folder-list-change-hook' is called whenever -;; mh-folder-list variable is set. -(defvar mh-folder-list nil) ;List of folder names for completion. - -;; Cached value of the `Path:' component in the user's MH profile. -(defvar mh-user-path nil) ;User's mail folder directory. - -;; 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. -(defvar mh-draft-folder nil) ;Name of folder containing draft messages. - -;; Cached value of the `Unseen-Sequence:' component in the user's MH profile. -(defvar mh-unseen-seq nil) ;Name of the Unseen sequence. - -;; Cached value of the `Previous-Sequence:' component in the user's MH profile. -(defvar mh-previous-seq nil) ;Name of the Previous sequence. - -;; Cached value of the `Inbox:' component in the user's MH profile, -;; or "+inbox" if no such component. -(defvar mh-inbox nil) ;Name of the Inbox folder. - -(defconst mh-temp-buffer " *mh-temp*") ;Name of mh-e scratch buffer. - -(defvar mh-previous-window-config nil) ;Window configuration before mh-e command. - -;;; Internal variables local to a folder. - -(defvar mh-current-folder nil) ;Name of current folder, a string. - -(defvar mh-show-buffer nil) ;Buffer that displays message for this folder. - -(defvar mh-folder-filename nil) ;Full path of directory for this folder. - -(defvar mh-msg-count nil) ;Number of msgs in buffer. - -(defvar mh-showing nil) ;If non-nil, show the message in a separate window. - -;;; This holds a documentation string used by describe-mode. -(defun mh-showing () - "When moving to a new message in the Folder window, -also show it in a separate Show window." - nil) - -(defvar mh-seq-list nil) ;The sequences of this folder. An alist of (seq . msgs). - -(defvar mh-seen-list nil) ;List of displayed messages to be removed from the Unseen sequence. - -;; If non-nil, show buffer contains message with all headers. -;; If nil, show buffer contains message processed normally. -(defvar mh-showing-with-headers nil) ;Showing message with headers or normally. - - -;;; mh-e macros - -(defmacro with-mh-folder-updating (save-modification-flag-p &rest body) - ;; Format is (with-mh-folder-updating (SAVE-MODIFICATION-FLAG-P) &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-P is non-nil, the buffer's modification - ;; flag is unchanged, otherwise it is cleared. - (setq save-modification-flag-p (car save-modification-flag-p)) ; 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-p) - '((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 (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) (list 'cons name msgs)) - -(defmacro mh-seq-name (pair) (list 'car pair)) - -(defmacro mh-seq-msgs (pair) (list 'cdr pair)) - - -;;; Ensure new buffers won't get this mode if default-major-mode is nil. -(put 'mh-show-mode 'mode-class 'special) - -(defun mh-show-mode () - "Major mode for showing messages in mh-e. -The value of mh-show-mode-hook is called when a new message is displayed." - (kill-all-local-variables) - (setq major-mode 'mh-show-mode) - (mh-set-mode-name "MH-Show") - (run-hooks 'mh-show-mode-hook)) - - -(defun mh-maybe-show (&optional msg) - ;; If in showing mode, then display the message pointed to by the cursor. - (if mh-showing (mh-show msg))) - -(defun mh-show (&optional message) - "Show MESSAGE (default: message at cursor). -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' 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) - (mh-invalidate-show-buffer)) - (mh-show-msg message)) - - -(defun mh-show-msg (msg) - (if (not msg) - (setq msg (mh-get-msg-num t))) - (setq mh-showing t) - (let ((folder mh-current-folder) - (clean-message-header mh-clean-message-header) - (show-window (get-buffer-window mh-show-buffer))) - (if (not (eql (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)) (screen-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))) - (run-hooks 'mh-show-hook)) - - -(defun mh-display-msg (msg-num folder) - ;; Display message NUMBER of FOLDER. - ;; Sets the current buffer to the show buffer. - (set-buffer folder) - ;; Bind variables in folder buffer in case they are local - (let ((formfile mhl-formfile) - (clean-message-header mh-clean-message-header) - (invisible-headers mh-invisible-headers) - (visible-headers mh-visible-headers) - (msg-filename (mh-msg-filename msg-num)) - (show-buffer mh-show-buffer)) - (if (not (file-exists-p msg-filename)) - (error "Message %d does not exist" msg-num)) - (set-buffer show-buffer) - (cond ((not (equal msg-filename buffer-file-name)) - (mh-unvisit-file) - (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)) - (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-modified-p 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) - (setq mode-line-buffer-identification - (list (format mh-show-buffer-mode-line-buffer-id - folder msg-num))) - (set-buffer folder) - (setq mh-showing-with-headers nil))))) - -(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)) - - -(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-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-msg-filename (msg &optional folder) - ;; Return the file name of MESSAGE in FOLDER (default current folder). - (expand-file-name (int-to-string msg) - (if folder - (mh-expand-file-name folder) - mh-folder-filename))) - - -(defun mh-clean-msg-header (start invisible-headers visible-headers) - ;; Flush extraneous lines in a message header, from the given POINT to the - ;; end of the message header. If VISIBLE-HEADERS is non-nil, it contains a - ;; regular expression specifying the lines to display, otherwise - ;; INVISIBLE-HEADERS contains a regular expression specifying lines to - ;; delete from the header. - (let ((case-fold-search t)) - (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-recenter (arg) - ;; Like recenter but with two improvements: nil arg means recenter, - ;; and only does anything if the current buffer is in the selected - ;; window. (Commands like save-some-buffers can make this false.) - (if (eql (get-buffer-window (current-buffer)) - (selected-window)) - (recenter (if arg arg '(t))))) - - -(defun mh-delete-line (lines) - ;; Delete version of kill-line. - (delete-region (point) (progn (forward-line lines) (point)))) - - -(defun mh-notate (msg notation offset) - ;; Marks MESSAGE with the character NOTATION at position OFFSET. - ;; Null MESSAGE means the message that the cursor points to. - (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 on the current scan line - ;; or one nearby. Jumps over non-message lines, such as inc errors. - ;; STEP tells whether to search forward or backward if we have to search. - (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 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 means not to show the message." - (interactive "NGo to message: ") - (setq number (prefix-numeric-value number)) ;Emacs 19 - ;; This basic routine tries to be as fast as possible, - ;; using a binary search and minimal regexps. - (let ((cur-msg (mh-find-msg-get-num -1)) - (jump-size mh-msg-count)) - (while (and (> jump-size 1) - cur-msg - (not (eq cur-msg number))) - (cond ((< cur-msg number) - (setq jump-size (min (- number cur-msg) - (ash (1+ jump-size) -1))) - (forward-line jump-size) - (setq cur-msg (mh-find-msg-get-num 1))) - (t - (setq jump-size (min (- cur-msg number) - (ash (1+ jump-size) -1))) - (forward-line (- jump-size)) - (setq cur-msg (mh-find-msg-get-num -1))))) - (if (eq cur-msg number) - (progn - (beginning-of-line) - (or dont-show - (mh-maybe-show number) - t)) - (if (not no-error-if-no-message) - (error "No message %d" number))))) - - -(defun mh-msg-search-pat (n) - ;; Return a search pattern for message N in the scan listing. - (format mh-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 'mh-e-user-agent) ;from reporter.el 3.2 - -(defun mh-find-path () - ;; Set mh-progs and mh-lib. - ;; (This step is necessary if MH was installed after this Emacs was dumped.) - ;; From profile file, set mh-user-path, mh-draft-folder, - ;; mh-unseen-seq, mh-previous-seq, mh-inbox. - (mh-find-progs) - (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))) - (setq mail-user-agent 'mh-e-user-agent) - (run-hooks 'mh-find-path-hook)))) - -(defun mh-find-progs () - (or (file-exists-p (expand-file-name "inc" mh-progs)) - (setq mh-progs - (or (mh-path-search exec-path "inc") - (mh-path-search '("/usr/local/bin/mh/" - "/usr/local/mh/" - "/usr/bin/mh/" ;Ultrix 4.2 - "/usr/new/mh/" ;Ultrix <4.2 - "/usr/contrib/mh/bin/" ;BSDI - "/usr/local/bin/" - ) - "inc") - mh-progs - "/usr/local/bin/"))) - (or (file-exists-p (expand-file-name "mhl" mh-lib)) - (setq mh-lib - (or (mh-path-search '("/usr/local/lib/mh/" - "/usr/local/mh/lib/" - "/usr/local/bin/mh/" - "/usr/lib/mh/" ;Ultrix 4.2 - "/usr/new/lib/mh/" ;Ultrix <4.2 - "/usr/contrib/mh/lib/" ;BSDI - ) - "mhl") - (mh-path-search exec-path "mhl") ;unlikely - mh-lib - "/usr/local/lib/mh/")))) - -(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 (file-exists-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) - ;; Called to do error recovery if we fail to read the profile file. - ;; If possible, initialize the MH environment. - (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) "-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) (assoc name mh-seq-list)) - -(defun mh-seq-to-msgs (seq) - ;; Return a list of the messages in SEQUENCE. - (mh-seq-msgs (mh-find-seq seq))) - - -(defun mh-add-msgs-to-seq (msgs seq &optional internal-flag) - ;; Add MESSAGE(s) to the SEQUENCE. If optional 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 msgs) mh-seq-list)) - (if msgs (setcdr entry (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)))))) - -(autoload 'mh-add-to-sequence "mh-seq") -(autoload 'mh-notate-seq "mh-seq") -(autoload 'mh-read-seq-default "mh-seq") -(autoload 'mh-map-to-seq-msgs "mh-seq") - - -(defun mh-set-mode-name (mode-name-string) - ;; Set the mode-name and ensure that the mode line is updated. - (setq mode-name mode-name-string) - (force-mode-line-update t)) - - -(defun mh-prompt-for-folder (prompt default can-create) - ;; 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 non-existent folder is made. - (if (null default) - (setq default "")) - (let* ((prompt (format "%s folder%s" prompt - (if (equal "" default) - "? " - (format " [%s]? " default)))) - 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 "+")) - (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)))) - (setq folder-name read-name) - (cond ((and (> (length folder-name) 0) - (eql (aref folder-name (1- (length folder-name))) ?/)) - (setq folder-name (substring folder-name 0 -1)))) - (let ((new-file-p (not (file-exists-p (mh-expand-file-name folder-name))))) - (cond ((and new-file-p - (y-or-n-p - (format "Folder %s does not exist. Create it? " folder-name))) - (message "Creating %s" folder-name) - (call-process "mkdir" nil nil nil (mh-expand-file-name 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-p - (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 () - ;; Sets 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. - (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) - (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 - "-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) - ;; parse output from "folders -fast" - (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))) - (store-match-data prevailing-match-data)) - (setq mh-folder-list-partial-line (substring output position)))) - - -(defun mh-folder-name-p (name) - ;; Return non-NIL if NAME is possibly the name of a folder. - ;; A name (a string or symbol) can be a folder name if it begins with "+". - (if (symbolp name) - (eql (aref (symbol-name name) 0) ?+) - (and (> (length name) 0) - (eql (aref name 0) ?+)))) - - -;;; 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 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) - ;; Args are RAISE-ERROR, COMMANDS, ARGS.... - ;; 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-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)) - (exchange-point-and-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) nil args)) - - -(defun mh-handle-process-error (command status) - ;; Raise error if COMMAND returned non-0 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 ((eql 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) (screen-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-expand-file-name (filename &optional default) - ;; Just like `expand-file-name', but also handles MH folder names. - ;; Assumes that any filename that starts with '+' is a folder name. - (if (mh-folder-name-p filename) - (expand-file-name (substring filename 1) mh-user-path) - (expand-file-name filename default))) - - -(defun mh-list-to-string (l) - ;; Flattens the list L and makes every element of the new list into a string. - (nreverse (mh-list-to-string-1 l))) - -(defun mh-list-to-string-1 (l) - (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) - -(and (not noninteractive) - mh-auto-folder-collect - (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 - -;;; mh-utils.el ends here diff --git a/lisp/mail/reporter.el b/lisp/mail/reporter.el deleted file mode 100644 index 76d7108d1a0..00000000000 --- a/lisp/mail/reporter.el +++ /dev/null @@ -1,437 +0,0 @@ -;;; reporter.el --- customizable bug reporting of lisp programs - -;; Copyright (C) 1993 1994 1995 1996 Free Software Foundation, Inc. - -;; Author: 1993-1996 Barry A. Warsaw -;; Created: 19-Apr-1993 -;; Version: 3.3 -;; Last Modified: 1996/07/02 00:39:09 -;; Keywords: maint mail tools - -;; 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: - -;; End User Interface -;; ================== -;; The variable `mail-user-agent' contains a symbol indicating which -;; Emacs mail package end users would like to use to compose outgoing -;; mail. See that variable for details. - -;; Lisp Package Authors -;; ==================== -;; Reporter was written primarily for Emacs Lisp package authors so -;; that their users can easily report bugs. When invoked, -;; reporter-submit-bug-report will set up an outgoing mail buffer with -;; the appropriate bug report address, including a lisp expression the -;; maintainer of the package can eval to completely reproduce the -;; environment in which the bug was observed (e.g. by using -;; eval-last-sexp). This package proved especially useful during my -;; development of cc-mode, which is highly dependent on its -;; configuration variables. -;; -;; Do a "C-h f reporter-submit-bug-report" for more information. -;; Here's an example usage: -;; -;;(defconst mypkg-version "9.801") -;;(defconst mypkg-maintainer-address "mypkg-help@foo.com") -;;(defun mypkg-submit-bug-report () -;; "Submit via mail a bug report on mypkg" -;; (interactive) -;; (reporter-submit-bug-report -;; mypkg-maintainer-address -;; (concat "mypkg.el " mypkg-version) -;; (list 'mypkg-variable-1 -;; 'mypkg-variable-2 -;; ;; ... -;; 'mypkg-variable-last))) - -;; Mailing List -;; ============ -;; I've set up a Majordomo mailing list to report bugs or suggest -;; enhancements, etc. This list's intended audience is elisp package -;; authors who are using reporter and want to stay current with -;; releases. Here are the relevant addresses: -;; -;; Administrivia: reporter-request@python.org -;; Submissions: reporter@python.org - -;; Packages that currently use reporter are: cc-mode, supercite, elp, -;; tcl, ediff, crypt++ (crypt), dired-x, rmailgen, mode-line, vm, -;; mh-e, edebug, archie, viper, w3-mode, framepop, hl319, hilit19, -;; pgp, eos, hm--html, efs. -;; -;; If you know of others, please email me! - -;;; Code: - -;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv -;; Package author interface variables - -(defvar reporter-prompt-for-summary-p nil - "Interface variable controlling prompting for problem summary. -When non-nil, `reporter-submit-bug-report' prompts the user for a -brief summary of the problem, and puts this summary on the Subject: -line. If this variable is a string, that string is used as the prompt -string. - -Default behavior is to not prompt (i.e. nil). If you want reporter to -prompt, you should `let' bind this variable before calling -`reporter-submit-bug-report'. Note that this variable is not -buffer-local so you should never just `setq' it.") - -(defvar reporter-dont-compact-list nil - "Interface variable controlling compacting of list values. -When non-nil, this must be a list of variable symbols. When a -variable containing a list value is formatted in the bug report mail -buffer, it normally is compacted so that its value fits one the fewest -number of lines. If the variable's symbol appears in this list, its -value is printed in a more verbose style, specifically, one elemental -sexp per line. - -Note that this variable is not buffer-local so you should never just -`setq' it. If you want to changes its default value, you should `let' -bind it.") - -;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -;; End of editable variables - - -(defvar reporter-eval-buffer nil - "Buffer to retrieve variable's value from. -This is necessary to properly support the printing of buffer-local -variables. Current buffer will always be the mail buffer being -composed.") - -(defconst reporter-version "3.2" - "Reporter version number.") - -(defvar reporter-initial-text nil - "The automatically created initial text of a bug report.") -(make-variable-buffer-local 'reporter-initial-text) - - - -;; status feedback to the user -(defvar reporter-status-message nil) -(defvar reporter-status-count nil) - -(defun reporter-update-status () - ;; periodically output a status message - (if (zerop (% reporter-status-count 10)) - (progn - (message reporter-status-message) - (setq reporter-status-message (concat reporter-status-message ".")))) - (setq reporter-status-count (1+ reporter-status-count))) - - -;; dumping/pretty printing of values -(defun reporter-beautify-list (maxwidth compact-p) - ;; pretty print a list - (reporter-update-status) - (let (linebreak indent-enclosing-p indent-p here) - (condition-case nil ;loop exit - (progn - (down-list 1) - (setq indent-enclosing-p t) - (while t - (setq here (point)) - (forward-sexp 1) - (if (<= maxwidth (current-column)) - (if linebreak - (progn - (goto-char linebreak) - (newline-and-indent) - (setq linebreak nil)) - (goto-char here) - (setq indent-p (reporter-beautify-list maxwidth compact-p)) - (goto-char here) - (forward-sexp 1) - (if indent-p - (newline-and-indent)) - t) - (if compact-p - (setq linebreak (point)) - (newline-and-indent)) - )) - t) - (error indent-enclosing-p)))) - -(defun reporter-lisp-indent (indent-point state) - ;; a better lisp indentation style for bug reporting - (save-excursion - (goto-char (1+ (nth 1 state))) - (current-column))) - -(defun reporter-dump-variable (varsym mailbuf) - ;; Pretty-print the value of the variable in symbol VARSYM. MAILBUF - ;; is the mail buffer being composed - (reporter-update-status) - (condition-case nil - (let ((val (save-excursion - (set-buffer reporter-eval-buffer) - (symbol-value varsym))) - (sym (symbol-name varsym)) - (print-escape-newlines t) - (maxwidth (1- (window-width))) - (here (point))) - (insert " " sym " " - (cond - ((memq val '(t nil)) "") - ((listp val) "'") - ((symbolp val) "'") - (t "")) - (prin1-to-string val)) - (lisp-indent-line) - ;; clean up lists, but only if the line as printed was long - ;; enough to wrap - (if (and val ;nil is a list, but short - (listp val) - (<= maxwidth (current-column))) - (save-excursion - (let ((compact-p (not (memq varsym reporter-dont-compact-list))) - (lisp-indent-function 'reporter-lisp-indent)) - (goto-char here) - (reporter-beautify-list maxwidth compact-p)))) - (insert "\n")) - (void-variable - (save-excursion - (set-buffer mailbuf) - (mail-position-on-field "X-Reporter-Void-Vars-Found") - (end-of-line) - (insert (symbol-name varsym) " "))) - (error - (error "")))) - -(defun reporter-dump-state (pkgname varlist pre-hooks post-hooks) - ;; Dump the state of the mode specific variables. - ;; PKGNAME contains the name of the mode as it will appear in the bug - ;; report (you must explicitly concat any version numbers). - - ;; VARLIST is the list of variables to dump. Each element in - ;; VARLIST can be a variable symbol, or a cons cell. If a symbol, - ;; this will be passed to `reporter-dump-variable' for insertion - ;; into the mail buffer. If a cons cell, the car must be a variable - ;; symbol and the cdr must be a function which will be `funcall'd - ;; with arguments the symbol and the mail buffer being composed. Use - ;; this to write your own custom variable value printers for - ;; specific variables. - - ;; Note that the global variable `reporter-eval-buffer' will be bound to - ;; the buffer in which `reporter-submit-bug-report' was invoked. If you - ;; want to print the value of a buffer local variable, you should wrap - ;; the `eval' call in your custom printer inside a `set-buffer' (and - ;; probably a `save-excursion'). `reporter-dump-variable' handles this - ;; properly. - - ;; PRE-HOOKS is run after the emacs-version and PKGNAME are inserted, but - ;; before the VARLIST is dumped. POST-HOOKS is run after the VARLIST is - ;; dumped. - (let ((buffer (current-buffer))) - (set-buffer buffer) - (insert "Emacs : " (emacs-version) "\n") - (and pkgname - (insert "Package: " pkgname "\n")) - (run-hooks 'pre-hooks) - (if (not varlist) - nil - (insert "\ncurrent state:\n==============\n") - ;; create an emacs-lisp-mode buffer to contain the output, which - ;; we'll later insert into the mail buffer - (condition-case fault - (let ((mailbuf (current-buffer)) - (elbuf (get-buffer-create " *tmp-reporter-buffer*"))) - (save-excursion - (set-buffer elbuf) - (emacs-lisp-mode) - (erase-buffer) - (insert "(setq\n") - (lisp-indent-line) - (mapcar - (function - (lambda (varsym-or-cons-cell) - (let ((varsym (or (car-safe varsym-or-cons-cell) - varsym-or-cons-cell)) - (printer (or (cdr-safe varsym-or-cons-cell) - 'reporter-dump-variable))) - (funcall printer varsym mailbuf) - ))) - varlist) - (lisp-indent-line) - (insert ")\n")) - (insert-buffer elbuf)) - (error - (insert "State could not be dumped due to the following error:\n\n" - (format "%s" fault) - "\n\nYou should still send this bug report.")))) - (run-hooks 'post-hooks) - )) - - -(defun reporter-calculate-separator () - ;; returns the string regexp matching the mail separator - (save-excursion - (re-search-forward - (concat - "^\\(" ;beginning of line - (mapconcat - 'identity - (list "[\t ]*" ;simple SMTP form - "-+" ;mh-e form - (regexp-quote - mail-header-separator)) ;sendmail.el form - "\\|") ;or them together - "\\)$") ;end of line - nil - 'move) ;search for and move - (buffer-substring (match-beginning 0) (match-end 0)))) - - -(defun reporter-compose-outgoing () - ;; compose the outgoing mail buffer, and return the selected - ;; paradigm, with the current-buffer tacked onto the beginning of - ;; the list. - (let* ((agent mail-user-agent) - (compose (get mail-user-agent 'composefunc))) - ;; Sanity check. If this fails then we'll try to use the SENDMAIL - ;; protocol, otherwise we must signal an error. - (if (not (and compose (fboundp compose))) - (progn - (setq agent 'sendmail-user-agent - compose (get agent 'composefunc)) - (if (not (and compose (fboundp compose))) - (error "Could not find a valid `mail-user-agent'") - (ding) - (message "`%s' is an invalid `mail-user-agent'; using `sendmail-user-agent'" - mail-user-agent) - ))) - (funcall compose) - agent)) - - -;;;###autoload -(defun reporter-submit-bug-report - (address pkgname varlist &optional pre-hooks post-hooks salutation) - ;; Submit a bug report via mail. - - ;; ADDRESS is the email address for the package's maintainer. PKGNAME is - ;; the name of the mode (you must explicitly concat any version numbers). - ;; VARLIST is the list of variables to dump (see `reporter-dump-state' - ;; for details). Optional PRE-HOOKS and POST-HOOKS are passed to - ;; `reporter-dump-state'. Optional SALUTATION is inserted at the top of the - ;; mail buffer, and point is left after the salutation. - - ;; This function will prompt for a summary if - ;; reporter-prompt-for-summary-p is non-nil. - - ;; The mailer used is described in by the variable `mail-user-agent'. - (let ((reporter-eval-buffer (current-buffer)) - final-resting-place - after-sep-pos - (reporter-status-message "Formatting bug report buffer...") - (reporter-status-count 0) - (problem (and reporter-prompt-for-summary-p - (read-string (if (stringp reporter-prompt-for-summary-p) - reporter-prompt-for-summary-p - "(Very) brief summary of problem: ")))) - (agent (reporter-compose-outgoing)) - (mailbuf (current-buffer)) - hookvar) - ;; do the work - (require 'sendmail) - ;; If mailbuf did not get made visible before, make it visible now. - (let (same-window-buffer-names same-window-regexps) - (pop-to-buffer mailbuf) - ;; Just in case the original buffer is not visible now, bring it - ;; back somewhere - (display-buffer reporter-eval-buffer)) - (goto-char (point-min)) - ;; different mailers use different separators, some may not even - ;; use mail-header-separator, but sendmail.el stuff must have this - ;; variable bound. - (let ((mail-header-separator (reporter-calculate-separator))) - (mail-position-on-field "to") - (insert address) - ;; insert problem summary if available - (if (and reporter-prompt-for-summary-p problem pkgname) - (progn - (mail-position-on-field "subject") - (insert pkgname "; " problem))) - ;; move point to the body of the message - (mail-text) - (forward-line 1) - (setq after-sep-pos (point)) - (and salutation (insert "\n" salutation "\n\n")) - (unwind-protect - (progn - (setq final-resting-place (point-marker)) - (insert "\n\n") - (reporter-dump-state pkgname varlist pre-hooks post-hooks) - (goto-char final-resting-place)) - (set-marker final-resting-place nil))) - - ;; save initial text and set up the `no-empty-submission' hook. - ;; This only works for mailers that support a pre-send hook, and - ;; for which the paradigm has a non-nil value for the `hookvar' - ;; key in its agent (i.e. sendmail.el's mail-send-hook). - (save-excursion - (goto-char (point-max)) - (skip-chars-backward " \t\n") - (setq reporter-initial-text (buffer-substring after-sep-pos (point)))) - (if (setq hookvar (get agent 'hookvar)) - (progn - (make-variable-buffer-local hookvar) - (add-hook hookvar 'reporter-bug-hook))) - - ;; compose the minibuf message and display this. - (let* ((sendkey-whereis (where-is-internal - (get agent 'sendfunc) nil t)) - (abortkey-whereis (where-is-internal - (get agent 'abortfunc) nil t)) - (sendkey (if sendkey-whereis - (key-description sendkey-whereis) - "C-c C-c")) ; TBD: BOGUS hardcode - (abortkey (if abortkey-whereis - (key-description abortkey-whereis) - "M-x kill-buffer")) ; TBD: BOGUS hardcode - ) - (message "Please enter your report. Type %s to send, %s to abort." - sendkey abortkey)) - )) - -(defun reporter-bug-hook () - ;; prohibit sending mail if empty bug report - (let ((after-sep-pos - (save-excursion - (beginning-of-buffer) - (re-search-forward (reporter-calculate-separator) (point-max) 'move) - (forward-line 1) - (point)))) - (save-excursion - (goto-char (point-max)) - (skip-chars-backward " \t\n") - (if (and (= (- (point) after-sep-pos) - (length reporter-initial-text)) - (string= (buffer-substring after-sep-pos (point)) - reporter-initial-text)) - (error "Bug report was empty--not sent")) - ))) - - -(provide 'reporter) -;;; reporter.el ends here diff --git a/lisp/mail/rfc822.el b/lisp/mail/rfc822.el deleted file mode 100644 index 178dd943cb6..00000000000 --- a/lisp/mail/rfc822.el +++ /dev/null @@ -1,319 +0,0 @@ -;;; rfc822.el --- hairy rfc822 parser for mail and news and suchlike - -;; Copyright (C) 1986, 87, 1990 Free Software Foundation, Inc. - -;; Author: Richard Mlynarik <mly@eddie.mit.edu> -;; Maintainer: FSF -;; 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: - -;; Support functions for parsing RFC-822 headers, used by mail and news -;; modes. - -;;; Code: - -;; uses address-start free, throws to address -(defun rfc822-bad-address (reason) - (save-restriction - (insert "_^_") - (narrow-to-region address-start - (if (re-search-forward "[,;]" nil t) - (max (point-min) (1- (point))) - (point-max))) - ;; make the error string be suitable for inclusion in (...) - (let ((losers '("\\" "(" ")" "\n"))) - (while losers - (goto-char (point-min)) - (while (search-forward (car losers) nil t) - (backward-char 1) - (insert ?\\) - (forward-char 1)) - (setq losers (cdr losers)))) - (goto-char (point-min)) (insert "(Unparsable address -- " - reason - ": \"") - (goto-char (point-max)) (insert "\")")) - (rfc822-nuke-whitespace) - (throw 'address (buffer-substring address-start (point)))) - -(defun rfc822-nuke-whitespace (&optional leave-space) - (let (ch) - (while (cond ((eobp) - nil) - ((= (setq ch (following-char)) ?\() - (forward-char 1) - (while (if (eobp) - (rfc822-bad-address "Unbalanced comment (...)") - (/= (setq ch (following-char)) ?\))) - (cond ((looking-at "[^()\\]+") - (replace-match "")) - ((= ch ?\() - (rfc822-nuke-whitespace)) - ((< (point) (1- (point-max))) - (delete-char 2)) - (t - (rfc822-bad-address "orphaned backslash")))) - ;; delete remaining "()" - (forward-char -1) - (delete-char 2) - t) - ((memq ch '(?\ ?\t ?\n)) - (delete-region (point) - (progn (skip-chars-forward " \t\n") (point))) - t) - (t - nil))) - (or (not leave-space) - (eobp) - (bobp) - (= (preceding-char) ?\ ) - (insert ?\ )))) - -(defun rfc822-looking-at (regex &optional leave-space) - (if (cond ((stringp regex) - (if (looking-at regex) - (progn (goto-char (match-end 0)) - t))) - (t - (if (and (not (eobp)) - (= (following-char) regex)) - (progn (forward-char 1) - t)))) - (let ((tem (match-data))) - (rfc822-nuke-whitespace leave-space) - (store-match-data tem) - t))) - -(defun rfc822-snarf-word () - ;; word is atom | quoted-string - (cond ((= (following-char) ?\") - ;; quoted-string - (or (rfc822-looking-at "\"\\([^\"\\\n]\\|\\\\.\\|\\\\\n\\)*\"") - (rfc822-bad-address "Unterminated quoted string"))) - ((rfc822-looking-at "[^][\000-\037\177-\377 ()<>@,;:\\\".]+") - ;; atom - ) - (t - (rfc822-bad-address "Rubbish in address")))) - -(defun rfc822-snarf-words () - (rfc822-snarf-word) - (while (rfc822-looking-at ?.) - (rfc822-snarf-word))) - -(defun rfc822-snarf-subdomain () - ;; sub-domain is domain-ref | domain-literal - (cond ((= (following-char) ?\[) - ;; domain-ref - (or (rfc822-looking-at "\\[\\([^][\\\n]\\|\\\\.\\|\\\\\n\\)*\\]") - (rfc822-bad-address "Unterminated domain literal [...]"))) - ((rfc822-looking-at "[^][\000-\037\177-\377 ()<>@,;:\\\".]+") - ;; domain-literal = atom - ) - (t - (rfc822-bad-address "Rubbish in host/domain specification")))) - -(defun rfc822-snarf-domain () - (rfc822-snarf-subdomain) - (while (rfc822-looking-at ?.) - (rfc822-snarf-subdomain))) - -(defun rfc822-snarf-frob-list (name separator terminator snarfer - &optional return) - (let ((first t) - (list ()) - tem) - (while (cond ((eobp) - (rfc822-bad-address - (format "End of addresses in middle of %s" name))) - ((rfc822-looking-at terminator) - nil) - ((rfc822-looking-at separator) - ;; multiple separators are allowed and do nothing. - (while (rfc822-looking-at separator)) - t) - (first - t) - (t - (rfc822-bad-address - (format "Gubbish in middle of %s" name)))) - (setq tem (funcall snarfer) - first nil) - (and return tem - (setq list (if (listp tem) - (nconc (reverse tem) list) - (cons tem list))))) - (nreverse list))) - -;; return either an address (a string) or a list of addresses -(defun rfc822-addresses-1 (&optional allow-groups) - ;; Looking for an rfc822 `address' - ;; Either a group (1*word ":" [#mailbox] ";") - ;; or a mailbox (addr-spec | 1*word route-addr) - ;; addr-spec is (local-part "@" domain) - ;; route-addr is ("<" [1#("@" domain) ":"] addr-spec ">") - ;; local-part is (word *("." word)) - ;; word is (atom | quoted-string) - ;; quoted-string is ("\([^\"\\n]\|\\.\|\\\n\)") - ;; atom is [^\000-\037\177 ()<>@,;:\".[]]+ - ;; domain is sub-domain *("." sub-domain) - ;; sub-domain is domain-ref | domain-literal - ;; domain-literal is "[" *(dtext | quoted-pair) "]" - ;; dtext is "[^][\\n" - ;; domain-ref is atom - (let ((address-start (point)) - (n 0)) - (catch 'address - ;; optimize common cases: - ;; foo - ;; foo.bar@bar.zap - ;; followed by "\\'\\|,\\|([^()\\]*)\\'" - ;; other common cases are: - ;; foo bar <foo.bar@baz.zap> - ;; "foo bar" <foo.bar@baz.zap> - ;; those aren't hacked yet. - (if (and (rfc822-looking-at "[^][\000-\037\177-\377 ()<>@,;:\\\"]+\\(\\|@[^][\000-\037\177-\377 ()<>@,;:\\\"]+\\)" t) - (progn (or (eobp) - (rfc822-looking-at ?,)))) - (progn - ;; rfc822-looking-at may have inserted a space - (or (bobp) (/= (preceding-char) ?\ ) (delete-char -1)) - ;; relying on the fact that rfc822-looking-at <char> - ;; doesn't mung match-data - (throw 'address (buffer-substring address-start (match-end 0))))) - (goto-char address-start) - (while t - (cond ((and (= n 1) (rfc822-looking-at ?@)) - ;; local-part@domain - (rfc822-snarf-domain) - (throw 'address - (buffer-substring address-start (point)))) - ((rfc822-looking-at ?:) - (cond ((not allow-groups) - (rfc822-bad-address "A group name may not appear here")) - ((= n 0) - (rfc822-bad-address "No name for :...; group"))) - ;; group - (throw 'address - ;; return a list of addresses - (rfc822-snarf-frob-list ":...; group" ?\, ?\; - 'rfc822-addresses-1 t))) - ((rfc822-looking-at ?<) - (let ((start (point)) - (strip t)) - (cond ((rfc822-looking-at ?>) - ;; empty path - ()) - ((and (not (eobp)) (= (following-char) ?\@)) - ;; <@foo.bar,@baz:quux@abcd.efg> - (rfc822-snarf-frob-list "<...> address" ?\, ?\: - (function (lambda () - (if (rfc822-looking-at ?\@) - (rfc822-snarf-domain) - (rfc822-bad-address - "Gubbish in route-addr"))))) - (rfc822-snarf-words) - (or (rfc822-looking-at ?@) - (rfc822-bad-address "Malformed <..@..> address")) - (rfc822-snarf-domain) - (setq strip nil)) - ((progn (rfc822-snarf-words) (rfc822-looking-at ?@)) - ; allow <foo> (losing unix seems to do this) - (rfc822-snarf-domain))) - (let ((end (point))) - (if (rfc822-looking-at ?\>) - (throw 'address - (buffer-substring (if strip start (1- start)) - (if strip end (1+ end)))) - (rfc822-bad-address "Unterminated <...> address"))))) - ((looking-at "[^][\000-\037\177-\377 ()<>@,;:\\.]") - ;; this allows "." to be part of the words preceding - ;; an addr-spec, since many broken mailers output - ;; "Hern K. Herklemeyer III - ;; <yank@megadeath.dod.gods-own-country>" - (let ((again t)) - (while again - (or (= n 0) (bobp) (= (preceding-char) ?\ ) - (insert ?\ )) - (rfc822-snarf-words) - (setq n (1+ n)) - (setq again (or (rfc822-looking-at ?.) - (looking-at "[^][\000-\037\177-\377 ()<>@,;:\\.]")))))) - ((= n 0) - (throw 'address nil)) - ((= n 1) ; allow "foo" (losing unix seems to do this) - (throw 'address - (buffer-substring address-start (point)))) - ((> n 1) - (rfc822-bad-address "Missing comma between addresses or badly-formatted address")) - ((or (eobp) (= (following-char) ?,)) - (rfc822-bad-address "Missing comma or route-spec")) - (t - (rfc822-bad-address "Strange character or missing comma"))))))) - - -(defun rfc822-addresses (header-text) - (if (string-match "\\`[ \t]*\\([^][\000-\037\177-\377 ()<>@,;:\\\".]+\\)[ \t]*\\'" - header-text) - ;; Make very simple case moderately fast. - (list (substring header-text (match-beginning 1) (match-end 1))) - (let ((buf (generate-new-buffer " rfc822"))) - (unwind-protect - (save-excursion - (set-buffer buf) - (make-local-variable 'case-fold-search) - (setq case-fold-search nil) ;For speed(?) - (insert header-text) - ;; unfold continuation lines - (goto-char (point-min)) - - (while (re-search-forward "\\([^\\]\\(\\\\\\\\\\)*\\)\n[ \t]" nil t) - (replace-match "\\1 " t)) - - (goto-char (point-min)) - (rfc822-nuke-whitespace) - (let ((list ()) - tem - address-start); this is for rfc822-bad-address - (while (not (eobp)) - (setq address-start (point)) - (setq tem - (catch 'address ; this is for rfc822-bad-address - (cond ((rfc822-looking-at ?\,) - nil) - ((looking-at "[][\000-\037\177-\377@;:\\.>)]") - (forward-char) - (rfc822-bad-address - (format "Strange character \\%c found" - (preceding-char)))) - (t - (rfc822-addresses-1 t))))) - (cond ((null tem)) - ((stringp tem) - (setq list (cons tem list))) - (t - (setq list (nconc (nreverse tem) list))))) - (nreverse list))) - (and buf (kill-buffer buf)))))) - -(provide 'rfc822) - -;;; rfc822.el ends here diff --git a/lisp/mail/rmail.el b/lisp/mail/rmail.el deleted file mode 100644 index 30493fea700..00000000000 --- a/lisp/mail/rmail.el +++ /dev/null @@ -1,2715 +0,0 @@ -;;; rmail.el --- main code of "RMAIL" mail reader for Emacs. - -;; Copyright (C) 1985,86,87,88,93,94,95,96 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; 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. - -;;; Code: - -;; Souped up by shane@mit-ajax based on ideas of rlk@athena.mit.edu -;; New features include attribute and keyword support, message -;; selection by dispatch table, summary by attributes and keywords, -;; expunging by dispatch table, sticky options for file commands. - -;; Extended by Bob Weiner of Motorola -;; New features include: rmail and rmail-summary buffers remain -;; synchronized and key bindings basically operate the same way in both -;; buffers, summary by topic or by regular expression, rmail-reply-prefix -;; variable, and a bury rmail buffer (wipe) command. -;; - -(require 'mail-utils) - -;; For Emacs V18 compatibility -(and (not (fboundp 'buffer-disable-undo)) - (fboundp 'buffer-flush-undo) - (defalias 'buffer-disable-undo 'buffer-flush-undo)) - -; These variables now declared in paths.el. -;(defvar rmail-spool-directory "/usr/spool/mail/" -; "This is the name of the directory used by the system mailer for\n\ -;delivering new mail. Its name should end with a slash.") -;(defvar rmail-file-name -; (expand-file-name "~/RMAIL") -; "") - -(defvar rmail-movemail-program nil - "If non-nil, name of program for fetching new mail.") - -(defvar rmail-pop-password nil - "*Password to use when reading mail from a POP server, if required.") - -(defvar rmail-pop-password-required nil - "*Non-nil if a password is required when reading mail using POP.") - -;;;###autoload -(defvar rmail-dont-reply-to-names nil "\ -*A regexp specifying names to prune of reply to messages. -A value of nil means exclude your own name only.") - -;;;###autoload -(defvar rmail-default-dont-reply-to-names "info-" "\ -A regular expression specifying part of the value of the default value of -the variable `rmail-dont-reply-to-names', for when the user does not set -`rmail-dont-reply-to-names' explicitly. (The other part of the default -value is the user's name.) -It is useful to set this variable in the site customization file.") - -;;;###autoload -(defvar rmail-ignored-headers "^via:\\|^mail-from:\\|^origin:\\|^status:\\|^received:\\|^x400-originator:\\|^x400-recipients:\\|^x400-received:\\|^x400-mts-identifier:\\|^x400-content-type:\\|^\\(resent-\\|\\)message-id:\\|^summary-line:\\|^resent-date:\\|^nntp-posting-host:\\|^path:\\|^x-char.*:\\|^x-face:\\|^x-mailer:" - "*Regexp to match header fields that Rmail should normally hide.") - -;;;###autoload -(defvar rmail-displayed-headers nil - "*Regexp to match Header fields that Rmail should display. -If nil, display all header fields except those matched by -`rmail-ignored-headers'.") - -;;;###autoload -(defvar rmail-retry-ignored-headers nil "\ -*Headers that should be stripped when retrying a failed message.") - -;;;###autoload -(defvar rmail-highlighted-headers "^From:\\|^Subject:" "\ -*Regexp to match Header fields that Rmail should normally highlight. -A value of nil means don't highlight. -See also `rmail-highlight-face'.") - -;;;###autoload -(defvar rmail-highlight-face nil "\ -*Face used by Rmail for highlighting headers.") - -;;;###autoload -(defvar rmail-delete-after-output nil "\ -*Non-nil means automatically delete a message that is copied to a file.") - -;;;###autoload -(defvar rmail-primary-inbox-list nil "\ -*List of files which are inboxes for user's primary mail file `~/RMAIL'. -`nil' means the default, which is (\"/usr/spool/mail/$USER\") -\(the name varies depending on the operating system, -and the value of the environment variable MAIL overrides it).") - -;;;###autoload -(defvar rmail-mail-new-frame nil - "*Non-nil means Rmail makes a new frame for composing outgoing mail.") - -;;;###autoload -(defvar rmail-secondary-file-directory "~/" - "*Directory for additional secondary Rmail files.") -;;;###autoload -(defvar rmail-secondary-file-regexp "\\.xmail$" - "*Regexp for which files are secondary Rmail files.") - -;;;###autoload -(defvar rmail-mode-hook nil - "List of functions to call when Rmail is invoked.") - -;;;###autoload -(defvar rmail-get-new-mail-hook nil - "List of functions to call when Rmail has retrieved new mail.") - -;;;###autoload -(defvar rmail-show-message-hook nil - "List of functions to call when Rmail displays a message.") - -;;;###autoload -(defvar rmail-delete-message-hook nil - "List of functions to call when Rmail deletes a message. -When the hooks are called, the message has been marked deleted but is -still the current message in the Rmail buffer.") - -;; These may be altered by site-init.el to match the format of mmdf files -;; delimiting used on a given host (delim1 and delim2 from the config -;; files). - -(defvar mmdf-delim1 "^\001\001\001\001\n" - "Regexp marking the start of an mmdf message") -(defvar mmdf-delim2 "^\001\001\001\001\n" - "Regexp marking the end of an mmdf message") - -(defvar rmail-message-filter nil - "If non-nil, a filter function for new messages in RMAIL. -Called with region narrowed to the message, including headers, -before obeying `rmail-ignored-headers'.") - -(defvar rmail-reply-prefix "Re: " - "String to prepend to Subject line when replying to a message.") - -;; Some mailers use "Re(2):" or "Re^2:" or "Re: Re:" or "Re[2]". -;; This pattern should catch all the common variants. -(defvar rmail-reply-regexp "\\`\\(Re\\(([0-9]+)\\|\\[[0-9]+\\]\\|\\^[0-9]+\\)?: *\\)*" - "Regexp to delete from Subject line before inserting `rmail-reply-prefix'.") - -(defvar rmail-display-summary nil - "If non-nil, Rmail always displays the summary buffer.") - -(defvar rmail-mode-map nil) - -(defvar rmail-inbox-list nil) -(defvar rmail-keywords nil) - -;; Message counters and markers. Deleted flags. - -(defvar rmail-current-message nil) -(defvar rmail-total-messages nil) -(defvar rmail-message-vector nil) -(defvar rmail-deleted-vector nil) - -(defvar rmail-overlay-list nil) - -(defvar rmail-font-lock-keywords - (eval-when-compile - (let* ((cite-chars "[>|}]") - (cite-prefix "A-Za-z") - (cite-suffix (concat cite-prefix "0-9_.@-`'\""))) - (list '("^\\(From\\|Sender\\):" . font-lock-function-name-face) - '("^Reply-To:.*$" . font-lock-function-name-face) - '("^Subject:" . font-lock-comment-face) - '("^\\(To\\|Apparently-To\\|Cc\\):" . font-lock-keyword-face) - ;; Use MATCH-ANCHORED to effectively anchor the regexp left side. - `(,cite-chars - (,(concat "\\=[ \t]*" - "\\([" cite-prefix "]+[" cite-suffix "]*\\)?" - cite-chars ".*") - (beginning-of-line) (end-of-line) - (0 font-lock-reference-face))) - '("^\\(X-[A-Za-z0-9-]+\\|In-reply-to\\|Date\\):.*$" - . font-lock-string-face)))) - "Additional expressions to highlight in Rmail mode.") - -;; These are used by autoloaded rmail-summary. - -(defvar rmail-summary-buffer nil) -(defvar rmail-summary-vector nil) - -;; `Sticky' default variables. - -;; Last individual label specified to a or k. -(defvar rmail-last-label nil) -;; Last set of values specified to C-M-n, C-M-p, C-M-s or C-M-l. -(defvar rmail-last-multi-labels nil) -(defvar rmail-last-regexp nil) -(defvar rmail-default-file "~/xmail" - "*Default file name for \\[rmail-output].") -(defvar rmail-default-rmail-file "~/XMAIL" - "*Default file name for \\[rmail-output-to-rmail-file].") - -;;; Regexp matching the delimiter of messages in UNIX mail format -;;; (UNIX From lines), minus the initial ^. Note that if you change -;;; this expression, you must change the code in rmail-nuke-pinhead-header -;;; that knows the exact ordering of the \\( \\) subexpressions. -(defvar rmail-unix-mail-delimiter - (let ((time-zone-regexp - (concat "\\([A-Z]?[A-Z]?[A-Z][A-Z]\\( DST\\)?" - "\\|[-+]?[0-9][0-9][0-9][0-9]" - "\\|" - "\\) *"))) - (concat - "From " - - ;; Many things can happen to an RFC 822 mailbox before it is put into - ;; a `From' line. The leading phrase can be stripped, e.g. - ;; `Joe <@w.x:joe@y.z>' -> `<@w.x:joe@y.z>'. The <> can be stripped, e.g. - ;; `<@x.y:joe@y.z>' -> `@x.y:joe@y.z'. Everything starting with a CRLF - ;; can be removed, e.g. - ;; From: joe@y.z (Joe K - ;; User) - ;; can yield `From joe@y.z (Joe K Fri Mar 22 08:11:15 1996', and - ;; From: Joe User - ;; <joe@y.z> - ;; can yield `From Joe User Fri Mar 22 08:11:15 1996'. - ;; The mailbox can be removed or be replaced by white space, e.g. - ;; From: "Joe User"{space}{tab} - ;; <joe@y.z> - ;; can yield `From {space}{tab} Fri Mar 22 08:11:15 1996', - ;; where {space} and {tab} represent the Ascii space and tab characters. - ;; We want to match the results of any of these manglings. - ;; The following regexp rejects names whose first characters are - ;; obviously bogus, but after that anything goes. - "\\([^\0-\b\n-\r\^?].*\\)? " - - ;; The time the message was sent. - "\\([^\0-\r \^?]+\\) +" ; day of the week - "\\([^\0-\r \^?]+\\) +" ; month - "\\([0-3]?[0-9]\\) +" ; day of month - "\\([0-2][0-9]:[0-5][0-9]\\(:[0-6][0-9]\\)?\\) *" ; time of day - - ;; Perhaps a time zone, specified by an abbreviation, or by a - ;; numeric offset. - time-zone-regexp - - ;; The year. - " \\([0-9][0-9]+\\) *" - - ;; On some systems the time zone can appear after the year, too. - time-zone-regexp - - ;; Old uucp cruft. - "\\(remote from .*\\)?" - - "\n")) - nil) - -;; Perform BODY in the summary buffer -;; in such a way that its cursor is properly updated in its own window. -(defmacro rmail-select-summary (&rest body) - (` (let ((total rmail-total-messages)) - (if (rmail-summary-displayed) - (let ((window (selected-window))) - (save-excursion - (unwind-protect - (progn - (pop-to-buffer rmail-summary-buffer) - ;; rmail-total-messages is a buffer-local var - ;; in the rmail buffer. - ;; This way we make it available for the body - ;; even tho the rmail buffer is not current. - (let ((rmail-total-messages total)) - (,@ body))) - (select-window window)))) - (save-excursion - (set-buffer rmail-summary-buffer) - (let ((rmail-total-messages total)) - (,@ body)))) - (rmail-maybe-display-summary)))) - -;;;; *** Rmail Mode *** - -;;;###autoload -(defun rmail (&optional file-name-arg) - "Read and edit incoming mail. -Moves messages into file named by `rmail-file-name' (a babyl format file) - and edits that file in RMAIL Mode. -Type \\[describe-mode] once editing that file, for a list of RMAIL commands. - -May be called with file name as argument; then performs rmail editing on -that file, but does not copy any new mail into the file. -Interactively, if you supply a prefix argument, then you -have a chance to specify a file name with the minibuffer. - -If `rmail-display-summary' is non-nil, make a summary for this RMAIL file." - (interactive (if current-prefix-arg - (list (read-file-name "Run rmail on RMAIL file: ")))) - (let* ((file-name (expand-file-name (or file-name-arg rmail-file-name))) - (existed (get-file-buffer file-name)) - run-mail-hook) - ;; Like find-file, but in the case where a buffer existed - ;; and the file was reverted, recompute the message-data. - (if (and existed (not (verify-visited-file-modtime existed))) - (progn - ;; Don't be confused by apparent local-variables spec - ;; in the last message in the RMAIL file. - (let ((enable-local-variables nil)) - (find-file file-name)) - (if (and (verify-visited-file-modtime existed) - (eq major-mode 'rmail-mode)) - (progn (rmail-forget-messages) - (rmail-set-message-counters)))) - (let ((enable-local-variables nil)) - (find-file file-name))) - (if (eq major-mode 'rmail-edit-mode) - (error "Exit Rmail Edit mode before getting new mail.")) - (if (and existed (> (buffer-size) 0)) - ;; Buffer not new and not empty; ensure in proper mode, but that's all. - (or (eq major-mode 'rmail-mode) - (progn (rmail-mode-2) - (setq run-mail-hook t))) - (setq run-mail-hook t) - (rmail-mode-2) - ;; Convert all or part to Babyl file if possible. - (rmail-convert-file) - (goto-char (point-max)) - (if (null rmail-inbox-list) - (progn - (rmail-set-message-counters) - (rmail-show-message)))) - (or (and (null file-name-arg) - (rmail-get-new-mail)) - (rmail-show-message (rmail-first-unseen-message))) - (if rmail-display-summary (rmail-summary)) - (rmail-construct-io-menu) - (if run-mail-hook - (run-hooks 'rmail-mode-hook)))) - -;; Given the value of MAILPATH, return a list of inbox file names. -;; This is turned off because it is not clear that the user wants -;; all these inboxes to feed into the primary rmail file. -; (defun rmail-convert-mailpath (string) -; (let (idx list) -; (while (setq idx (string-match "[%:]" string)) -; (let ((this (substring string 0 idx))) -; (setq string (substring string (1+ idx))) -; (setq list (cons (if (string-match "%" this) -; (substring this 0 (string-match "%" this)) -; this) -; list)))) -; list)) - -; I have checked that adding "-*- rmail -*-" to the BABYL OPTIONS line -; will not cause emacs 18.55 problems. - -(defun rmail-convert-file () - (let (convert) - (widen) - (goto-char (point-min)) - ;; If file doesn't start like a Babyl file, - ;; convert it to one, by adding a header and converting each message. - (cond ((looking-at "BABYL OPTIONS:")) - ((looking-at "Version: 5\n") - ;; Losing babyl file made by old version of Rmail. - ;; Just fix the babyl file header; don't make a new one, - ;; so we don't lose the Labels: file attribute, etc. - (let ((buffer-read-only nil)) - (insert "BABYL OPTIONS: -*- rmail -*-\n"))) - ((equal (point-min) (point-max)) - ;; Empty RMAIL file. Just insert the header. - (rmail-insert-rmail-file-header)) - (t - ;; Non-empty file in non-RMAIL format. Add header and convert. - (setq convert t) - (rmail-insert-rmail-file-header))) - ;; If file was not a Babyl file or if there are - ;; Unix format messages added at the end, - ;; convert file as necessary. - (if (or convert - (save-excursion - (goto-char (point-max)) - (search-backward "\n\^_") - (forward-char 2) - (looking-at "\n*From "))) - (let ((buffer-read-only nil)) - (message "Converting to Babyl format...") - ;; If file needs conversion, convert it all, - ;; except for the BABYL header. - ;; (rmail-convert-to-babyl-format would delete the header.) - (goto-char (point-min)) - (search-forward "\n\^_" nil t) - (narrow-to-region (point) (point-max)) - (rmail-convert-to-babyl-format) - (message "Converting to Babyl format...done"))))) - -;;; I have checked that adding "-*- rmail -*-" to the BABYL OPTIONS line -;;; will not cause emacs 18.55 problems. - -(defun rmail-insert-rmail-file-header () - (let ((buffer-read-only nil)) - (insert "BABYL OPTIONS: -*- rmail -*- -Version: 5 -Labels: -Note: This is the header of an rmail file. -Note: If you are seeing it in rmail, -Note: it means the file has no messages in it.\n\^_"))) - -(if rmail-mode-map - nil - (setq rmail-mode-map (make-keymap)) - (suppress-keymap rmail-mode-map) - (define-key rmail-mode-map "a" 'rmail-add-label) - (define-key rmail-mode-map "b" 'rmail-bury) - (define-key rmail-mode-map "c" 'rmail-continue) - (define-key rmail-mode-map "d" 'rmail-delete-forward) - (define-key rmail-mode-map "\C-d" 'rmail-delete-backward) - (define-key rmail-mode-map "e" 'rmail-edit-current-message) - (define-key rmail-mode-map "f" 'rmail-forward) - (define-key rmail-mode-map "g" 'rmail-get-new-mail) - (define-key rmail-mode-map "h" 'rmail-summary) - (define-key rmail-mode-map "i" 'rmail-input) - (define-key rmail-mode-map "j" 'rmail-show-message) - (define-key rmail-mode-map "k" 'rmail-kill-label) - (define-key rmail-mode-map "l" 'rmail-summary-by-labels) - (define-key rmail-mode-map "\e\C-h" 'rmail-summary) - (define-key rmail-mode-map "\e\C-l" 'rmail-summary-by-labels) - (define-key rmail-mode-map "\e\C-r" 'rmail-summary-by-recipients) - (define-key rmail-mode-map "\e\C-s" 'rmail-summary-by-regexp) - (define-key rmail-mode-map "\e\C-t" 'rmail-summary-by-topic) - (define-key rmail-mode-map "m" 'rmail-mail) - (define-key rmail-mode-map "\em" 'rmail-retry-failure) - (define-key rmail-mode-map "n" 'rmail-next-undeleted-message) - (define-key rmail-mode-map "\en" 'rmail-next-message) - (define-key rmail-mode-map "\e\C-n" 'rmail-next-labeled-message) - (define-key rmail-mode-map "o" 'rmail-output-to-rmail-file) - (define-key rmail-mode-map "\C-o" 'rmail-output) - (define-key rmail-mode-map "p" 'rmail-previous-undeleted-message) - (define-key rmail-mode-map "\ep" 'rmail-previous-message) - (define-key rmail-mode-map "\e\C-p" 'rmail-previous-labeled-message) - (define-key rmail-mode-map "q" 'rmail-quit) - (define-key rmail-mode-map "r" 'rmail-reply) -;; I find I can't live without the default M-r command -- rms. -;; (define-key rmail-mode-map "\er" 'rmail-search-backwards) - (define-key rmail-mode-map "s" 'rmail-expunge-and-save) - (define-key rmail-mode-map "\es" 'rmail-search) - (define-key rmail-mode-map "t" 'rmail-toggle-header) - (define-key rmail-mode-map "u" 'rmail-undelete-previous-message) - (define-key rmail-mode-map "w" 'rmail-edit-current-message) - (define-key rmail-mode-map "x" 'rmail-expunge) - (define-key rmail-mode-map "." 'rmail-beginning-of-message) - (define-key rmail-mode-map "<" 'rmail-first-message) - (define-key rmail-mode-map ">" 'rmail-last-message) - (define-key rmail-mode-map " " 'scroll-up) - (define-key rmail-mode-map "\177" 'scroll-down) - (define-key rmail-mode-map "?" 'describe-mode) - (define-key rmail-mode-map "\C-c\C-s\C-d" 'rmail-sort-by-date) - (define-key rmail-mode-map "\C-c\C-s\C-s" 'rmail-sort-by-subject) - (define-key rmail-mode-map "\C-c\C-s\C-a" 'rmail-sort-by-author) - (define-key rmail-mode-map "\C-c\C-s\C-r" 'rmail-sort-by-recipient) - (define-key rmail-mode-map "\C-c\C-s\C-c" 'rmail-sort-by-correspondent) - (define-key rmail-mode-map "\C-c\C-s\C-l" 'rmail-sort-by-lines) - (define-key rmail-mode-map "\C-c\C-s\C-k" 'rmail-sort-by-keywords) - (define-key rmail-mode-map "\C-c\C-n" 'rmail-next-same-subject) - (define-key rmail-mode-map "\C-c\C-p" 'rmail-previous-same-subject) - ) - -(define-key rmail-mode-map [menu-bar] (make-sparse-keymap)) - -(define-key rmail-mode-map [menu-bar classify] - (cons "Classify" (make-sparse-keymap "Classify"))) - -(define-key rmail-mode-map [menu-bar classify input-menu] - nil) - -(define-key rmail-mode-map [menu-bar classify output-menu] - nil) - -(define-key rmail-mode-map [menu-bar classify output-inbox] - '("Output (inbox)..." . rmail-output)) - -(define-key rmail-mode-map [menu-bar classify output] - '("Output (Rmail)..." . rmail-output-to-rmail-file)) - -(define-key rmail-mode-map [menu-bar classify kill-label] - '("Kill Label..." . rmail-kill-label)) - -(define-key rmail-mode-map [menu-bar classify add-label] - '("Add Label..." . rmail-add-label)) - -(define-key rmail-mode-map [menu-bar summary] - (cons "Summary" (make-sparse-keymap "Summary"))) - -(define-key rmail-mode-map [menu-bar summary senders] - '("By Senders..." . rmail-summary-by-senders)) - -(define-key rmail-mode-map [menu-bar summary labels] - '("By Labels..." . rmail-summary-by-labels)) - -(define-key rmail-mode-map [menu-bar summary recipients] - '("By Recipients..." . rmail-summary-by-recipients)) - -(define-key rmail-mode-map [menu-bar summary topic] - '("By Topic..." . rmail-summary-by-topic)) - -(define-key rmail-mode-map [menu-bar summary regexp] - '("By Regexp..." . rmail-summary-by-regexp)) - -(define-key rmail-mode-map [menu-bar summary all] - '("All" . rmail-summary)) - -(define-key rmail-mode-map [menu-bar mail] - (cons "Mail" (make-sparse-keymap "Mail"))) - -(define-key rmail-mode-map [menu-bar mail rmail-get-new-mail] - '("Get New Mail" . rmail-get-new-mail)) - -(define-key rmail-mode-map [menu-bar mail lambda] - '("----")) - -(define-key rmail-mode-map [menu-bar mail continue] - '("Continue" . rmail-continue)) - -(define-key rmail-mode-map [menu-bar mail resend] - '("Re-send..." . rmail-resend)) - -(define-key rmail-mode-map [menu-bar mail forward] - '("Forward" . rmail-forward)) - -(define-key rmail-mode-map [menu-bar mail retry] - '("Retry" . rmail-retry-failure)) - -(define-key rmail-mode-map [menu-bar mail reply] - '("Reply" . rmail-reply)) - -(define-key rmail-mode-map [menu-bar mail mail] - '("Mail" . rmail-mail)) - -(define-key rmail-mode-map [menu-bar delete] - (cons "Delete" (make-sparse-keymap "Delete"))) - -(define-key rmail-mode-map [menu-bar delete expunge/save] - '("Expunge/Save" . rmail-expunge-and-save)) - -(define-key rmail-mode-map [menu-bar delete expunge] - '("Expunge" . rmail-expunge)) - -(define-key rmail-mode-map [menu-bar delete undelete] - '("Undelete" . rmail-undelete-previous-message)) - -(define-key rmail-mode-map [menu-bar delete delete] - '("Delete" . rmail-delete-forward)) - -(define-key rmail-mode-map [menu-bar move] - (cons "Move" (make-sparse-keymap "Move"))) - -(define-key rmail-mode-map [menu-bar move search-back] - '("Search Back..." . rmail-search-backwards)) - -(define-key rmail-mode-map [menu-bar move search] - '("Search..." . rmail-search)) - -(define-key rmail-mode-map [menu-bar move previous] - '("Previous Nondeleted" . rmail-previous-undeleted-message)) - -(define-key rmail-mode-map [menu-bar move next] - '("Next Nondeleted" . rmail-next-undeleted-message)) - -(define-key rmail-mode-map [menu-bar move last] - '("Last" . rmail-last-message)) - -(define-key rmail-mode-map [menu-bar move first] - '("First" . rmail-first-message)) - -(define-key rmail-mode-map [menu-bar move previous] - '("Previous" . rmail-previous-message)) - -(define-key rmail-mode-map [menu-bar move next] - '("Next" . rmail-next-message)) - -;; Rmail mode is suitable only for specially formatted data. -(put 'rmail-mode 'mode-class 'special) - -(defun rmail-mode-kill-summary () - (if rmail-summary-buffer (kill-buffer rmail-summary-buffer))) - -;;;###autoload -(defun rmail-mode () - "Rmail Mode is used by \\<rmail-mode-map>\\[rmail] for editing Rmail files. -All normal editing commands are turned off. -Instead, these commands are available: - -\\[rmail-beginning-of-message] Move point to front of this message (same as \\[beginning-of-buffer]). -\\[scroll-up] Scroll to next screen of this message. -\\[scroll-down] Scroll to previous screen of this message. -\\[rmail-next-undeleted-message] Move to Next non-deleted message. -\\[rmail-previous-undeleted-message] Move to Previous non-deleted message. -\\[rmail-next-message] Move to Next message whether deleted or not. -\\[rmail-previous-message] Move to Previous message whether deleted or not. -\\[rmail-first-message] Move to the first message in Rmail file. -\\[rmail-last-message] Move to the last message in Rmail file. -\\[rmail-show-message] Jump to message specified by numeric position in file. -\\[rmail-search] Search for string and show message it is found in. -\\[rmail-delete-forward] Delete this message, move to next nondeleted. -\\[rmail-delete-backward] Delete this message, move to previous nondeleted. -\\[rmail-undelete-previous-message] Undelete message. Tries current message, then earlier messages - till a deleted message is found. -\\[rmail-edit-current-message] Edit the current message. \\[rmail-cease-edit] to return to Rmail. -\\[rmail-expunge] Expunge deleted messages. -\\[rmail-expunge-and-save] Expunge and save the file. -\\[rmail-quit] Quit Rmail: expunge, save, then switch to another buffer. -\\[save-buffer] Save without expunging. -\\[rmail-get-new-mail] Move new mail from system spool directory into this file. -\\[rmail-mail] Mail a message (same as \\[mail-other-window]). -\\[rmail-continue] Continue composing outgoing message started before. -\\[rmail-reply] Reply to this message. Like \\[rmail-mail] but initializes some fields. -\\[rmail-retry-failure] Send this message again. Used on a mailer failure message. -\\[rmail-forward] Forward this message to another user. -\\[rmail-output-to-rmail-file] Output this message to an Rmail file (append it). -\\[rmail-output] Output this message to a Unix-format mail file (append it). -\\[rmail-input] Input Rmail file. Run Rmail on that file. -\\[rmail-add-label] Add label to message. It will be displayed in the mode line. -\\[rmail-kill-label] Kill label. Remove a label from current message. -\\[rmail-next-labeled-message] Move to Next message with specified label - (label defaults to last one specified). - Standard labels: filed, unseen, answered, forwarded, deleted. - Any other label is present only if you add it with \\[rmail-add-label]. -\\[rmail-previous-labeled-message] Move to Previous message with specified label -\\[rmail-summary] Show headers buffer, with a one line summary of each message. -\\[rmail-summary-by-labels] Summarize only messages with particular label(s). -\\[rmail-summary-by-recipients] Summarize only messages with particular recipient(s). -\\[rmail-summary-by-regexp] Summarize only messages with particular regexp(s). -\\[rmail-summary-by-topic] Summarize only messages with subject line regexp(s). -\\[rmail-toggle-header] Toggle display of complete header." - (interactive) - (rmail-mode-2) - (rmail-set-message-counters) - (rmail-show-message rmail-total-messages) - (run-hooks 'rmail-mode-hook)) - -(defun rmail-mode-2 () - (kill-all-local-variables) - (rmail-mode-1) - (rmail-variables)) - -(defun rmail-mode-1 () - (setq major-mode 'rmail-mode) - (setq mode-name "RMAIL") - (setq buffer-read-only t) - ;; No need to auto save RMAIL files in normal circumstances - ;; because they contain no info except attribute changes - ;; and deletion of messages. - ;; The one exception is when messages are copied into an Rmail mode buffer. - ;; rmail-output-to-rmail-file enables auto save when you do that. - (setq buffer-auto-save-file-name nil) - (if (boundp 'mode-line-modified) - (setq mode-line-modified "--- ") - (setq mode-line-format - (cons "--- " (cdr (default-value 'mode-line-format))))) - (use-local-map rmail-mode-map) - (set-syntax-table text-mode-syntax-table) - (setq local-abbrev-table text-mode-abbrev-table)) - -(defun rmail-variables () - (make-local-variable 'revert-buffer-function) - (setq revert-buffer-function 'rmail-revert) - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults - '(rmail-font-lock-keywords t nil nil nil - (font-lock-maximum-size . nil) - (font-lock-fontify-buffer-function . rmail-fontify-buffer-function) - (font-lock-unfontify-buffer-function . rmail-unfontify-buffer-function) - (font-lock-inhibit-thing-lock . (lazy-lock-mode fast-lock-mode)))) - (make-local-variable 'rmail-last-label) - (make-local-variable 'rmail-last-regexp) - (make-local-variable 'rmail-deleted-vector) - (make-local-variable 'rmail-summary-buffer) - (make-local-variable 'rmail-summary-vector) - (make-local-variable 'rmail-current-message) - (make-local-variable 'rmail-total-messages) - (make-local-variable 'require-final-newline) - (setq require-final-newline nil) - (make-local-variable 'rmail-overlay-list) - (setq rmail-overlay-list nil) - (make-local-variable 'version-control) - (setq version-control 'never) - (make-local-variable 'kill-buffer-hook) - (add-hook 'kill-buffer-hook 'rmail-mode-kill-summary) - (make-local-variable 'file-precious-flag) - (setq file-precious-flag t) - (make-local-variable 'rmail-message-vector) - (make-local-variable 'rmail-inbox-list) - (setq rmail-inbox-list (rmail-parse-file-inboxes)) - ;; Provide default set of inboxes for primary mail file ~/RMAIL. - (and (null rmail-inbox-list) - (or (equal buffer-file-name (expand-file-name rmail-file-name)) - (equal buffer-file-truename - (abbreviate-file-name (file-truename rmail-file-name)))) - (setq rmail-inbox-list - (or rmail-primary-inbox-list - (list (or (getenv "MAIL") - (concat rmail-spool-directory - (user-login-name))))))) - (make-local-variable 'rmail-keywords) - ;; this gets generated as needed - (setq rmail-keywords nil)) - -;; Handle M-x revert-buffer done in an rmail-mode buffer. -(defun rmail-revert (arg noconfirm) - (let ((revert-buffer-function (default-value 'revert-buffer-function))) - ;; Call our caller again, but this time it does the default thing. - (if (revert-buffer arg noconfirm) - ;; If the user said "yes", and we changed something, - ;; reparse the messages. - (progn - (rmail-convert-file) - (goto-char (point-max)) - (rmail-mode))))) - -;; Return a list of files from this buffer's Mail: option. -;; Does not assume that messages have been parsed. -;; Just returns nil if buffer does not look like Babyl format. -(defun rmail-parse-file-inboxes () - (save-excursion - (save-restriction - (widen) - (goto-char 1) - (cond ((looking-at "BABYL OPTIONS:") - (search-forward "\n\^_" nil 'move) - (narrow-to-region 1 (point)) - (goto-char 1) - (if (search-forward "\nMail:" nil t) - (progn - (narrow-to-region (point) (progn (end-of-line) (point))) - (goto-char (point-min)) - (mail-parse-comma-list)))))))) - -(defun rmail-expunge-and-save () - "Expunge and save RMAIL file." - (interactive) - (rmail-expunge) - (save-buffer) - (if (rmail-summary-exists) - (rmail-select-summary (set-buffer-modified-p nil)))) - -(defun rmail-quit () - "Quit out of RMAIL." - (interactive) - (rmail-expunge-and-save) - ;; Don't switch to the summary buffer even if it was recently visible. - (if rmail-summary-buffer - (progn - (replace-buffer-in-windows rmail-summary-buffer) - (bury-buffer rmail-summary-buffer))) - (let ((obuf (current-buffer))) - (replace-buffer-in-windows obuf) - (bury-buffer obuf))) - -(defun rmail-bury () - "Bury current Rmail buffer and its summary buffer." - (interactive) - ;; This let var was called rmail-buffer, but that interfered - ;; with the buffer-local var used in summary buffers. - (let ((buffer-to-bury (current-buffer))) - (if (rmail-summary-exists) - (let (window) - (while (setq window (get-buffer-window rmail-summary-buffer)) - (set-window-buffer window (other-buffer rmail-summary-buffer))) - (bury-buffer rmail-summary-buffer))) - (switch-to-buffer (other-buffer (current-buffer))) - (bury-buffer buffer-to-bury))) - -(defun rmail-duplicate-message () - "Create a duplicated copy of the current message. -The duplicate copy goes into the Rmail file just after the -original copy." - (interactive) - (widen) - (let ((buffer-read-only nil) - (number rmail-current-message) - (string (buffer-substring (rmail-msgbeg rmail-current-message) - (rmail-msgend rmail-current-message)))) - (goto-char (rmail-msgend rmail-current-message)) - (insert string) - (rmail-forget-messages) - (rmail-show-message number) - (message "Message duplicated"))) - -;;;###autoload -(defun rmail-input (filename) - "Run Rmail on file FILENAME." - (interactive "FRun rmail on RMAIL file: ") - (rmail filename)) - - -;; This used to scan subdirectories recursively, but someone pointed out -;; that if the user wants that, person can put all the files in one dir. -;; And the recursive scan was slow. So I took it out. -;; rms, Sep 1996. -(defun rmail-find-all-files (start) - "Return list of file in dir START that match `rmail-secondary-file-regexp'." - (if (file-accessible-directory-p start) - ;; Don't sort here. - (let* ((case-fold-search t) - (files (directory-files start t rmail-secondary-file-regexp))) - ;; Sort here instead of in directory-files - ;; because this list is usually much shorter. - (sort files 'string<)))) - -(defun rmail-list-to-menu (menu-name l action &optional full-name) - (let ((menu (make-sparse-keymap menu-name))) - (mapcar - (function (lambda (item) - (let (command) - (if (consp item) - (progn - (setq command - (rmail-list-to-menu (car item) (cdr item) - action - (if full-name - (concat full-name "/" - (car item)) - (car item)))) - (setq name (car item))) - (progn - (setq name item) - (setq command - (list 'lambda () '(interactive) - (list action - (expand-file-name - (if full-name - (concat full-name "/" item) - item) - rmail-secondary-file-directory)))))) - (define-key menu (vector (intern name)) - (cons name command))))) - (reverse l)) - menu)) - -;; This command is always "disabled" when it appears in a menu. -(put 'rmail-disable-menu 'menu-enable ''nil) - -(defun rmail-construct-io-menu () - (let ((files (rmail-find-all-files rmail-secondary-file-directory))) - (if files - (progn - (define-key rmail-mode-map [menu-bar classify input-menu] - (cons "Input Rmail File" - (rmail-list-to-menu "Input Rmail File" - files - 'rmail-input))) - (define-key rmail-mode-map [menu-bar classify output-menu] - (cons "Output Rmail File" - (rmail-list-to-menu "Output Rmail File" - files - 'rmail-output-to-rmail-file)))) - - (define-key rmail-mode-map [menu-bar classify input-menu] - '("Input Rmail File" . rmail-disable-menu)) - (define-key rmail-mode-map [menu-bar classify output-menu] - '("Output Rmail File" . rmail-disable-menu))))) - - -;;;; *** Rmail input *** - -;; RLK feature not added in this version: -;; argument specifies inbox file or files in various ways. - -(defun rmail-get-new-mail (&optional file-name) - "Move any new mail from this RMAIL file's inbox files. -The inbox files can be specified with the file's Mail: option. The -variable `rmail-primary-inbox-list' specifies the inboxes for your -primary RMAIL file if it has no Mail: option. By default, this is -your /usr/spool/mail/$USER. - -You can also specify the file to get new mail from. In this case, the -file of new mail is not changed or deleted. Noninteractively, you can -pass the inbox file name as an argument. Interactively, a prefix -argument causes us to read a file name and use that file as the inbox. - -This function runs `rmail-get-new-mail-hook' before saving the updated file. -It returns t if it got any new messages." - (interactive - (list (if current-prefix-arg - (read-file-name "Get new mail from file: ")))) - (run-hooks 'rmail-before-get-new-mail-hook) - ;; If the disk file has been changed from under us, - ;; revert to it before we get new mail. - (or (verify-visited-file-modtime (current-buffer)) - (find-file (buffer-file-name))) - (rmail-maybe-set-message-counters) - (widen) - ;; Get rid of all undo records for this buffer. - (or (eq buffer-undo-list t) - (setq buffer-undo-list nil)) - (let ((all-files (if file-name (list file-name) - rmail-inbox-list))) - (unwind-protect - (while all-files - (let ((opoint (point)) - (new-messages 0) - (delete-files ()) - ;; If buffer has not changed yet, and has not been saved yet, - ;; don't replace the old backup file now. - (make-backup-files (and make-backup-files (buffer-modified-p))) - (buffer-read-only nil) - ;; Don't make undo records for what we do in getting mail. - (buffer-undo-list t) - success - ;; Files to insert this time around. - files - ;; Last names of those files. - file-last-names) - ;; Pull files off all-files onto files - ;; as long as there is no name conflict. - ;; A conflict happens when two inbox file names - ;; have the same last component. - (while (and all-files - (not (member (file-name-nondirectory (car all-files)) - file-last-names))) - (setq files (cons (car all-files) files) - file-last-names - (cons (file-name-nondirectory (car all-files)) files)) - (setq all-files (cdr all-files))) - ;; Put them back in their original order. - (setq files (nreverse files)) - - (goto-char (point-max)) - (skip-chars-backward " \t\n") ; just in case of brain damage - (delete-region (point) (point-max)) ; caused by require-final-newline - (save-excursion - (save-restriction - (narrow-to-region (point) (point)) - ;; Read in the contents of the inbox files, - ;; renaming them as necessary, - ;; and adding to the list of files to delete eventually. - (if file-name - (rmail-insert-inbox-text files nil) - (setq delete-files (rmail-insert-inbox-text files t))) - ;; Scan the new text and convert each message to babyl format. - (goto-char (point-min)) - (unwind-protect - (save-excursion - (setq new-messages (rmail-convert-to-babyl-format) - success t)) - ;; If we could not convert the file's inboxes, - ;; rename the files we tried to read - ;; so we won't over and over again. - (if (and (not file-name) (not success)) - (let ((delfiles delete-files) - (count 0)) - (while delfiles - (while (file-exists-p (format "RMAILOSE.%d" count)) - (setq count (1+ count))) - (rename-file (car delfiles) - (format "RMAILOSE.%d" count)) - (setq delfiles (cdr delfiles)))))) - (or (zerop new-messages) - (let (success) - (widen) - (search-backward "\n\^_" nil t) - (narrow-to-region (point) (point-max)) - (goto-char (1+ (point-min))) - (rmail-count-new-messages) - (run-hooks 'rmail-get-new-mail-hook) - (save-buffer))) - ;; Delete the old files, now that babyl file is saved. - (while delete-files - (condition-case () - ;; First, try deleting. - (condition-case () - (delete-file (car delete-files)) - (file-error - ;; If we can't delete it, truncate it. - (write-region (point) (point) (car delete-files)))) - (file-error nil)) - (setq delete-files (cdr delete-files))))) - (if (= new-messages 0) - (progn (goto-char opoint) - (if (or file-name rmail-inbox-list) - (message "(No new mail has arrived)")) - nil) - (if (rmail-summary-exists) - (rmail-select-summary - (rmail-update-summary))) - (message "%d new message%s read" - new-messages (if (= 1 new-messages) "" "s")) - ;; Move to the first new message - ;; unless we have other unseen messages before it. - (rmail-show-message (rmail-first-unseen-message)) - (run-hooks 'rmail-after-get-new-mail-hook) - t))) - ;; Don't leave the buffer screwed up if we get a disk-full error. - (rmail-show-message)))) - -(defun rmail-insert-inbox-text (files renamep) - ;; Detect a locked file now, so that we avoid moving mail - ;; out of the real inbox file. (That could scare people.) - (or (memq (file-locked-p buffer-file-name) '(nil t)) - (error "RMAIL file %s is locked" - (file-name-nondirectory buffer-file-name))) - (let (file tofile delete-files movemail popmail) - (while files - (setq file (file-truename - (expand-file-name (substitute-in-file-name (car files)))) - tofile (expand-file-name - ;; Generate name to move to from inbox name, - ;; in case of multiple inboxes that need moving. - (concat ".newmail-" (file-name-nondirectory file)) - ;; Use the directory of this rmail file - ;; because it's a nuisance to use the homedir - ;; if that is on a full disk and this rmail - ;; file isn't. - (file-name-directory - (expand-file-name buffer-file-name)))) - ;; Always use movemail to rename the file, - ;; since there can be mailboxes in various directories. - (setq movemail t) -;;; ;; If getting from mail spool directory, -;;; ;; use movemail to move rather than just renaming, -;;; ;; so as to interlock with the mailer. -;;; (setq movemail (string= file -;;; (file-truename -;;; (concat rmail-spool-directory -;;; (file-name-nondirectory file))))) - (setq popmail (string-match "^po:" (file-name-nondirectory file))) - (if popmail (setq file (file-name-nondirectory file) - renamep t)) - (if movemail - (progn - ;; On some systems, /usr/spool/mail/foo is a directory - ;; and the actual inbox is /usr/spool/mail/foo/foo. - (if (file-directory-p file) - (setq file (expand-file-name (user-login-name) - file))))) - (cond (popmail - (if (and rmail-pop-password-required (not rmail-pop-password)) - (setq rmail-pop-password - (rmail-read-passwd - (format "Password for %s: " - (substring file (+ popmail 3)))))) - (if (eq system-type 'windows-nt) - ;; cannot have "po:" in file name - (setq tofile - (expand-file-name - (concat ".newmail-pop-" (substring file (+ popmail 3))) - (file-name-directory - (expand-file-name buffer-file-name))))) - (message "Getting mail from post office ...")) - ((and (file-exists-p tofile) - (/= 0 (nth 7 (file-attributes tofile)))) - (message "Getting mail from %s..." tofile)) - ((and (file-exists-p file) - (/= 0 (nth 7 (file-attributes file)))) - (message "Getting mail from %s..." file))) - ;; Set TOFILE if have not already done so, and - ;; rename or copy the file FILE to TOFILE if and as appropriate. - (cond ((not renamep) - (setq tofile file)) - ((or (file-exists-p tofile) (and (not popmail) - (not (file-exists-p file)))) - nil) - ((and (not movemail) (not popmail)) - ;; Try copying. If that fails (perhaps no space), - ;; rename instead. - (condition-case nil - (copy-file file tofile nil) - (error - ;; Third arg is t so we can replace existing file TOFILE. - (rename-file file tofile t))) - ;; Make the real inbox file empty. - ;; Leaving it deleted could cause lossage - ;; because mailers often won't create the file. - (condition-case () - (write-region (point) (point) file) - (file-error nil))) - (t - (let ((errors nil)) - (unwind-protect - (save-excursion - (setq errors (generate-new-buffer " *rmail loss*")) - (buffer-disable-undo errors) - (if rmail-pop-password - (call-process - (or rmail-movemail-program - (expand-file-name "movemail" exec-directory)) - nil errors nil file tofile rmail-pop-password) - (call-process - (or rmail-movemail-program - (expand-file-name "movemail" exec-directory)) - nil errors nil file tofile)) - (if (not (buffer-modified-p errors)) - ;; No output => movemail won - nil - (set-buffer errors) - (subst-char-in-region (point-min) (point-max) - ?\n ?\ ) - (goto-char (point-max)) - (skip-chars-backward " \t") - (delete-region (point) (point-max)) - (goto-char (point-min)) - (if (looking-at "movemail: ") - (delete-region (point-min) (match-end 0))) - (beep t) - (message "movemail: %s" - (buffer-substring (point-min) - (point-max))) - (sit-for 3) - nil)) - (if errors (kill-buffer errors)))))) - ;; At this point, TOFILE contains the name to read: - ;; Either the alternate name (if we renamed) - ;; or the actual inbox (if not renaming). - (if (file-exists-p tofile) - (let (size) - (goto-char (point-max)) - (setq size (nth 1 (insert-file-contents tofile))) - (goto-char (point-max)) - (or (= (preceding-char) ?\n) - (zerop size) - (insert ?\n)) - (setq delete-files (cons tofile delete-files)))) - (message "") - (setq files (cdr files))) - delete-files)) - -(defun rmail-read-passwd (prompt &optional default) - "Read a password, echoing `.' for each character typed. -End with RET, LFD, or ESC. DEL or C-h rubs out. C-u kills line. -Optional DEFAULT is password to start with." - (let ((pass (if default default "")) - (c 0) - (echo-keystrokes 0) - (cursor-in-echo-area t)) - (while (progn (message "%s%s" - prompt - (make-string (length pass) ?.)) - (setq c (read-char)) - (and (/= c ?\r) (/= c ?\n) (/= c ?\e))) - (if (= c ?\C-u) - (setq pass "") - (if (and (/= c ?\b) (/= c ?\177)) - (setq pass (concat pass (char-to-string c))) - (if (> (length pass) 0) - (setq pass (substring pass 0 -1)))))) - (message "") - (message nil) - pass)) - -;; the rmail-break-forwarded-messages feature is not implemented -(defun rmail-convert-to-babyl-format () - (let ((count 0) start - (case-fold-search nil) - (invalid-input-resync - (function (lambda () - (message "Invalid Babyl format in inbox!") - (sit-for 3) - ;; Try to get back in sync with a real message. - (if (re-search-forward - (concat mmdf-delim1 "\\|^From") nil t) - (beginning-of-line) - (goto-char (point-max))))))) - (goto-char (point-min)) - (save-restriction - (while (not (eobp)) - (cond ((looking-at "BABYL OPTIONS:");Babyl header - (if (search-forward "\n\^_" nil t) - ;; If we find the proper terminator, delete through there. - (delete-region (point-min) (point)) - (funcall invalid-input-resync) - (delete-region (point-min) (point)))) - ;; Babyl format message - ((looking-at "\^L") - (or (search-forward "\n\^_" nil t) - (funcall invalid-input-resync)) - (setq count (1+ count)) - ;; Make sure there is no extra white space after the ^_ - ;; at the end of the message. - ;; Narrowing will make sure that whatever follows the junk - ;; will be treated properly. - (delete-region (point) - (save-excursion - (skip-chars-forward " \t\n") - (point))) - (narrow-to-region (point) (point-max))) - ;;*** MMDF format - ((let ((case-fold-search t)) - (looking-at mmdf-delim1)) - (let ((case-fold-search t)) - (replace-match "\^L\n0, unseen,,\n*** EOOH ***\n") - (setq start (point)) - (re-search-forward mmdf-delim2 nil t) - (replace-match "\^_")) - (save-excursion - (save-restriction - (narrow-to-region start (1- (point))) - (goto-char (point-min)) - (while (search-forward "\n\^_" nil t); single char "\^_" - (replace-match "\n^_")))); 2 chars: "^" and "_" - (narrow-to-region (point) (point-max)) - (setq count (1+ count))) - ;;*** Mail format - ((looking-at "^From ") - (setq start (point)) - (insert "\^L\n0, unseen,,\n*** EOOH ***\n") - (rmail-nuke-pinhead-header) - ;; If this message has a Content-Length field, - ;; skip to the end of the contents. - (let* ((header-end (save-excursion - (and (re-search-forward "\n\n" nil t) - (1- (point))))) - (case-fold-search t) - (size - ;; Get the numeric value from the Content-Length field. - (save-excursion - ;; Back up to end of prev line, - ;; in case the Content-Length field comes first. - (forward-char -1) - (and (search-forward "\ncontent-length: " - header-end t) - (let ((beg (point)) - (eol (progn (end-of-line) (point)))) - (string-to-int (buffer-substring beg eol))))))) - (and size - (if (and (natnump size) - (<= (+ header-end size) (point-max)) - ;; Make sure this would put us at a position - ;; that we could continue from. - (save-excursion - (goto-char (+ header-end size)) - (skip-chars-forward "\n") - (or (eobp) - (and (looking-at "BABYL OPTIONS:") - (search-forward "\n\^_" nil t)) - (and (looking-at "\^L") - (search-forward "\n\^_" nil t)) - (let ((case-fold-search t)) - (looking-at mmdf-delim1)) - (looking-at "From ")))) - (goto-char (+ header-end size)) - (message "Ignoring invalid Content-Length field") - (sit-for 1 0 t)))) - - (if (re-search-forward - (concat "^[\^_]?\\(" - rmail-unix-mail-delimiter - "\\|" - mmdf-delim1 "\\|" - "^BABYL OPTIONS:\\|" - "\^L\n[01],\\)") nil t) - (goto-char (match-beginning 1)) - (goto-char (point-max))) - (setq count (1+ count)) - (save-excursion - (save-restriction - (narrow-to-region start (point)) - (goto-char (point-min)) - (while (search-forward "\n\^_" nil t); single char - (replace-match "\n^_")))); 2 chars: "^" and "_" - (insert ?\^_) - (narrow-to-region (point) (point-max))) - ;; - ;; This kludge is because some versions of sendmail.el - ;; insert an extra newline at the beginning that shouldn't - ;; be there. sendmail.el has been fixed, but old versions - ;; may still be in use. -- rms, 7 May 1993. - ((eolp) (delete-char 1)) - (t (error "Cannot convert to babyl format"))))) - count)) - -;; Delete the "From ..." line, creating various other headers with -;; information from it if they don't already exist. Now puts the -;; original line into a mail-from: header line for debugging and for -;; use by the rmail-output function. -(defun rmail-nuke-pinhead-header () - (save-excursion - (save-restriction - (let ((start (point)) - (end (progn - (condition-case () - (search-forward "\n\n") - (error - (goto-char (point-max)) - (insert "\n\n"))) - (point))) - has-from has-date) - (narrow-to-region start end) - (let ((case-fold-search t)) - (goto-char start) - (setq has-from (search-forward "\nFrom:" nil t)) - (goto-char start) - (setq has-date (and (search-forward "\nDate:" nil t) (point))) - (goto-char start)) - (let ((case-fold-search nil)) - (if (re-search-forward (concat "^" rmail-unix-mail-delimiter) nil t) - (replace-match - (concat - "Mail-from: \\&" - ;; Keep and reformat the date if we don't - ;; have a Date: field. - (if has-date - "" - (concat - "Date: \\2, \\4 \\3 \\9 \\5 " - - ;; The timezone could be matched by group 7 or group 10. - ;; If neither of them matched, assume EST, since only - ;; Easterners would be so sloppy. - ;; It's a shame the substitution can't use "\\10". - (cond - ((/= (match-beginning 7) (match-end 7)) "\\7") - ((/= (match-beginning 10) (match-end 10)) - (buffer-substring (match-beginning 10) - (match-end 10))) - (t "EST")) - "\n")) - ;; Keep and reformat the sender if we don't - ;; have a From: field. - (if has-from - "" - "From: \\1\n")) - t))))))) - -;;;; *** Rmail Message Formatting and Header Manipulation *** - -(defun rmail-reformat-message (beg end) - (goto-char beg) - (forward-line 1) - (if (/= (following-char) ?0) - (error "Bad format in RMAIL file.")) - (let ((buffer-read-only nil) - (delta (- (buffer-size) end))) - (delete-char 1) - (insert ?1) - (forward-line 1) - (let ((case-fold-search t)) - (while (looking-at "Summary-line:\\|Mail-From:") - (forward-line 1))) - (if (looking-at "\\*\\*\\* EOOH \\*\\*\\*\n") - (delete-region (point) - (progn (forward-line 1) (point)))) - (let ((str (buffer-substring (point) - (save-excursion (search-forward "\n\n" end 'move) - (point))))) - (insert str "*** EOOH ***\n") - (narrow-to-region (point) (- (buffer-size) delta))) - (goto-char (point-min)) - (if rmail-message-filter (funcall rmail-message-filter)) - (if (or rmail-displayed-headers rmail-ignored-headers) - (rmail-clear-headers)))) - -(defun rmail-clear-headers (&optional ignored-headers) - "Delete all header fields that Rmail should not show. -If the optional argument IGNORED-HEADERS is non-nil, -delete all header fields whose names match that regexp. -Otherwise, if `rmail-displayed-headers' is non-nil, -delete all header fields *except* those whose names match that regexp. -Otherwise, delete all header fields whose names match `rmail-ignored-headers'." - (if (search-forward "\n\n" nil t) - (let ((case-fold-search t) - (buffer-read-only nil)) - (if (and rmail-displayed-headers (null ignored-headers)) - (save-restriction - (narrow-to-region (point-min) (point)) - (let (lim) - (goto-char (point-min)) - (while (save-excursion - (re-search-forward "\n[^ \t]") - (and (not (eobp)) - (setq lim (1- (point))))) - (if (save-excursion - (re-search-forward rmail-displayed-headers lim t)) - (goto-char lim) - (delete-region (point) lim)))) - (goto-char (point-min))) - (or ignored-headers (setq ignored-headers rmail-ignored-headers)) - (save-restriction - (narrow-to-region (point-min) (point)) - (while (progn - (goto-char (point-min)) - (re-search-forward ignored-headers nil t)) - (beginning-of-line) - (delete-region (point) - (progn (re-search-forward "\n[^ \t]") - (1- (point)))))))))) - -(defun rmail-msg-is-pruned () - (rmail-maybe-set-message-counters) - (save-restriction - (save-excursion - (narrow-to-region (rmail-msgbeg rmail-current-message) (point-max)) - (goto-char (point-min)) - (forward-line 1) - (= (following-char) ?1)))) - -(defun rmail-toggle-header (&optional arg) - "Show original message header if pruned header currently shown, or vice versa. -With argument ARG, show the message header pruned if ARG is greater than zero; -otherwise, show it in full." - (interactive "P") - (let* ((buffer-read-only nil) - (pruned (rmail-msg-is-pruned)) - (prune (if arg - (> (prefix-numeric-value arg) 0) - (not pruned)))) - (if (eq pruned prune) - t - (rmail-maybe-set-message-counters) - (narrow-to-region (rmail-msgbeg rmail-current-message) (point-max)) - (if pruned - (progn (goto-char (point-min)) - (forward-line 1) - (delete-char 1) - (insert ?0) - (forward-line 1) - (let ((case-fold-search t)) - (while (looking-at "Summary-Line:\\|Mail-From:") - (forward-line 1))) - (insert "*** EOOH ***\n") - (forward-char -1) - (search-forward "\n*** EOOH ***\n") - (forward-line -1) - (let ((temp (point))) - (and (search-forward "\n\n" nil t) - (delete-region temp (point)))) - (goto-char (point-min)) - (search-forward "\n*** EOOH ***\n") - (narrow-to-region (point) (point-max))) - (rmail-reformat-message (point-min) (point-max))) - (rmail-highlight-headers)))) - -;;;; *** Rmail Attributes and Keywords *** - -;; Make a string describing current message's attributes and keywords -;; and set it up as the name of a minor mode -;; so it will appear in the mode line. -(defun rmail-display-labels () - (let ((blurb "") (beg (point-min-marker)) (end (point-max-marker))) - (save-excursion - (unwind-protect - (progn - (widen) - (goto-char (rmail-msgbeg rmail-current-message)) - (forward-line 1) - (if (looking-at "[01],") - (progn - (narrow-to-region (point) (progn (end-of-line) (point))) - ;; Truly valid BABYL format requires a space before each - ;; attribute or keyword name. Put them in if missing. - (let (buffer-read-only) - (goto-char (point-min)) - (while (search-forward "," nil t) - (or (looking-at "[ ,]") (eobp) - (insert " ")))) - (goto-char (point-max)) - (if (search-backward ",," nil 'move) - (progn - (if (> (point) (1+ (point-min))) - (setq blurb (buffer-substring (+ 1 (point-min)) (point)))) - (if (> (- (point-max) (point)) 2) - (setq blurb - (concat blurb - ";" - (buffer-substring (+ (point) 3) - (1- (point-max))))))))))) - ;; Note: we don't use save-restriction because that does not work right - ;; if changes are made outside the saved restriction - ;; before that restriction is restored. - (narrow-to-region beg end) - (set-marker beg nil) - (set-marker end nil))) - (while (string-match " +," blurb) - (setq blurb (concat (substring blurb 0 (match-beginning 0)) "," - (substring blurb (match-end 0))))) - (while (string-match ", +" blurb) - (setq blurb (concat (substring blurb 0 (match-beginning 0)) "," - (substring blurb (match-end 0))))) - (setq mode-line-process - (format " %d/%d%s" - rmail-current-message rmail-total-messages blurb)))) - -;; Turn an attribute of a message on or off according to STATE. -;; ATTR is the name of the attribute, as a string. -;; MSGNUM is message number to change; nil means current message. -(defun rmail-set-attribute (attr state &optional msgnum) - (let ((omax (point-max-marker)) - (omin (point-min-marker)) - (buffer-read-only nil)) - (or msgnum (setq msgnum rmail-current-message)) - (if (> msgnum 0) - (unwind-protect - (save-excursion - (widen) - (goto-char (+ 3 (rmail-msgbeg msgnum))) - (let ((curstate - (not - (null (search-backward (concat ", " attr ",") - (prog1 (point) (end-of-line)) t))))) - (or (eq curstate (not (not state))) - (if curstate - (delete-region (point) (1- (match-end 0))) - (beginning-of-line) - (forward-char 2) - (insert " " attr ",")))) - (if (string= attr "deleted") - (rmail-set-message-deleted-p msgnum state))) - ;; Note: we don't use save-restriction because that does not work right - ;; if changes are made outside the saved restriction - ;; before that restriction is restored. - (narrow-to-region omin omax) - (set-marker omin nil) - (set-marker omax nil) - (if (= msgnum rmail-current-message) - (rmail-display-labels)))))) - -;; Return t if the attributes/keywords line of msg number MSG -;; contains a match for the regexp LABELS. -(defun rmail-message-labels-p (msg labels) - (save-excursion - (save-restriction - (widen) - (goto-char (rmail-msgbeg msg)) - (forward-char 3) - (re-search-backward labels (prog1 (point) (end-of-line)) t)))) - -;;;; *** Rmail Message Selection And Support *** - -(defun rmail-msgend (n) - (marker-position (aref rmail-message-vector (1+ n)))) - -(defun rmail-msgbeg (n) - (marker-position (aref rmail-message-vector n))) - -(defun rmail-widen-to-current-msgbeg (function) - "Call FUNCTION with point at start of internal data of current message. -Assumes that bounds were previously narrowed to display the message in Rmail. -The bounds are widened enough to move point where desired, then narrowed -again afterward. - -FUNCTION may not change the visible text of the message, but it may -change the invisible header text." - (save-excursion - (let ((obeg (- (point-max) (point-min)))) - (unwind-protect - (progn - (narrow-to-region (rmail-msgbeg rmail-current-message) - (point-max)) - (goto-char (point-min)) - (funcall function)) - ;; Note: we don't use save-restriction because that does not work right - ;; if changes are made outside the saved restriction - ;; before that restriction is restored. - ;; Here we assume that changes made by FUNCTION - ;; occur before the visible region of the message. - (narrow-to-region (- (point-max) obeg) (point-max)))))) - -(defun rmail-forget-messages () - (unwind-protect - (if (vectorp rmail-message-vector) - (let* ((i 0) - (v rmail-message-vector) - (n (length v))) - (while (< i n) - (move-marker (aref v i) nil) - (setq i (1+ i))))) - (setq rmail-message-vector nil) - (setq rmail-deleted-vector nil))) - -(defun rmail-maybe-set-message-counters () - (if (not (and rmail-deleted-vector - rmail-message-vector - rmail-current-message - rmail-total-messages)) - (rmail-set-message-counters))) - -(defun rmail-count-new-messages (&optional nomsg) - (let* ((case-fold-search nil) - (total-messages 0) - (messages-head nil) - (deleted-head nil)) - (or nomsg (message "Counting new messages...")) - (goto-char (point-max)) - ;; Put at the end of messages-head - ;; the entry for message N+1, which marks - ;; the end of message N. (N = number of messages). - (search-backward "\n\^_") - (forward-char 1) - (setq messages-head (list (point-marker))) - (rmail-set-message-counters-counter (point-min)) - (setq rmail-current-message (1+ rmail-total-messages)) - (setq rmail-total-messages - (+ rmail-total-messages total-messages)) - (setq rmail-message-vector - (vconcat rmail-message-vector (cdr messages-head))) - (aset rmail-message-vector - rmail-current-message (car messages-head)) - (setq rmail-deleted-vector - (concat rmail-deleted-vector deleted-head)) - (setq rmail-summary-vector - (vconcat rmail-summary-vector (make-vector total-messages nil))) - (goto-char (point-min)) - (or nomsg (message "Counting new messages...done (%d)" total-messages)))) - -(defun rmail-set-message-counters () - (rmail-forget-messages) - (save-excursion - (save-restriction - (widen) - (let* ((point-save (point)) - (total-messages 0) - (messages-after-point) - (case-fold-search nil) - (messages-head nil) - (deleted-head nil)) - (message "Counting messages...") - (goto-char (point-max)) - ;; Put at the end of messages-head - ;; the entry for message N+1, which marks - ;; the end of message N. (N = number of messages). - (search-backward "\n\^_" nil t) - (if (/= (point) (point-max)) (forward-char 1)) - (setq messages-head (list (point-marker))) - (rmail-set-message-counters-counter (min (point) point-save)) - (setq messages-after-point total-messages) - (rmail-set-message-counters-counter) - (setq rmail-total-messages total-messages) - (setq rmail-current-message - (min total-messages - (max 1 (- total-messages messages-after-point)))) - (setq rmail-message-vector - (apply 'vector (cons (point-min-marker) messages-head)) - rmail-deleted-vector (concat "D" deleted-head) - rmail-summary-vector (make-vector rmail-total-messages nil)) - (message "Counting messages...done"))))) - -(defun rmail-set-message-counters-counter (&optional stop) - (while (search-backward "\n\^_\^L\n" stop t) - (forward-char 1) - (setq messages-head (cons (point-marker) messages-head)) - (save-excursion - (setq deleted-head - (cons (if (search-backward ", deleted," - (prog1 (point) - (forward-line 2)) - t) - ?D ?\ ) - deleted-head))) - (if (zerop (% (setq total-messages (1+ total-messages)) 20)) - (message "Counting messages...%d" total-messages)))) - -(defun rmail-beginning-of-message () - "Show current message starting from the beginning." - (interactive) - (rmail-show-message rmail-current-message)) - -(defun rmail-show-message (&optional n no-summary) - "Show message number N (prefix argument), counting from start of file. -If summary buffer is currently displayed, update current message there also." - (interactive "p") - (rmail-maybe-set-message-counters) - (widen) - (if (zerop rmail-total-messages) - (progn (narrow-to-region (point-min) (1- (point-max))) - (goto-char (point-min)) - (setq mode-line-process nil)) - (let (blurb) - (if (not n) - (setq n rmail-current-message) - (cond ((<= n 0) - (setq n 1 - rmail-current-message 1 - blurb "No previous message")) - ((> n rmail-total-messages) - (setq n rmail-total-messages - rmail-current-message rmail-total-messages - blurb "No following message")) - (t - (setq rmail-current-message n)))) - (let ((beg (rmail-msgbeg n))) - (goto-char beg) - (forward-line 1) - ;; Clear the "unseen" attribute when we show a message. - (rmail-set-attribute "unseen" nil) - ;; Reformat the header, or else find the reformatted header. - (let ((end (rmail-msgend n))) - (if (= (following-char) ?0) - (rmail-reformat-message beg end) - (search-forward "\n*** EOOH ***\n" end t) - (narrow-to-region (point) end))) - (goto-char (point-min)) - (rmail-display-labels) - (rmail-highlight-headers) - (if transient-mark-mode (deactivate-mark)) - (run-hooks 'rmail-show-message-hook) - ;; If there is a summary buffer, try to move to this message - ;; in that buffer. But don't complain if this message - ;; is not mentioned in the summary. - ;; Don't do this at all if we were called on behalf - ;; of cursor motion in the summary buffer. - (and (rmail-summary-exists) (not no-summary) - (let ((curr-msg rmail-current-message)) - (rmail-select-summary - (rmail-summary-goto-msg curr-msg t t)))) - (if blurb - (message blurb)))))) - -;; Find all occurrences of certain fields, and highlight them. -(defun rmail-highlight-headers () - ;; Do this only if the system supports faces. - (if (and (fboundp 'internal-find-face) - rmail-highlighted-headers) - (save-excursion - (search-forward "\n\n" nil 'move) - (save-restriction - (narrow-to-region (point-min) (point)) - (let ((case-fold-search t) - (inhibit-read-only t) - ;; Highlight with boldface if that is available. - ;; Otherwise use the `highlight' face. - (face (or rmail-highlight-face - (if (face-differs-from-default-p 'bold) - 'bold 'highlight))) - ;; List of overlays to reuse. - (overlays rmail-overlay-list)) - (goto-char (point-min)) - (while (re-search-forward rmail-highlighted-headers nil t) - (skip-chars-forward " \t") - (let ((beg (point)) - overlay) - (while (progn (forward-line 1) - (looking-at "[ \t]"))) - ;; Back up over newline, then trailing spaces or tabs - (forward-char -1) - (while (member (preceding-char) '(? ?\t)) - (forward-char -1)) - (if overlays - ;; Reuse an overlay we already have. - (progn - (setq overlay (car overlays) - overlays (cdr overlays)) - (overlay-put overlay 'face face) - (move-overlay overlay beg (point))) - ;; Make a new overlay and add it to - ;; rmail-overlay-list. - (setq overlay (make-overlay beg (point))) - (overlay-put overlay 'face face) - (setq rmail-overlay-list - (cons overlay rmail-overlay-list)))))))))) - -(defun rmail-next-message (n) - "Show following message whether deleted or not. -With prefix arg N, moves forward N messages, or backward if N is negative." - (interactive "p") - (rmail-maybe-set-message-counters) - (rmail-show-message (+ rmail-current-message n))) - -(defun rmail-previous-message (n) - "Show previous message whether deleted or not. -With prefix arg N, moves backward N messages, or forward if N is negative." - (interactive "p") - (rmail-next-message (- n))) - -(defun rmail-next-undeleted-message (n) - "Show following non-deleted message. -With prefix arg N, moves forward N non-deleted messages, -or backward if N is negative. - -Returns t if a new message is being shown, nil otherwise." - (interactive "p") - (rmail-maybe-set-message-counters) - (let ((lastwin rmail-current-message) - (current rmail-current-message)) - (while (and (> n 0) (< current rmail-total-messages)) - (setq current (1+ current)) - (if (not (rmail-message-deleted-p current)) - (setq lastwin current n (1- n)))) - (while (and (< n 0) (> current 1)) - (setq current (1- current)) - (if (not (rmail-message-deleted-p current)) - (setq lastwin current n (1+ n)))) - (if (/= lastwin rmail-current-message) - (progn (rmail-show-message lastwin) - t) - (if (< n 0) - (message "No previous nondeleted message")) - (if (> n 0) - (message "No following nondeleted message")) - nil))) - -(defun rmail-previous-undeleted-message (n) - "Show previous non-deleted message. -With prefix argument N, moves backward N non-deleted messages, -or forward if N is negative." - (interactive "p") - (rmail-next-undeleted-message (- n))) - -(defun rmail-first-message () - "Show first message in file." - (interactive) - (rmail-maybe-set-message-counters) - (rmail-show-message 1)) - -(defun rmail-last-message () - "Show last message in file." - (interactive) - (rmail-maybe-set-message-counters) - (rmail-show-message rmail-total-messages)) - -(defun rmail-what-message () - (let ((where (point)) - (low 1) - (high rmail-total-messages) - (mid (/ rmail-total-messages 2))) - (while (> (- high low) 1) - (if (>= where (rmail-msgbeg mid)) - (setq low mid) - (setq high mid)) - (setq mid (+ low (/ (- high low) 2)))) - (if (>= where (rmail-msgbeg high)) high low))) - -(defun rmail-message-recipients-p (msg recipients &optional primary-only) - (save-restriction - (goto-char (rmail-msgbeg msg)) - (search-forward "\n*** EOOH ***\n") - (narrow-to-region (point) (progn (search-forward "\n\n") (point))) - (or (string-match recipients (or (mail-fetch-field "To") "")) - (string-match recipients (or (mail-fetch-field "From") "")) - (if (not primary-only) - (string-match recipients (or (mail-fetch-field "Cc") "")))))) - -(defun rmail-message-regexp-p (msg regexp) - "Return t, if for message number MSG, regexp REGEXP matches in the header." - (goto-char (rmail-msgbeg msg)) - (let ((end - (save-excursion - (search-forward "*** EOOH ***" (point-max)) (point)))) - (re-search-forward regexp end t))) - -(defvar rmail-search-last-regexp nil) -(defun rmail-search (regexp &optional n) - "Show message containing next match for REGEXP (but not the current msg). -Prefix argument gives repeat count; negative argument means search -backwards (through earlier messages). -Interactively, empty argument means use same regexp used last time." - (interactive - (let* ((reversep (< (prefix-numeric-value current-prefix-arg) 0)) - (prompt - (concat (if reversep "Reverse " "") "Rmail search (regexp): ")) - regexp) - (if rmail-search-last-regexp - (setq prompt (concat prompt - "(default " - rmail-search-last-regexp - ") "))) - (setq regexp (read-string prompt)) - (cond ((not (equal regexp "")) - (setq rmail-search-last-regexp regexp)) - ((not rmail-search-last-regexp) - (error "No previous Rmail search string"))) - (list rmail-search-last-regexp - (prefix-numeric-value current-prefix-arg)))) - (or n (setq n 1)) - (message "%sRmail search for %s..." - (if (< n 0) "Reverse " "") - regexp) - (rmail-maybe-set-message-counters) - (let ((omin (point-min)) - (omax (point-max)) - (opoint (point)) - win - (reversep (< n 0)) - (msg rmail-current-message)) - (unwind-protect - (progn - (widen) - (while (/= n 0) - ;; Check messages one by one, advancing message number up or down - ;; but searching forward through each message. - (if reversep - (while (and (null win) (> msg 1)) - (goto-char (rmail-msgbeg (setq msg (1- msg)))) - (setq win (re-search-forward - regexp (rmail-msgend msg) t))) - (while (and (null win) (< msg rmail-total-messages)) - (goto-char (rmail-msgbeg (setq msg (1+ msg)))) - (setq win (re-search-forward regexp (rmail-msgend msg) t)))) - (setq n (+ n (if reversep 1 -1))))) - (if win - (progn - ;; If this is a reverse search and we found a message, - ;; search backward thru this message to position point. - (if reversep - (progn - (goto-char (rmail-msgend msg)) - (re-search-backward - regexp (rmail-msgbeg msg) t))) - (setq win (point)) - (rmail-show-message msg) - (message "%sRmail search for %s...done" - (if reversep "Reverse " "") - regexp) - (goto-char win)) - (goto-char opoint) - (narrow-to-region omin omax) - (ding) - (message "Search failed: %s" regexp))))) - -(defun rmail-search-backwards (regexp &optional n) - "Show message containing previous match for REGEXP. -Prefix argument gives repeat count; negative argument means search -forward (through later messages). -Interactively, empty argument means use same regexp used last time." - (interactive - (let* ((reversep (>= (prefix-numeric-value current-prefix-arg) 0)) - (prompt - (concat (if reversep "Reverse " "") "Rmail search (regexp): ")) - regexp) - (if rmail-search-last-regexp - (setq prompt (concat prompt - "(default " - rmail-search-last-regexp - ") "))) - (setq regexp (read-string prompt)) - (cond ((not (equal regexp "")) - (setq rmail-search-last-regexp regexp)) - ((not rmail-search-last-regexp) - (error "No previous Rmail search string"))) - (list rmail-search-last-regexp - (prefix-numeric-value current-prefix-arg)))) - (rmail-search regexp (- (or n 1)))) - -;; Show the first message which has the `unseen' attribute. -(defun rmail-first-unseen-message () - (rmail-maybe-set-message-counters) - (let ((current 1) - found) - (save-restriction - (widen) - (while (and (not found) (<= current rmail-total-messages)) - (if (rmail-message-labels-p current ", ?\\(unseen\\),") - (setq found current)) - (setq current (1+ current)))) -;; Let the caller show the message. -;; (if found -;; (rmail-show-message found)) - found)) - -(defun rmail-next-same-subject (n) - "Go to the next mail message having the same subject header. -With prefix argument N, do this N times. -If N is negative, go backwards instead." - (interactive "p") - (let ((subject (mail-fetch-field "Subject")) - (forward (> n 0)) - (i rmail-current-message) - search-regexp found) - (if (string-match "Re:[ \t]*" subject) - (setq subject (substring subject (match-end 0)))) - (setq search-regexp (concat "^Subject: *\\(Re: *\\)?" - (regexp-quote subject) - "\n")) - (save-excursion - (save-restriction - (widen) - (while (and (/= n 0) - (if forward - (< i rmail-total-messages) - (> i 1))) - (let (done) - (while (and (not done) - (if forward - (< i rmail-total-messages) - (> i 1))) - (setq i (if forward (1+ i) (1- i))) - (goto-char (rmail-msgbeg i)) - (search-forward "\n*** EOOH ***\n") - (let ((beg (point)) end) - (search-forward "\n\n") - (setq end (point)) - (goto-char beg) - (setq done (re-search-forward search-regexp end t)))) - (if done (setq found i))) - (setq n (if forward (1- n) (1+ n)))))) - (if found - (rmail-show-message found) - (error "No %s message with same subject" - (if forward "following" "previous"))))) - -(defun rmail-previous-same-subject (n) - "Go to the previous mail message having the same subject header. -With prefix argument N, do this N times. -If N is negative, go forwards instead." - (interactive "p") - (rmail-next-same-subject (- n))) - -;;;; *** Rmail Message Deletion Commands *** - -(defun rmail-message-deleted-p (n) - (= (aref rmail-deleted-vector n) ?D)) - -(defun rmail-set-message-deleted-p (n state) - (aset rmail-deleted-vector n (if state ?D ?\ ))) - -(defun rmail-delete-message () - "Delete this message and stay on it." - (interactive) - (rmail-set-attribute "deleted" t) - (run-hooks 'rmail-delete-message-hook)) - -(defun rmail-undelete-previous-message () - "Back up to deleted message, select it, and undelete it." - (interactive) - (let ((msg rmail-current-message)) - (while (and (> msg 0) - (not (rmail-message-deleted-p msg))) - (setq msg (1- msg))) - (if (= msg 0) - (error "No previous deleted message") - (if (/= msg rmail-current-message) - (rmail-show-message msg)) - (rmail-set-attribute "deleted" nil) - (if (rmail-summary-exists) - (save-excursion - (set-buffer rmail-summary-buffer) - (rmail-summary-mark-undeleted msg))) - (rmail-maybe-display-summary)))) - -(defun rmail-delete-forward (&optional backward) - "Delete this message and move to next nondeleted one. -Deleted messages stay in the file until the \\[rmail-expunge] command is given. -With prefix argument, delete and move backward. - -Returns t if a new message is displayed after the delete, or nil otherwise." - (interactive "P") - (rmail-set-attribute "deleted" t) - (run-hooks 'rmail-delete-message-hook) - (let ((del-msg rmail-current-message)) - (if (rmail-summary-exists) - (rmail-select-summary - (rmail-summary-mark-deleted del-msg))) - (prog1 (rmail-next-undeleted-message (if backward -1 1)) - (rmail-maybe-display-summary)))) - -(defun rmail-delete-backward () - "Delete this message and move to previous nondeleted one. -Deleted messages stay in the file until the \\[rmail-expunge] command is given." - (interactive) - (rmail-delete-forward t)) - -;; Compute the message number a given message would have after expunging. -;; The present number of the message is OLDNUM. -;; DELETEDVEC should be rmail-deleted-vector. -;; The value is nil for a message that would be deleted. -(defun rmail-msg-number-after-expunge (deletedvec oldnum) - (if (or (null oldnum) (= (aref deletedvec oldnum) ?D)) - nil - (let ((i 0) - (newnum 0)) - (while (< i oldnum) - (if (/= (aref deletedvec i) ?D) - (setq newnum (1+ newnum))) - (setq i (1+ i))) - newnum))) - -(defun rmail-only-expunge () - "Actually erase all deleted messages in the file." - (interactive) - (message "Expunging deleted messages...") - ;; Discard all undo records for this buffer. - (or (eq buffer-undo-list t) - (setq buffer-undo-list nil)) - (rmail-maybe-set-message-counters) - (let* ((omax (- (buffer-size) (point-max))) - (omin (- (buffer-size) (point-min))) - (opoint (if (and (> rmail-current-message 0) - (rmail-message-deleted-p rmail-current-message)) - 0 - (- (point) (point-min)))) - (messages-head (cons (aref rmail-message-vector 0) nil)) - (messages-tail messages-head) - ;; Don't make any undo records for the expunging. - (buffer-undo-list t) - (win)) - (unwind-protect - (save-excursion - (widen) - (goto-char (point-min)) - (let ((counter 0) - (number 1) - (total rmail-total-messages) - (new-message-number rmail-current-message) - (new-summary nil) - (rmailbuf (current-buffer)) - (buffer-read-only nil) - (messages rmail-message-vector) - (deleted rmail-deleted-vector) - (summary rmail-summary-vector)) - (setq rmail-total-messages nil - rmail-current-message nil - rmail-message-vector nil - rmail-deleted-vector nil - rmail-summary-vector nil) - - ;; Find each sendmail buffer that is set to reply - ;; to a message in this buffer, and update its - ;; message number. - (let ((bufs (buffer-list))) - (while bufs - (save-excursion - (set-buffer (car bufs)) - (and (boundp 'rmail-send-actions-rmail-buffer) - (eq rmail-send-actions-rmail-buffer rmailbuf) - (setq rmail-send-actions-rmail-msg-number - (rmail-msg-number-after-expunge - deleted - rmail-send-actions-rmail-msg-number)))) - (setq bufs (cdr bufs)))) - - (while (<= number total) - (if (= (aref deleted number) ?D) - (progn - (delete-region - (marker-position (aref messages number)) - (marker-position (aref messages (1+ number)))) - (move-marker (aref messages number) nil) - (if (> new-message-number counter) - (setq new-message-number (1- new-message-number)))) - (setq counter (1+ counter)) - (setq messages-tail - (setcdr messages-tail - (cons (aref messages number) nil))) - (setq new-summary - (cons (if (= counter number) (aref summary (1- number))) - new-summary))) - (if (zerop (% (setq number (1+ number)) 20)) - (message "Expunging deleted messages...%d" number))) - (setq messages-tail - (setcdr messages-tail - (cons (aref messages number) nil))) - (setq rmail-current-message new-message-number - rmail-total-messages counter - rmail-message-vector (apply 'vector messages-head) - rmail-deleted-vector (make-string (1+ counter) ?\ ) - rmail-summary-vector (vconcat (nreverse new-summary)) - win t))) - (message "Expunging deleted messages...done") - (if (not win) - (narrow-to-region (- (buffer-size) omin) (- (buffer-size) omax))) - (rmail-show-message - (if (zerop rmail-current-message) 1 nil)) - (forward-char opoint)))) - -(defun rmail-expunge () - "Erase deleted messages from Rmail file and summary buffer." - (interactive) - (rmail-only-expunge) - (if (rmail-summary-exists) - (rmail-select-summary - (rmail-update-summary)))) - -;;;; *** Rmail Mailing Commands *** - -(defun rmail-start-mail (&optional noerase to subject in-reply-to cc - replybuffer sendactions same-window others) - (let (yank-action) - (if replybuffer - (setq yank-action (list 'insert-buffer replybuffer))) - (setq others (cons (cons "cc" cc) others)) - (setq others (cons (cons "in-reply-to" in-reply-to) others)) - (if same-window - (compose-mail to subject others - noerase nil - yank-action sendactions) - (if (and window-system rmail-mail-new-frame) - (prog1 - (compose-mail to subject others - noerase 'switch-to-buffer-other-frame - yank-action sendactions) - ;; This is not a standard frame parameter; - ;; nothing except sendmail.el looks at it. - (modify-frame-parameters (selected-frame) - '((mail-dedicated-frame . t)))) - (compose-mail to subject others - noerase 'switch-to-buffer-other-window - yank-action sendactions))))) - -(defun rmail-mail () - "Send mail in another window. -While composing the message, use \\[mail-yank-original] to yank the -original message into it." - (interactive) - (rmail-start-mail nil nil nil nil nil (current-buffer))) - -(defun rmail-continue () - "Continue composing outgoing message previously being composed." - (interactive) - (rmail-start-mail t)) - -(put 'rmail-send-actions-rmail-buffer 'permanent-local t) -(put 'rmail-send-actions-rmail-msg-number 'permanent-local t) - -(defun rmail-reply (just-sender) - "Reply to the current message. -Normally include CC: to all other recipients of original message; -prefix argument means ignore them. While composing the reply, -use \\[mail-yank-original] to yank the original message into it." - (interactive "P") - (let (from reply-to cc subject date to message-id - resent-to resent-cc resent-reply-to - (msgnum rmail-current-message) - (rmail-buffer (current-buffer))) - (save-excursion - (save-restriction - (widen) - (goto-char (rmail-msgbeg rmail-current-message)) - (forward-line 1) - (if (= (following-char) ?0) - (narrow-to-region - (progn (forward-line 2) - (point)) - (progn (search-forward "\n\n" (rmail-msgend rmail-current-message) - 'move) - (point))) - (narrow-to-region (point) - (progn (search-forward "\n*** EOOH ***\n") - (beginning-of-line) (point)))) - (setq from (mail-fetch-field "from") - reply-to (or (mail-fetch-field "reply-to" nil t) - from) - cc (and (not just-sender) - (mail-fetch-field "cc" nil t)) - subject (mail-fetch-field "subject") - date (mail-fetch-field "date") - to (or (mail-fetch-field "to" nil t) "") - message-id (mail-fetch-field "message-id") - resent-reply-to (mail-fetch-field "resent-reply-to" t) - resent-cc (and (not just-sender) - (mail-fetch-field "resent-cc" nil t)) - resent-to (or (mail-fetch-field "resent-to" nil t) "") -;;; resent-subject (mail-fetch-field "resent-subject") -;;; resent-date (mail-fetch-field "resent-date") -;;; resent-message-id (mail-fetch-field "resent-message-id") - ))) - ;; Merge the resent-to and resent-cc into the to and cc. - (if (and resent-to (not (equal resent-to ""))) - (if (not (equal to "")) - (setq to (concat to ", " resent-to)) - (setq to resent-to))) - (if (and resent-cc (not (equal resent-cc ""))) - (if (not (equal cc "")) - (setq cc (concat cc ", " resent-cc)) - (setq cc resent-cc))) - ;; Add `Re: ' to subject if not there already. - (and (stringp subject) - (setq subject - (concat rmail-reply-prefix - (if (string-match rmail-reply-regexp subject) - (substring subject (match-end 0)) - subject)))) - (rmail-start-mail nil - (mail-strip-quoted-names reply-to) - subject - (rmail-make-in-reply-to-field from date message-id) - (if just-sender - nil - (let* ((cc-list (rmail-dont-reply-to - (mail-strip-quoted-names - (if (null cc) to (concat to ", " cc)))))) - (if (string= cc-list "") nil cc-list))) - (current-buffer) - (list (list '(lambda () - (let ((msgnum rmail-send-actions-rmail-msg-number)) - (save-excursion - (set-buffer rmail-send-actions-rmail-buffer) - (if msgnum - (rmail-set-attribute "answered" t msgnum)))))))) - ;; We keep the rmail buffer and message number in these - ;; buffer-local vars in the sendmail buffer, - ;; so that rmail-only-expunge can relocate the message number. - (make-local-variable 'rmail-send-actions-rmail-buffer) - (make-local-variable 'rmail-send-actions-rmail-msg-number) - (setq rmail-send-actions-rmail-buffer rmail-buffer) - (setq rmail-send-actions-rmail-msg-number msgnum))) - -(defun rmail-make-in-reply-to-field (from date message-id) - (cond ((not from) - (if message-id - message-id - nil)) - (mail-use-rfc822 - (require 'rfc822) - (let ((tem (car (rfc822-addresses from)))) - (if message-id - (if (string-match - (regexp-quote (if (string-match "@[^@]*\\'" tem) - (substring tem 0 (match-beginning 0)) - tem)) - message-id) - ;; Message-ID is sufficiently informative - message-id - (concat message-id " (" tem ")")) - ;; Copy TEM, discarding text properties. - (setq tem (copy-sequence tem)) - (set-text-properties 0 (length tem) nil tem) - (setq tem (copy-sequence tem)) - ;; Use prin1 to fake RFC822 quoting - (let ((field (prin1-to-string tem))) - (if date - (concat field "'s message of " date) - field))))) - ((let* ((foo "[^][\000-\037\177-\377()<>@,;:\\\" ]+") - (bar "[^][\000-\037\177-\377()<>@,;:\\\"]+")) - ;; Can't use format because format loses on \000 (unix *^&%*^&%$!!) - (or (string-match (concat "\\`[ \t]*\\(" bar - "\\)\\(<" foo "@" foo ">\\)?[ \t]*\\'") - ;; "Unix Loser <Foo@bar.edu>" => "Unix Loser" - from) - (string-match (concat "\\`[ \t]*<" foo "@" foo ">[ \t]*(\\(" - bar "\\))[ \t]*\\'") - ;; "<Bugs@bar.edu>" (Losing Unix) => "Losing Unix" - from))) - (let ((start (match-beginning 1)) - (end (match-end 1))) - ;; Trim whitespace which above regexp match allows - (while (and (< start end) - (memq (aref from start) '(?\t ?\ ))) - (setq start (1+ start))) - (while (and (< start end) - (memq (aref from (1- end)) '(?\t ?\ ))) - (setq end (1- end))) - (let ((field (substring from start end))) - (if date (setq field (concat "message from " field " on " date))) - (if message-id - ;; "<AA259@bar.edu> (message from Unix Loser on 1-Apr-89)" - (concat message-id " (" field ")") - field)))) - (t - ;; If we can't kludge it simply, do it correctly - (let ((mail-use-rfc822 t)) - (rmail-make-in-reply-to-field from date message-id))))) - -(defun rmail-forward (resend) - "Forward the current message to another user. -With prefix argument, \"resend\" the message instead of forwarding it; -see the documentation of `rmail-resend'." - (interactive "P") - (if resend - (call-interactively 'rmail-resend) - (let ((forward-buffer (current-buffer)) - (msgnum rmail-current-message) - (subject (concat "[" - (let ((from (or (mail-fetch-field "From") - (mail-fetch-field ">From")))) - (if from - (concat (mail-strip-quoted-names from) ": ") - "")) - (or (mail-fetch-field "Subject") "") - "]"))) - (if (rmail-start-mail - nil nil subject nil nil nil - (list (list (function - (lambda () - (let ((msgnum - rmail-send-actions-rmail-msg-number)) - (save-excursion - (set-buffer rmail-send-actions-rmail-buffer) - (if msgnum - (rmail-set-attribute - "forwarded" t msgnum)))))))) - ;; If only one window, use it for the mail buffer. - ;; Otherwise, use another window for the mail buffer - ;; so that the Rmail buffer remains visible - ;; and sending the mail will get back to it. - (and (not rmail-mail-new-frame) (one-window-p t))) - ;; The mail buffer is now current. - (save-excursion - ;; We keep the rmail buffer and message number in these - ;; buffer-local vars in the sendmail buffer, - ;; so that rmail-only-expunge can relocate the message number. - (make-local-variable 'rmail-send-actions-rmail-buffer) - (make-local-variable 'rmail-send-actions-rmail-msg-number) - (setq rmail-send-actions-rmail-buffer forward-buffer) - (setq rmail-send-actions-rmail-msg-number msgnum) - ;; Insert after header separator--before signature if any. - (goto-char (point-min)) - (search-forward-regexp - (concat "^" (regexp-quote mail-header-separator) "$")) - (forward-line 1) - (insert "------- Start of forwarded message -------\n") - ;; Quote lines with `- ' if they start with `-'. - (let ((beg (point)) end) - (setq end (point-marker)) - (set-marker-insertion-type end t) - (insert-buffer-substring forward-buffer) - (goto-char beg) - (while (re-search-forward "^-" nil t) - (beginning-of-line) - (insert "- ") - (forward-line 1)) - (goto-char end) - (skip-chars-backward "\n") - (if (< (point) end) - (forward-char 1)) - (delete-region (point) end) - (set-marker end nil)) - (insert "------- End of forwarded message -------\n") - (push-mark)))))) - -(defun rmail-resend (address &optional from comment mail-alias-file) - "Resend current message to ADDRESSES. -ADDRESSES should be a single address, a string consisting of several -addresses separated by commas, or a list of addresses. - -Optional FROM is the address to resend the message from, and -defaults to the username of the person redistributing the message. -Optional COMMENT is a string that will be inserted as a comment in the -resent message. -Optional ALIAS-FILE is alternate aliases file to be used by sendmail, -typically for purposes of moderating a list." - (interactive "sResend to: ") - (require 'sendmail) - (require 'mailalias) - (if (not from) (setq from (user-login-name))) - (let ((tembuf (generate-new-buffer " sendmail temp")) - (mail-header-separator "") - (case-fold-search nil) - (mailbuf (current-buffer))) - (unwind-protect - (save-excursion - ;;>> Copy message into temp buffer - (set-buffer tembuf) - (insert-buffer-substring mailbuf) - (goto-char (point-min)) - ;; Delete any Sender field, since that's not specifiable. - ; Only delete Sender fields in the actual header. - (re-search-forward "^$" nil 'move) - ; Using "while" here rather than "if" because some buggy mail - ; software may have inserted multiple Sender fields. - (while (re-search-backward "^Sender:" nil t) - (let (beg) - (setq beg (point)) - (forward-line 1) - (while (looking-at "[ \t]") - (forward-line 1)) - (delete-region beg (point)))) - ; Go back to the beginning of the buffer so the Resent- fields - ; are inserted there. - (goto-char (point-min)) - ;;>> Insert resent-from: - (insert "Resent-From: " from "\n") - (insert "Resent-Date: " (mail-rfc822-date) "\n") - ;;>> Insert resent-to: and bcc if need be. - (let ((before (point))) - (if mail-self-blind - (insert "Resent-Bcc: " (user-login-name) "\n")) - (insert "Resent-To: " (if (stringp address) - address - (mapconcat 'identity address ",\n\t")) - "\n") - ;; Expand abbrevs in the recipients. - (save-excursion - (if (featurep 'mailabbrev) - (let ((end (point-marker)) - (local-abbrev-table mail-abbrevs) - (old-syntax-table (syntax-table))) - (if (and (not (vectorp mail-abbrevs)) - (file-exists-p mail-personal-alias-file)) - (build-mail-abbrevs)) - (set-syntax-table mail-abbrev-syntax-table) - (goto-char before) - (while (and (< (point) end) - (progn (forward-word 1) - (<= (point) end))) - (expand-abbrev)) - (set-syntax-table old-syntax-table)) - (expand-mail-aliases before (point))))) - ;;>> Set up comment, if any. - (if (and (sequencep comment) (not (zerop (length comment)))) - (let ((before (point)) - after) - (insert comment) - (or (eolp) (insert "\n")) - (setq after (point)) - (goto-char before) - (while (< (point) after) - (insert "Resent-Comment: ") - (forward-line 1)))) - ;; Don't expand aliases in the destination fields - ;; of the original message. - (let (mail-aliases) - (funcall send-mail-function))) - (kill-buffer tembuf)) - (rmail-set-attribute "resent" t rmail-current-message))) - -(defvar mail-unsent-separator - (concat "^ *---+ +Unsent message follows +---+ *$\\|" - "^ *---+ +Returned message +---+ *$\\|" - "^Start of returned message$\\|" - "^ *---+ +Original message +---+ *$\\|" - "^ *--+ +begin message +--+ *$\\|" - "^ *---+ +Original message follows +---+ *$\\|" - "^|? *---+ +Message text follows: +---+ *|?$") - "A regexp that matches the separator before the text of a failed message.") - -(defun rmail-retry-failure () - "Edit a mail message which is based on the contents of the current message. -For a message rejected by the mail system, extract the interesting headers and -the body of the original message. -The variable `mail-unsent-separator' should match the string that -delimits the returned original message. -The variable `rmail-retry-ignored-headers' is a regular expression -specifying headers which should not be copied into the new message." - (interactive) - (require 'mail-utils) - (let ((rmail-buffer (current-buffer)) - (msgnum rmail-current-message) - bounce-start bounce-end bounce-indent resending) - (save-excursion - ;; Narrow down to just the quoted original message - (rmail-beginning-of-message) - (let ((case-fold-search t)) - (if (search-forward "This is a MIME-encapsulated message\n\n--" nil t) - (let ((codestring - (buffer-substring (progn (beginning-of-line) (point)) - (progn (end-of-line) (point))))) - (or (re-search-forward mail-unsent-separator nil t) - (error "Cannot find beginning of header in failed message")) - (or (and (search-forward codestring nil t) - (search-forward "\n\n" nil t)) - (error "Cannot find end of Mime data in failed message")) - (setq bounce-start (point)) - (save-excursion - (goto-char (point-max)) - (search-backward codestring) - (setq bounce-end (point))) - (or (search-forward "\n\n" nil t) - (error "Cannot find end of header in failed message"))) - (or (re-search-forward mail-unsent-separator nil t) - (error "Cannot parse this as a failure message")) - (skip-chars-forward "\n") - ;; Support a style of failure message in which the original - ;; message is indented, and included within lines saying - ;; `Start of returned message' and `End of returned message'. - (if (looking-at " +Received:") - (progn - (setq bounce-start (point)) - (skip-chars-forward " ") - (setq bounce-indent (- (current-column))) - (goto-char (point-max)) - (re-search-backward "^End of returned message$" nil t) - (setq bounce-end (point))) - ;; One message contained a few random lines before the old - ;; message header. The first line of the message started with - ;; two hyphens. A blank line followed these random lines. - ;; The same line beginning with two hyphens was possibly - ;; marking the end of the message. - (if (looking-at "^--") - (let ((boundary (buffer-substring-no-properties - (point) - (progn (end-of-line) (point))))) - (search-forward "\n\n") - (skip-chars-forward "\n") - (setq bounce-start (point)) - (goto-char (point-max)) - (search-backward (concat "\n\n" boundary) bounce-start t) - (setq bounce-end (point))) - (setq bounce-start (point) - bounce-end (point-max))) - (or (search-forward "\n\n" nil t) - (error "Cannot find end of header in failed message")) - )))) - ;; Start sending a new message; default header fields from the original. - ;; Turn off the usual actions for initializing the message body - ;; because we want to get only the text from the failure message. - (let ((action - ;; This function will be called when the user sends the retry. - ;; It will mark the bounce message as "retried". - (function (lambda () - (let ((msgnum rmail-send-actions-rmail-msg-number)) - (save-excursion - (set-buffer rmail-send-actions-rmail-buffer) - (if msgnum - (rmail-set-attribute "retried" t msgnum))))))) - mail-signature mail-setup-hook) - (if (rmail-start-mail nil nil nil nil nil rmail-buffer - (list (list action))) - ;; Insert original text as initial text of new draft message. - ;; Bind inhibit-read-only since the header delimiter - ;; of the previous message was probably read-only. - (let ((inhibit-read-only t)) - ;; We keep the rmail buffer and message number in these - ;; buffer-local vars in the sendmail buffer, - ;; so that the rmail-only-expunge can relocate the message number. - (make-local-variable 'rmail-send-actions-rmail-buffer) - (make-local-variable 'rmail-send-actions-rmail-msg-number) - (setq rmail-send-actions-rmail-buffer rmail-buffer) - (setq rmail-send-actions-rmail-msg-number msgnum) - (erase-buffer) - (insert-buffer-substring rmail-buffer bounce-start bounce-end) - (goto-char (point-min)) - (if bounce-indent - (indent-rigidly (point-min) (point-max) bounce-indent)) - (rmail-clear-headers rmail-retry-ignored-headers) - (rmail-clear-headers "^sender:\\|^from:\\|^return-path:") - (goto-char (point-min)) - (save-restriction - (search-forward "\n\n") - (forward-line -1) - (narrow-to-region (point-min) (point)) - (setq resending (mail-fetch-field "resent-to")) - (if mail-self-blind - (if resending - (insert "Resent-Bcc: " (user-login-name) "\n") - (insert "BCC: " (user-login-name) "\n")))) - (insert mail-header-separator) - (mail-position-on-field (if resending "Resent-To" "To") t) - (set-buffer rmail-buffer) - (rmail-beginning-of-message)))))) - -(defun rmail-summary-exists () - "Non-nil iff in an RMAIL buffer and an associated summary buffer exists. -In fact, the non-nil value returned is the summary buffer itself." - (and rmail-summary-buffer (buffer-name rmail-summary-buffer) - rmail-summary-buffer)) - -(defun rmail-summary-displayed () - "t iff in RMAIL buffer and an associated summary buffer is displayed." - (and rmail-summary-buffer (get-buffer-window rmail-summary-buffer))) - -(defvar rmail-redisplay-summary nil - "*Non-nil means Rmail should show the summary when it changes. -This has an effect only if a summary buffer exists.") - -(defvar rmail-summary-window-size nil - "*Non-nil means specify the height for an Rmail summary window.") - -;; Put the summary buffer back on the screen, if user wants that. -(defun rmail-maybe-display-summary () - (let ((selected (selected-window)) - window) - ;; If requested, make sure the summary is displayed. - (and rmail-summary-buffer (buffer-name rmail-summary-buffer) - rmail-redisplay-summary - (if (get-buffer-window rmail-summary-buffer 0) - ;; It's already in some frame; show that one. - (let ((frame (window-frame - (get-buffer-window rmail-summary-buffer 0)))) - (make-frame-visible frame) - (raise-frame frame)) - (display-buffer rmail-summary-buffer))) - ;; If requested, set the height of the summary window. - (and rmail-summary-buffer (buffer-name rmail-summary-buffer) - rmail-summary-window-size - (setq window (get-buffer-window rmail-summary-buffer)) - ;; Don't try to change the size if just one window in frame. - (not (eq window (frame-root-window (window-frame window)))) - (unwind-protect - (progn - (select-window window) - (enlarge-window (- rmail-summary-window-size (window-height)))) - (select-window selected))))) - -;;;; *** Rmail Local Fontification *** - -(defun rmail-fontify-buffer-function () - ;; This function's symbol is bound to font-lock-fontify-buffer-function. - (make-local-hook 'rmail-show-message-hook) - (add-hook 'rmail-show-message-hook 'rmail-fontify-message nil t) - ;; If we're already showing a message, fontify it now. - (if rmail-current-message (rmail-fontify-message)) - ;; Prevent Font Lock mode from kicking in. - (setq font-lock-fontified t)) - -(defun rmail-unfontify-buffer-function () - ;; This function's symbol is bound to font-lock-fontify-unbuffer-function. - (let ((modified (buffer-modified-p)) - (buffer-undo-list t) (inhibit-read-only t) - before-change-functions after-change-functions - buffer-file-name buffer-file-truename) - (save-restriction - (widen) - (remove-hook 'rmail-show-message-hook 'rmail-fontify-message t) - (remove-text-properties (point-min) (point-max) '(rmail-fontified nil)) - (font-lock-default-unfontify-buffer) - (and (not modified) (buffer-modified-p) (set-buffer-modified-p nil))))) - -(defun rmail-fontify-message () - ;; Fontify the current message if it is not already fontified. - (if (text-property-any (point-min) (point-max) 'rmail-fontified nil) - (let ((modified (buffer-modified-p)) - (buffer-undo-list t) (inhibit-read-only t) - before-change-functions after-change-functions - buffer-file-name buffer-file-truename) - (save-excursion - (save-match-data - (add-text-properties (point-min) (point-max) '(rmail-fontified t)) - (font-lock-fontify-region (point-min) (point-max)) - (and (not modified) (buffer-modified-p) (set-buffer-modified-p nil))))))) - -(provide 'rmail) - -;;; rmail.el ends here diff --git a/lisp/mail/rmailedit.el b/lisp/mail/rmailedit.el deleted file mode 100644 index 2f892981d19..00000000000 --- a/lisp/mail/rmailedit.el +++ /dev/null @@ -1,121 +0,0 @@ -;;; rmailedit.el --- "RMAIL edit mode" Edit the current message. - -;; Copyright (C) 1985, 1994 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; 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. - -;;; Code: - -(require 'rmail) - -(defvar rmail-edit-map nil) -(if rmail-edit-map - nil - ;; Make a keymap that inherits text-mode-map. - (setq rmail-edit-map (nconc (make-sparse-keymap) text-mode-map)) - (define-key rmail-edit-map "\C-c\C-c" 'rmail-cease-edit) - (define-key rmail-edit-map "\C-c\C-]" 'rmail-abort-edit)) - -;; Rmail Edit mode is suitable only for specially formatted data. -(put 'rmail-edit-mode 'mode-class 'special) - -(defun rmail-edit-mode () - "Major mode for editing the contents of an RMAIL message. -The editing commands are the same as in Text mode, together with two commands -to return to regular RMAIL: - * rmail-abort-edit cancels the changes - you have made and returns to RMAIL - * rmail-cease-edit makes them permanent. -\\{rmail-edit-map}" - (use-local-map rmail-edit-map) - (setq major-mode 'rmail-edit-mode) - (setq mode-name "RMAIL Edit") - (if (boundp 'mode-line-modified) - (setq mode-line-modified (default-value 'mode-line-modified)) - (setq mode-line-format (default-value 'mode-line-format))) - (if (rmail-summary-exists) - (save-excursion - (set-buffer rmail-summary-buffer) - (rmail-summary-disable))) - (run-hooks 'text-mode-hook 'rmail-edit-mode-hook)) - -;;;###autoload -(defun rmail-edit-current-message () - "Edit the contents of this message." - (interactive) - (rmail-edit-mode) - (make-local-variable 'rmail-old-text) - (setq rmail-old-text (buffer-substring (point-min) (point-max))) - (setq buffer-read-only nil) - (force-mode-line-update) - (if (and (eq (key-binding "\C-c\C-c") 'rmail-cease-edit) - (eq (key-binding "\C-c\C-]") 'rmail-abort-edit)) - (message "Editing: Type C-c C-c to return to Rmail, C-c C-] to abort") - (message "%s" (substitute-command-keys - "Editing: Type \\[rmail-cease-edit] to return to Rmail, \\[rmail-abort-edit] to abort")))) - -(defun rmail-cease-edit () - "Finish editing message; switch back to Rmail proper." - (interactive) - (if (rmail-summary-exists) - (save-excursion - (set-buffer rmail-summary-buffer) - (rmail-summary-enable))) - ;; Make sure buffer ends with a newline. - (save-excursion - (goto-char (point-max)) - (if (/= (preceding-char) ?\n) - (insert "\n")) - ;; Adjust the marker that points to the end of this message. - (set-marker (aref rmail-message-vector (1+ rmail-current-message)) - (point))) - (let ((old rmail-old-text)) - (force-mode-line-update) - (rmail-mode-1) - (if (and (= (length old) (- (point-max) (point-min))) - (string= old (buffer-substring (point-min) (point-max)))) - () - (setq old nil) - (rmail-set-attribute "edited" t) - (if (boundp 'rmail-summary-vector) - (progn - (aset rmail-summary-vector (1- rmail-current-message) nil) - (save-excursion - (rmail-widen-to-current-msgbeg - (function (lambda () - (forward-line 2) - (if (looking-at "Summary-line: ") - (let ((buffer-read-only nil)) - (delete-region (point) - (progn (forward-line 1) - (point)))))))) - (rmail-show-message)))))) - (setq buffer-read-only t)) - -(defun rmail-abort-edit () - "Abort edit of current message; restore original contents." - (interactive) - (delete-region (point-min) (point-max)) - (insert rmail-old-text) - (rmail-cease-edit) - (rmail-highlight-headers)) - -;;; rmailedit.el ends here diff --git a/lisp/mail/rmailkwd.el b/lisp/mail/rmailkwd.el deleted file mode 100644 index dfafab38e60..00000000000 --- a/lisp/mail/rmailkwd.el +++ /dev/null @@ -1,269 +0,0 @@ -;;; rmailkwd.el --- part of the "RMAIL" mail reader for Emacs. - -;; Copyright (C) 1985, 1988, 1994 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; 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. - -;;; Code: - -;; Global to all RMAIL buffers. It exists primarily for the sake of -;; completion. It is better to use strings with the label functions -;; and let them worry about making the label. - -(defvar rmail-label-obarray (make-vector 47 0)) - -;; Named list of symbols representing valid message attributes in RMAIL. - -(defconst rmail-attributes - (cons 'rmail-keywords - (mapcar (function (lambda (s) (intern s rmail-label-obarray))) - '("deleted" "answered" "filed" "forwarded" "unseen" "edited" - "resent")))) - -(defconst rmail-deleted-label (intern "deleted" rmail-label-obarray)) - -;; Named list of symbols representing valid message keywords in RMAIL. - -(defvar rmail-keywords) - -;;;###autoload -(defun rmail-add-label (string) - "Add LABEL to labels associated with current RMAIL message. -Completion is performed over known labels when reading." - (interactive (list (rmail-read-label "Add label"))) - (rmail-set-label string t)) - -;;;###autoload -(defun rmail-kill-label (string) - "Remove LABEL from labels associated with current RMAIL message. -Completion is performed over known labels when reading." - (interactive (list (rmail-read-label "Remove label"))) - (rmail-set-label string nil)) - -;;;###autoload -(defun rmail-read-label (prompt) - (if (not rmail-keywords) (rmail-parse-file-keywords)) - (let ((result - (completing-read (concat prompt - (if rmail-last-label - (concat " (default " - (symbol-name rmail-last-label) - "): ") - ": ")) - rmail-label-obarray - nil - nil))) - (if (string= result "") - rmail-last-label - (setq rmail-last-label (rmail-make-label result t))))) - -(defun rmail-set-label (l state &optional n) - (rmail-maybe-set-message-counters) - (if (not n) (setq n rmail-current-message)) - (aset rmail-summary-vector (1- n) nil) - (let* ((attribute (rmail-attribute-p l)) - (keyword (and (not attribute) - (or (rmail-keyword-p l) - (rmail-install-keyword l)))) - (label (or attribute keyword))) - (if label - (let ((omax (- (buffer-size) (point-max))) - (omin (- (buffer-size) (point-min))) - (buffer-read-only nil) - (case-fold-search t)) - (unwind-protect - (save-excursion - (widen) - (goto-char (rmail-msgbeg n)) - (forward-line 1) - (if (not (looking-at "[01],")) - nil - (let ((start (1+ (point))) - (bound)) - (narrow-to-region (point) (progn (end-of-line) (point))) - (setq bound (point-max)) - (search-backward ",," nil t) - (if attribute - (setq bound (1+ (point))) - (setq start (1+ (point)))) - (goto-char start) -; (while (re-search-forward "[ \t]*,[ \t]*" nil t) -; (replace-match ",")) -; (goto-char start) - (if (re-search-forward - (concat ", " (rmail-quote-label-name label) ",") - bound - 'move) - (if (not state) (replace-match ",")) - (if state (insert " " (symbol-name label) ","))) - (if (eq label rmail-deleted-label) - (rmail-set-message-deleted-p n state))))) - (narrow-to-region (- (buffer-size) omin) (- (buffer-size) omax)) - (if (= n rmail-current-message) (rmail-display-labels))))))) - -;; Commented functions aren't used by RMAIL but might be nice for user -;; packages that do stuff with RMAIL. Note that rmail-message-labels-p -;; is in rmail.el now. - -;(defun rmail-message-label-p (label &optional n) -; "Returns symbol if LABEL (attribute or keyword) on NTH or current message." -; (rmail-message-labels-p (or n rmail-current-message) (regexp-quote label))) - -;(defun rmail-parse-message-labels (&optional n) -; "Returns labels associated with NTH or current RMAIL message. -;The result is a list of two lists of strings. The first is the -;message attributes and the second is the message keywords." -; (let (atts keys) -; (save-restriction -; (widen) -; (goto-char (rmail-msgbeg (or n rmail-current-message))) -; (forward-line 1) -; (or (looking-at "[01],") (error "Malformed label line")) -; (forward-char 2) -; (while (looking-at "[ \t]*\\([^ \t\n,]+\\),") -; (setq atts (cons (buffer-substring (match-beginning 1) (match-end 1)) -; atts)) -; (goto-char (match-end 0))) -; (or (looking-at ",") (error "Malformed label line")) -; (forward-char 1) -; (while (looking-at "[ \t]*\\([^ \t\n,]+\\),") -; (setq keys (cons (buffer-substring (match-beginning 1) (match-end 1)) -; keys)) -; (goto-char (match-end 0))) -; (or (looking-at "[ \t]*$") (error "Malformed label line")) -; (list (nreverse atts) (nreverse keys))))) - -(defun rmail-attribute-p (s) - (let ((symbol (rmail-make-label s))) - (if (memq symbol (cdr rmail-attributes)) symbol))) - -(defun rmail-keyword-p (s) - (let ((symbol (rmail-make-label s))) - (if (memq symbol (cdr (rmail-keywords))) symbol))) - -(defun rmail-make-label (s &optional forcep) - (cond ((symbolp s) s) - (forcep (intern (downcase s) rmail-label-obarray)) - (t (intern-soft (downcase s) rmail-label-obarray)))) - -(defun rmail-force-make-label (s) - (intern (downcase s) rmail-label-obarray)) - -(defun rmail-quote-label-name (label) - (regexp-quote (symbol-name (rmail-make-label label t)))) - -;; Motion on messages with keywords. - -;;;###autoload -(defun rmail-previous-labeled-message (n labels) - "Show previous message with one of the labels LABELS. -LABELS should be a comma-separated list of label names. -If LABELS is empty, the last set of labels specified is used. -With prefix argument N moves backward N messages with these labels." - (interactive "p\nsMove to previous msg with labels: ") - (rmail-next-labeled-message (- n) labels)) - -;;;###autoload -(defun rmail-next-labeled-message (n labels) - "Show next message with one of the labels LABELS. -LABELS should be a comma-separated list of label names. -If LABELS is empty, the last set of labels specified is used. -With prefix argument N moves forward N messages with these labels." - (interactive "p\nsMove to next msg with labels: ") - (if (string= labels "") - (setq labels rmail-last-multi-labels)) - (or labels - (error "No labels to find have been specified previously")) - (setq rmail-last-multi-labels labels) - (rmail-maybe-set-message-counters) - (let ((lastwin rmail-current-message) - (current rmail-current-message) - (regexp (concat ", ?\\(" - (mail-comma-list-regexp labels) - "\\),"))) - (save-restriction - (widen) - (while (and (> n 0) (< current rmail-total-messages)) - (setq current (1+ current)) - (if (rmail-message-labels-p current regexp) - (setq lastwin current n (1- n)))) - (while (and (< n 0) (> current 1)) - (setq current (1- current)) - (if (rmail-message-labels-p current regexp) - (setq lastwin current n (1+ n))))) - (rmail-show-message lastwin) - (if (< n 0) - (message "No previous message with labels %s" labels)) - (if (> n 0) - (message "No following message with labels %s" labels)))) - -;;; Manipulate the file's Labels option. - -;; Return a list of symbols for all -;; the keywords (labels) recorded in this file's Labels option. -(defun rmail-keywords () - (or rmail-keywords (rmail-parse-file-keywords))) - -;; Set rmail-keywords to a list of symbols for all -;; the keywords (labels) recorded in this file's Labels option. -(defun rmail-parse-file-keywords () - (save-restriction - (save-excursion - (widen) - (goto-char 1) - (setq rmail-keywords - (if (search-forward "\nLabels:" (rmail-msgbeg 1) t) - (progn - (narrow-to-region (point) (progn (end-of-line) (point))) - (goto-char (point-min)) - (cons 'rmail-keywords - (mapcar 'rmail-force-make-label - (mail-parse-comma-list))))))))) - -;; Add WORD to the list in the file's Labels option. -;; Any keyword used for the first time needs this done. -(defun rmail-install-keyword (word) - (let ((keyword (rmail-make-label word t)) - (keywords (rmail-keywords))) - (if (not (or (rmail-attribute-p keyword) - (rmail-keyword-p keyword))) - (let ((omin (- (buffer-size) (point-min))) - (omax (- (buffer-size) (point-max)))) - (unwind-protect - (save-excursion - (widen) - (goto-char 1) - (let ((case-fold-search t) - (buffer-read-only nil)) - (or (search-forward "\nLabels:" nil t) - (progn - (end-of-line) - (insert "\nLabels:"))) - (delete-region (point) (progn (end-of-line) (point))) - (setcdr keywords (cons keyword (cdr keywords))) - (while (setq keywords (cdr keywords)) - (insert (symbol-name (car keywords)) ",")) - (delete-char -1))) - (narrow-to-region (- (buffer-size) omin) - (- (buffer-size) omax))))) - keyword)) - -;;; rmailkwd.el ends here diff --git a/lisp/mail/rmailmsc.el b/lisp/mail/rmailmsc.el deleted file mode 100644 index 98926d8117e..00000000000 --- a/lisp/mail/rmailmsc.el +++ /dev/null @@ -1,55 +0,0 @@ -;;; rmailmsc.el --- miscellaneous support functions for the RMAIL mail reader - -;; Copyright (C) 1985 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; 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. - -;;; Code: - -;;;###autoload -(defun set-rmail-inbox-list (file-name) - "Set the inbox list of the current RMAIL file to FILE-NAME. -You can specify one file name, or several names separated by commas. -If FILE-NAME is empty, remove any existing inbox list." - (interactive "sSet mailbox list to (comma-separated list of filenames): ") - (save-excursion - (let ((names (rmail-parse-file-inboxes)) - (standard-output nil)) - (if (or (not names) - (y-or-n-p (concat "Replace " - (mapconcat 'identity names ", ") - "? "))) - (let ((buffer-read-only nil)) - (widen) - (goto-char (point-min)) - (search-forward "\n\^_") - (re-search-backward "^Mail" nil t) - (forward-line 0) - (if (looking-at "Mail:") - (delete-region (point) - (progn (forward-line 1) - (point)))) - (if (not (string= file-name "")) - (insert-before-markers "Mail: " file-name "\n")))))) - (setq rmail-inbox-list (rmail-parse-file-inboxes)) - (rmail-show-message rmail-current-message)) - -;;; rmailmsc.el ends here diff --git a/lisp/mail/rmailout.el b/lisp/mail/rmailout.el deleted file mode 100644 index 29621cc955d..00000000000 --- a/lisp/mail/rmailout.el +++ /dev/null @@ -1,322 +0,0 @@ -;;; rmailout.el --- "RMAIL" mail reader for Emacs: output message to a file. - -;; Copyright (C) 1985, 1987, 1993, 1994 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; 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. - -;;; Code: - -(require 'rmail) - -;;;###autoload -(defvar rmail-output-file-alist nil - "*Alist matching regexps to suggested output Rmail files. -This is a list of elements of the form (REGEXP . NAME-EXP). -The suggestion is taken if REGEXP matches anywhere in the message buffer. -NAME-EXP may be a string constant giving the file name to use, -or more generally it may be any kind of expression that returns -a file name as a string.") - -;;; There are functions elsewhere in Emacs that use this function; check -;;; them out before you change the calling method. -;;;###autoload -(defun rmail-output-to-rmail-file (file-name &optional count) - "Append the current message to an Rmail file named FILE-NAME. -If the file does not exist, ask if it should be created. -If file is being visited, the message is appended to the Emacs -buffer visiting that file. -If the file exists and is not an Rmail file, -the message is appended in inbox format. - -The default file name comes from `rmail-default-rmail-file', -which is updated to the name you use in this command. - -A prefix argument N says to output N consecutive messages -starting with the current one. Deleted messages are skipped and don't count." - (interactive - (let ((default-file - (let (answer tail) - (setq tail rmail-output-file-alist) - ;; Suggest a file based on a pattern match. - (while (and tail (not answer)) - (save-excursion - (goto-char (point-min)) - (if (re-search-forward (car (car tail)) nil t) - (setq answer (eval (cdr (car tail))))) - (setq tail (cdr tail)))) - ;; If not suggestions, use same file as last time. - (or answer rmail-default-rmail-file)))) - (list (setq rmail-default-rmail-file - (let ((read-file - (read-file-name - (concat "Output message to Rmail file: (default " - (file-name-nondirectory default-file) - ") ") - (file-name-directory default-file) - default-file))) - (if (file-directory-p read-file) - (expand-file-name (file-name-nondirectory default-file) - read-file) - (expand-file-name - (or read-file default-file) - (file-name-directory default-file))))) - (prefix-numeric-value current-prefix-arg)))) - (or count (setq count 1)) - (setq file-name - (expand-file-name file-name - (file-name-directory rmail-default-rmail-file))) - (if (and (file-readable-p file-name) (not (mail-file-babyl-p file-name))) - (rmail-output file-name count) - (rmail-maybe-set-message-counters) - (setq file-name (abbreviate-file-name file-name)) - (or (get-file-buffer file-name) - (file-exists-p file-name) - (if (yes-or-no-p - (concat "\"" file-name "\" does not exist, create it? ")) - (let ((file-buffer (create-file-buffer file-name))) - (save-excursion - (set-buffer file-buffer) - (rmail-insert-rmail-file-header) - (let ((require-final-newline nil)) - (write-region (point-min) (point-max) file-name t 1))) - (kill-buffer file-buffer)) - (error "Output file does not exist"))) - (while (> count 0) - (let (redelete) - (unwind-protect - (progn - ;; Temporarily turn off Deleted attribute. - ;; Do this outside the save-restriction, since it would - ;; shift the place in the buffer where the visible text starts. - (if (rmail-message-deleted-p rmail-current-message) - (progn (setq redelete t) - (rmail-set-attribute "deleted" nil))) - (save-restriction - (widen) - ;; Decide whether to append to a file or to an Emacs buffer. - (save-excursion - (let ((buf (get-file-buffer file-name)) - (cur (current-buffer)) - (beg (1+ (rmail-msgbeg rmail-current-message))) - (end (1+ (rmail-msgend rmail-current-message)))) - (if (not buf) - ;; Output to a file. - (if rmail-fields-not-to-output - ;; Delete some fields while we output. - (let ((obuf (current-buffer))) - (set-buffer (get-buffer-create " rmail-out-temp")) - (insert-buffer-substring obuf beg end) - (rmail-delete-unwanted-fields) - (append-to-file (point-min) (point-max) file-name) - (set-buffer obuf) - (kill-buffer (get-buffer " rmail-out-temp"))) - (append-to-file beg end file-name)) - (if (eq buf (current-buffer)) - (error "Can't output message to same file it's already in")) - ;; File has been visited, in buffer BUF. - (set-buffer buf) - (let ((buffer-read-only nil) - (msg (and (boundp 'rmail-current-message) - rmail-current-message))) - ;; If MSG is non-nil, buffer is in RMAIL mode. - (if msg - (progn - ;; Turn on auto save mode, if it's off in this - ;; buffer but enabled by default. - (and (not buffer-auto-save-file-name) - auto-save-default - (auto-save-mode t)) - (rmail-maybe-set-message-counters) - (widen) - (narrow-to-region (point-max) (point-max)) - (insert-buffer-substring cur beg end) - (goto-char (point-min)) - (widen) - (search-backward "\n\^_") - (narrow-to-region (point) (point-max)) - (rmail-delete-unwanted-fields) - (rmail-count-new-messages t) - (if (rmail-summary-exists) - (rmail-select-summary - (rmail-update-summary))) - (rmail-show-message msg)) - ;; Output file not in rmail mode => just insert at the end. - (narrow-to-region (point-min) (1+ (buffer-size))) - (goto-char (point-max)) - (insert-buffer-substring cur beg end) - (rmail-delete-unwanted-fields))))))) - (rmail-set-attribute "filed" t)) - (if redelete (rmail-set-attribute "deleted" t)))) - (setq count (1- count)) - (if rmail-delete-after-output - (rmail-delete-forward) - (if (> count 0) - (rmail-next-undeleted-message 1)))))) - -;;;###autoload -(defvar rmail-fields-not-to-output nil - "*Regexp describing fields to exclude when outputting a message to a file.") - -;; Delete from the buffer header fields we don't want output. -;; NOT-RMAIL if t means this buffer does not have the full header -;; and *** EOOH *** that a message in an Rmail file has. -(defun rmail-delete-unwanted-fields (&optional not-rmail) - (if rmail-fields-not-to-output - (save-excursion - (goto-char (point-min)) - ;; Find the end of the header. - (if (and (or not-rmail (search-forward "\n*** EOOH ***\n" nil t)) - (search-forward "\n\n" nil t)) - (let ((end (point-marker))) - (goto-char (point-min)) - (while (re-search-forward rmail-fields-not-to-output end t) - (beginning-of-line) - (delete-region (point) - (progn (forward-line 1) (point))))))))) - -;;; There are functions elsewhere in Emacs that use this function; check -;;; them out before you change the calling method. -;;;###autoload -(defun rmail-output (file-name &optional count noattribute from-gnus) - "Append this message to system-inbox-format mail file named FILE-NAME. -A prefix argument N says to output N consecutive messages -starting with the current one. Deleted messages are skipped and don't count. -When called from lisp code, N may be omitted. - -If the pruned message header is shown on the current message, then -messages will be appended with pruned headers; otherwise, messages -will be appended with their original headers. - -The default file name comes from `rmail-default-file', -which is updated to the name you use in this command. - -The optional third argument NOATTRIBUTE, if non-nil, says not -to set the `filed' attribute, and not to display a message. - -The optional fourth argument FROM-GNUS is set when called from GNUS." - (interactive - (let ((default-file - (let (answer tail) - (setq tail rmail-output-file-alist) - ;; Suggest a file based on a pattern match. - (while (and tail (not answer)) - (save-excursion - (goto-char (point-min)) - (if (re-search-forward (car (car tail)) nil t) - (setq answer (eval (cdr (car tail))))) - (setq tail (cdr tail)))) - ;; If not suggestions, use same file as last time. - (or answer rmail-default-file)))) - (list (setq rmail-default-file - (let ((read-file - (read-file-name - (concat "Output message to Unix mail file: (default " - (file-name-nondirectory default-file) - ") ") - (file-name-directory default-file) - default-file))) - (if (file-directory-p read-file) - (expand-file-name (file-name-nondirectory default-file) - read-file) - (expand-file-name - (or read-file default-file) - (file-name-directory default-file))))) - (prefix-numeric-value current-prefix-arg)))) - (or count (setq count 1)) - (setq file-name - (expand-file-name file-name - (and rmail-default-file - (file-name-directory rmail-default-file)))) - (if (and (file-readable-p file-name) (mail-file-babyl-p file-name)) - (rmail-output-to-rmail-file file-name count) - (let ((orig-count count) - (rmailbuf (current-buffer)) - (case-fold-search t) - (tembuf (get-buffer-create " rmail-output")) - (original-headers-p - (and (not from-gnus) - (save-excursion - (save-restriction - (narrow-to-region (rmail-msgbeg rmail-current-message) (point-max)) - (goto-char (point-min)) - (forward-line 1) - (= (following-char) ?0))))) - header-beginning - mail-from) - (while (> count 0) - (or from-gnus - (setq mail-from - (save-excursion - (save-restriction - (widen) - (goto-char (rmail-msgbeg rmail-current-message)) - (setq header-beginning (point)) - (search-forward "\n*** EOOH ***\n") - (narrow-to-region header-beginning (point)) - (mail-fetch-field "Mail-From"))))) - (save-excursion - (set-buffer tembuf) - (erase-buffer) - (insert-buffer-substring rmailbuf) - (rmail-delete-unwanted-fields t) - (insert "\n") - (goto-char (point-min)) - (if mail-from - (insert mail-from "\n") - (insert "From " - (mail-strip-quoted-names (or (mail-fetch-field "from") - (mail-fetch-field "really-from") - (mail-fetch-field "sender") - "unknown")) - " " (current-time-string) "\n")) - ;; ``Quote'' "\nFrom " as "\n>From " - ;; (note that this isn't really quoting, as there is no requirement - ;; that "\n[>]+From " be quoted in the same transparent way.) - (let ((case-fold-search nil)) - (while (search-forward "\nFrom " nil t) - (forward-char -5) - (insert ?>))) - (write-region (point-min) (point-max) file-name t - (if noattribute 'nomsg))) - (or noattribute - (if (equal major-mode 'rmail-mode) - (rmail-set-attribute "filed" t))) - (setq count (1- count)) - (or from-gnus - (let ((next-message-p - (if rmail-delete-after-output - (rmail-delete-forward) - (if (> count 0) - (rmail-next-undeleted-message 1)))) - (num-appended (- orig-count count))) - (if (and next-message-p original-headers-p) - (rmail-toggle-header)) - (if (and (> count 0) (not next-message-p)) - (progn - (error - (save-excursion - (set-buffer rmailbuf) - (format "Only %d message%s appended" num-appended - (if (= num-appended 1) "" "s")))) - (setq count 0)))))) - (kill-buffer tembuf)))) - -;;; rmailout.el ends here diff --git a/lisp/mail/rmailsort.el b/lisp/mail/rmailsort.el deleted file mode 100644 index 4066890fea9..00000000000 --- a/lisp/mail/rmailsort.el +++ /dev/null @@ -1,245 +0,0 @@ -;;; rmailsort.el --- Rmail: sort messages. - -;; Copyright (C) 1990, 1993, 1994 Free Software Foundation, Inc. - -;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp> -;; Version: $Header: /home/fsf/rms/e19/lisp/RCS/rmailsort.el,v 1.24 1996/01/20 07:41:37 kwzh Exp rms $ -;; 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. - -;;; Code: - -(require 'sort) - -;; For rmail-select-summary -(require 'rmail) - -(autoload 'timezone-make-date-sortable "timezone") - -;; Sorting messages in Rmail buffer - -;;;###autoload -(defun rmail-sort-by-date (reverse) - "Sort messages of current Rmail file by date. -If prefix argument REVERSE is non-nil, sort them in reverse order." - (interactive "P") - (rmail-sort-messages reverse - (function - (lambda (msg) - (rmail-make-date-sortable - (rmail-fetch-field msg "Date")))))) - -;;;###autoload -(defun rmail-sort-by-subject (reverse) - "Sort messages of current Rmail file by subject. -If prefix argument REVERSE is non-nil, sort them in reverse order." - (interactive "P") - (rmail-sort-messages reverse - (function - (lambda (msg) - (let ((key (or (rmail-fetch-field msg "Subject") "")) - (case-fold-search t)) - ;; Remove `Re:' - (if (string-match "^\\(re:[ \t]*\\)*" key) - (substring key (match-end 0)) - key)))))) - -;;;###autoload -(defun rmail-sort-by-author (reverse) - "Sort messages of current Rmail file by author. -If prefix argument REVERSE is non-nil, sort them in reverse order." - (interactive "P") - (rmail-sort-messages reverse - (function - (lambda (msg) - (downcase ;Canonical name - (mail-strip-quoted-names - (or (rmail-fetch-field msg "From") - (rmail-fetch-field msg "Sender") ""))))))) - -;;;###autoload -(defun rmail-sort-by-recipient (reverse) - "Sort messages of current Rmail file by recipient. -If prefix argument REVERSE is non-nil, sort them in reverse order." - (interactive "P") - (rmail-sort-messages reverse - (function - (lambda (msg) - (downcase ;Canonical name - (mail-strip-quoted-names - (or (rmail-fetch-field msg "To") - (rmail-fetch-field msg "Apparently-To") "") - )))))) - -;;;###autoload -(defun rmail-sort-by-correspondent (reverse) - "Sort messages of current Rmail file by other correspondent. -If prefix argument REVERSE is non-nil, sort them in reverse order." - (interactive "P") - (rmail-sort-messages reverse - (function - (lambda (msg) - (rmail-select-correspondent - msg - '("From" "Sender" "To" "Apparently-To")))))) - -(defun rmail-select-correspondent (msg fields) - (let ((ans "")) - (while (and fields (string= ans "")) - (setq ans - (rmail-dont-reply-to - (mail-strip-quoted-names - (or (rmail-fetch-field msg (car fields)) "")))) - (setq fields (cdr fields))) - ans)) - -;;;###autoload -(defun rmail-sort-by-lines (reverse) - "Sort messages of current Rmail file by number of lines. -If prefix argument REVERSE is non-nil, sort them in reverse order." - (interactive "P") - (rmail-sort-messages reverse - (function - (lambda (msg) - (count-lines (rmail-msgbeg msg) - (rmail-msgend msg)))))) - -;;;###autoload -(defun rmail-sort-by-keywords (reverse labels) - "Sort messages of current Rmail file by labels. -If prefix argument REVERSE is non-nil, sort them in reverse order. -KEYWORDS is a comma-separated list of labels." - (interactive "P\nsSort by labels: ") - (or (string-match "[^ \t]" labels) - (error "No labels specified")) - (setq labels (concat (substring labels (match-beginning 0)) ",")) - (let (labelvec) - (while (string-match "[ \t]*,[ \t]*" labels) - (setq labelvec (cons - (concat ", ?\\(" - (substring labels 0 (match-beginning 0)) - "\\),") - labelvec)) - (setq labels (substring labels (match-end 0)))) - (setq labelvec (apply 'vector (nreverse labelvec))) - (rmail-sort-messages reverse - (function - (lambda (msg) - (let ((n 0)) - (while (and (< n (length labelvec)) - (not (rmail-message-labels-p - msg (aref labelvec n)))) - (setq n (1+ n))) - n)))))) - -;; Basic functions - -(defun rmail-sort-messages (reverse keyfun) - "Sort messages of current Rmail file. -If 1st argument REVERSE is non-nil, sort them in reverse order. -2nd argument KEYFUN is called with a message number, and should return a key." - (save-excursion - ;; If we are in a summary buffer, operate on the Rmail buffer. - (if (eq major-mode 'rmail-summary-mode) - (set-buffer rmail-buffer)) - (let ((buffer-read-only nil) - (predicate nil) ;< or string-lessp - (sort-lists nil)) - (message "Finding sort keys...") - (widen) - (let ((msgnum 1)) - (while (>= rmail-total-messages msgnum) - (setq sort-lists - (cons (list (funcall keyfun msgnum) ;Make sorting key - (eq rmail-current-message msgnum) ;True if current - (aref rmail-message-vector msgnum) - (aref rmail-message-vector (1+ msgnum))) - sort-lists)) - (if (zerop (% msgnum 10)) - (message "Finding sort keys...%d" msgnum)) - (setq msgnum (1+ msgnum)))) - (or reverse (setq sort-lists (nreverse sort-lists))) - ;; Decide predicate: < or string-lessp - (if (numberp (car (car sort-lists))) ;Is a key numeric? - (setq predicate (function <)) - (setq predicate (function string-lessp))) - (setq sort-lists - (sort sort-lists - (function - (lambda (a b) - (funcall predicate (car a) (car b)))))) - (if reverse (setq sort-lists (nreverse sort-lists))) - ;; Now we enter critical region. So, keyboard quit is disabled. - (message "Reordering messages...") - (let ((inhibit-quit t) ;Inhibit quit - (current-message nil) - (msgnum 1) - (msginfo nil)) - ;; There's little hope that we can easily undo after that. - (buffer-disable-undo (current-buffer)) - (goto-char (rmail-msgbeg 1)) - ;; To force update of all markers. - (insert-before-markers ?Z) - (backward-char 1) - ;; Now reorder messages. - (while sort-lists - (setq msginfo (car sort-lists)) - ;; Swap two messages. - (insert-buffer-substring - (current-buffer) (nth 2 msginfo) (nth 3 msginfo)) - (delete-region (nth 2 msginfo) (nth 3 msginfo)) - ;; Is current message? - (if (nth 1 msginfo) - (setq current-message msgnum)) - (setq sort-lists (cdr sort-lists)) - (if (zerop (% msgnum 10)) - (message "Reordering messages...%d" msgnum)) - (setq msgnum (1+ msgnum))) - ;; Delete the garbage inserted before. - (delete-char 1) - (setq quit-flag nil) - (buffer-enable-undo) - (rmail-set-message-counters) - (rmail-show-message current-message) - (if (rmail-summary-exists) - (rmail-select-summary - (rmail-update-summary))))))) - -(defun rmail-fetch-field (msg field) - "Return the value of the header FIELD of MSG. -Arguments are MSG and FIELD." - (save-restriction - (widen) - (let ((next (rmail-msgend msg))) - (goto-char (rmail-msgbeg msg)) - (narrow-to-region (if (search-forward "\n*** EOOH ***\n" next t) - (point) - (forward-line 1) - (point)) - (progn (search-forward "\n\n" nil t) (point))) - (mail-fetch-field field)))) - -(defun rmail-make-date-sortable (date) - "Make DATE sortable using the function string-lessp." - ;; Assume the default time zone is GMT. - (timezone-make-date-sortable date "GMT" "GMT")) - -(provide 'rmailsort) - -;;; rmailsort.el ends here diff --git a/lisp/mail/rmailsum.el b/lisp/mail/rmailsum.el deleted file mode 100644 index 9c04ef524cf..00000000000 --- a/lisp/mail/rmailsum.el +++ /dev/null @@ -1,1531 +0,0 @@ -;;; rmailsum.el --- make summary buffers for the mail reader - -;; Copyright (C) 1985, 1993, 1994, 1995, 1996 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; 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: - -;; Extended by Bob Weiner of Motorola -;; Provided all commands from rmail-mode in rmail-summary-mode and made key -;; bindings in both modes wholly compatible. - -;;; Code: - -;; For rmail-select-summary -(require 'rmail) - -;;;###autoload -(defvar rmail-summary-scroll-between-messages t - "*Non-nil means Rmail summary scroll commands move between messages.") - -;;;###autoload -(defvar rmail-summary-line-count-flag t - "*Non-nil if Rmail summary should show the number of lines in each message.") - -(defvar rmail-summary-font-lock-keywords - '(("^....D.*" . font-lock-string-face) ; Deleted. - ("^....-.*" . font-lock-type-face) ; Unread. - ;; Neither of the below will be highlighted if either of the above are: - ("^....[^D-] \\(......\\)" 1 font-lock-keyword-face) ; Date. - ("{ \\([^}]+\\),}" 1 font-lock-comment-face)) ; Labels. - "Additional expressions to highlight in Rmail Summary mode.") - -;; Entry points for making a summary buffer. - -;; Regenerate the contents of the summary -;; using the same selection criterion as last time. -;; M-x revert-buffer in a summary buffer calls this function. -(defun rmail-update-summary (&rest ignore) - (apply (car rmail-summary-redo) (cdr rmail-summary-redo))) - -;;;###autoload -(defun rmail-summary () - "Display a summary of all messages, one line per message." - (interactive) - (rmail-new-summary "All" '(rmail-summary) nil)) - -;;;###autoload -(defun rmail-summary-by-labels (labels) - "Display a summary of all messages with one or more LABELS. -LABELS should be a string containing the desired labels, separated by commas." - (interactive "sLabels to summarize by: ") - (if (string= labels "") - (setq labels (or rmail-last-multi-labels - (error "No label specified")))) - (setq rmail-last-multi-labels labels) - (rmail-new-summary (concat "labels " labels) - (list 'rmail-summary-by-labels labels) - 'rmail-message-labels-p - (concat ", \\(" (mail-comma-list-regexp labels) "\\),"))) - -;;;###autoload -(defun rmail-summary-by-recipients (recipients &optional primary-only) - "Display a summary of all messages with the given RECIPIENTS. -Normally checks the To, From and Cc fields of headers; -but if PRIMARY-ONLY is non-nil (prefix arg given), - only look in the To and From fields. -RECIPIENTS is a string of regexps separated by commas." - (interactive "sRecipients to summarize by: \nP") - (rmail-new-summary - (concat "recipients " recipients) - (list 'rmail-summary-by-recipients recipients primary-only) - 'rmail-message-recipients-p - (mail-comma-list-regexp recipients) primary-only)) - -;;;###autoload -(defun rmail-summary-by-regexp (regexp) - "Display a summary of all messages according to regexp REGEXP. -If the regular expression is found in the header of the message -\(including in the date and other lines, as well as the subject line), -Emacs will list the header line in the RMAIL-summary." - (interactive "sRegexp to summarize by: ") - (if (string= regexp "") - (setq regexp (or rmail-last-regexp - (error "No regexp specified.")))) - (setq rmail-last-regexp regexp) - (rmail-new-summary (concat "regexp " regexp) - (list 'rmail-summary-by-regexp regexp) - 'rmail-message-regexp-p - regexp)) - -;; rmail-summary-by-topic -;; 1989 R.A. Schnitzler - -;;;###autoload -(defun rmail-summary-by-topic (subject &optional whole-message) - "Display a summary of all messages with the given SUBJECT. -Normally checks the Subject field of headers; -but if WHOLE-MESSAGE is non-nil (prefix arg given), - look in the whole message. -SUBJECT is a string of regexps separated by commas." - (interactive "sTopics to summarize by: \nP") - (rmail-new-summary - (concat "about " subject) - (list 'rmail-summary-by-topic subject whole-message) - 'rmail-message-subject-p - (mail-comma-list-regexp subject) whole-message)) - -(defun rmail-message-subject-p (msg subject &optional whole-message) - (save-restriction - (goto-char (rmail-msgbeg msg)) - (search-forward "\n*** EOOH ***\n") - (narrow-to-region - (point) - (progn (search-forward (if whole-message "\^_" "\n\n")) (point))) - (goto-char (point-min)) - (if whole-message (re-search-forward subject nil t) - (string-match subject (or (mail-fetch-field "Subject") "")) ))) - -;;;###autoload -(defun rmail-summary-by-senders (senders) - "Display a summary of all messages with the given SENDERS. -SENDERS is a string of names separated by commas." - (interactive "sSenders to summarize by: ") - (rmail-new-summary - (concat "senders " senders) - (list 'rmail-summary-by-senders senders) - 'rmail-message-senders-p - (mail-comma-list-regexp senders))) - -(defun rmail-message-senders-p (msg senders) - (save-restriction - (goto-char (rmail-msgbeg msg)) - (search-forward "\n*** EOOH ***\n") - (narrow-to-region (point) (progn (search-forward "\n\n") (point))) - (string-match senders (or (mail-fetch-field "From") "")))) - -;; General making of a summary buffer. - -(defvar rmail-summary-symbol-number 0) - -(defun rmail-new-summary (description redo-form function &rest args) - "Create a summary of selected messages. -DESCRIPTION makes part of the mode line of the summary buffer. -For each message, FUNCTION is applied to the message number and ARGS... -and if the result is non-nil, that message is included. -nil for FUNCTION means all messages." - (message "Computing summary lines...") - (let (sumbuf mesg was-in-summary) - (save-excursion - ;; Go to the Rmail buffer. - (if (eq major-mode 'rmail-summary-mode) - (progn - (setq was-in-summary t) - (set-buffer rmail-buffer))) - ;; Find its summary buffer, or make one. - (setq sumbuf - (if (and rmail-summary-buffer - (buffer-name rmail-summary-buffer)) - rmail-summary-buffer - (generate-new-buffer (concat (buffer-name) "-summary")))) - (setq mesg rmail-current-message) - ;; Filter the messages; make or get their summary lines. - (let ((summary-msgs ()) - (new-summary-line-count 0)) - (let ((msgnum 1) - (buffer-read-only nil) - (old-min (point-min-marker)) - (old-max (point-max-marker))) - ;; Can't use save-restriction here; that doesn't work if we - ;; plan to modify text outside the original restriction. - (save-excursion - (widen) - (goto-char (point-min)) - (while (>= rmail-total-messages msgnum) - (if (or (null function) - (apply function (cons msgnum args))) - (setq summary-msgs - (cons (cons msgnum (rmail-make-summary-line msgnum)) - summary-msgs))) - (setq msgnum (1+ msgnum))) - (setq summary-msgs (nreverse summary-msgs))) - (narrow-to-region old-min old-max)) - ;; Temporarily, while summary buffer is unfinished, - ;; we "don't have" a summary. - (setq rmail-summary-buffer nil) - (save-excursion - (let ((rbuf (current-buffer)) - (total rmail-total-messages)) - (set-buffer sumbuf) - ;; Set up the summary buffer's contents. - (let ((buffer-read-only nil)) - (erase-buffer) - (while summary-msgs - (princ (cdr (car summary-msgs)) sumbuf) - (setq summary-msgs (cdr summary-msgs))) - (goto-char (point-min))) - ;; Set up the rest of its state and local variables. - (setq buffer-read-only t) - (rmail-summary-mode) - (make-local-variable 'minor-mode-alist) - (setq minor-mode-alist (list (list t (concat ": " description)))) - (setq rmail-buffer rbuf - rmail-summary-redo redo-form - rmail-total-messages total)))) - (setq rmail-summary-buffer sumbuf)) - ;; Now display the summary buffer and go to the right place in it. - (or was-in-summary - (progn - (if (and (one-window-p) - pop-up-windows (not pop-up-frames)) - ;; If there is just one window, put the summary on the top. - (progn - (split-window (selected-window) rmail-summary-window-size) - (select-window (next-window (frame-first-window))) - (pop-to-buffer sumbuf) - ;; If pop-to-buffer did not use that window, delete that - ;; window. (This can happen if it uses another frame.) - (if (not (eq sumbuf (window-buffer (frame-first-window)))) - (delete-other-windows))) - (pop-to-buffer sumbuf)) - (set-buffer rmail-buffer) - ;; This is how rmail makes the summary buffer reappear. - ;; We do this here to make the window the proper size. - (rmail-select-summary nil) - (set-buffer rmail-summary-buffer))) - (rmail-summary-goto-msg mesg t t) - (rmail-summary-construct-io-menu) - (message "Computing summary lines...done"))) - -;; Low levels of generating a summary. - -(defun rmail-make-summary-line (msg) - (let ((line (or (aref rmail-summary-vector (1- msg)) - (progn - (setq new-summary-line-count - (1+ new-summary-line-count)) - (if (zerop (% new-summary-line-count 10)) - (message "Computing summary lines...%d" - new-summary-line-count)) - (rmail-make-summary-line-1 msg))))) - ;; Fix up the part of the summary that says "deleted" or "unseen". - (aset line 4 - (if (rmail-message-deleted-p msg) ?\D - (if (= ?0 (char-after (+ 3 (rmail-msgbeg msg)))) - ?\- ?\ ))) - line)) - -(defun rmail-make-summary-line-1 (msg) - (goto-char (rmail-msgbeg msg)) - (let* ((lim (save-excursion (forward-line 2) (point))) - pos - (labels - (progn - (forward-char 3) - (concat -; (if (save-excursion (re-search-forward ",answered," lim t)) -; "*" "") -; (if (save-excursion (re-search-forward ",filed," lim t)) -; "!" "") - (if (progn (search-forward ",,") (eolp)) - "" - (concat "{" - (buffer-substring (point) - (progn (end-of-line) (point))) - "} "))))) - (line - (progn - (forward-line 1) - (if (looking-at "Summary-line: ") - (progn - (goto-char (match-end 0)) - (setq line - (buffer-substring (point) - (progn (forward-line 1) (point))))))))) - ;; Obsolete status lines lacking a # should be flushed. - (and line - (not (string-match "#" line)) - (progn - (delete-region (point) - (progn (forward-line -1) (point))) - (setq line nil))) - ;; If we didn't get a valid status line from the message, - ;; make a new one and put it in the message. - (or line - (let* ((case-fold-search t) - (next (rmail-msgend msg)) - (beg (if (progn (goto-char (rmail-msgbeg msg)) - (search-forward "\n*** EOOH ***\n" next t)) - (point) - (forward-line 1) - (point))) - (end (progn (search-forward "\n\n" nil t) (point)))) - (save-restriction - (narrow-to-region beg end) - (goto-char beg) - (setq line (rmail-make-basic-summary-line))) - (goto-char (rmail-msgbeg msg)) - (forward-line 2) - (insert "Summary-line: " line))) - (setq pos (string-match "#" line)) - (aset rmail-summary-vector (1- msg) - (concat (format "%4d " msg) - (substring line 0 pos) - labels - (substring line (1+ pos)))))) - -(defun rmail-make-basic-summary-line () - (goto-char (point-min)) - (concat (save-excursion - (if (not (re-search-forward "^Date:" nil t)) - " " - (cond ((re-search-forward "\\([^0-9:]\\)\\([0-3]?[0-9]\\)\\([- \t_]+\\)\\([adfjmnos][aceopu][bcglnprtvy]\\)" - (save-excursion (end-of-line) (point)) t) - (format "%2d-%3s" - (string-to-int (buffer-substring - (match-beginning 2) - (match-end 2))) - (buffer-substring - (match-beginning 4) (match-end 4)))) - ((re-search-forward "\\([^a-z]\\)\\([adfjmnos][acepou][bcglnprtvy]\\)\\([-a-z \t_]*\\)\\([0-9][0-9]?\\)" - (save-excursion (end-of-line) (point)) t) - (format "%2d-%3s" - (string-to-int (buffer-substring - (match-beginning 4) - (match-end 4))) - (buffer-substring - (match-beginning 2) (match-end 2)))) - ((re-search-forward "\\(19\\|20\\)\\([0-9][0-9]\\)-\\([01][0-9]\\)-\\([0-3][0-9]\\)" - (save-excursion (end-of-line) (point)) t) - (format "%2s%2s%2s" - (buffer-substring - (match-beginning 2) (match-end 2)) - (buffer-substring - (match-beginning 3) (match-end 3)) - (buffer-substring - (match-beginning 4) (match-end 4)))) - (t "??????")))) - " " - (save-excursion - (if (not (re-search-forward "^From:[ \t]*" nil t)) - " " - (let* ((from (mail-strip-quoted-names - (buffer-substring - (1- (point)) - ;; Get all the lines of the From field - ;; so that we get a whole comment if there is one, - ;; so that mail-strip-quoted-names can discard it. - (let ((opoint (point))) - (while (progn (forward-line 1) - (looking-at "[ \t]"))) - ;; Back up over newline, then trailing spaces or tabs - (forward-char -1) - (skip-chars-backward " \t") - (point))))) - len mch lo) - (if (string-match (concat "^\\(" - (regexp-quote (user-login-name)) - "\\($\\|@\\)\\|" - (regexp-quote - ;; Don't lose if run from init file - ;; where user-mail-address is not - ;; set yet. - (or user-mail-address - (concat (user-login-name) "@" - (or mail-host-address - (system-name))))) - "\\>\\)") - from) - (save-excursion - (goto-char (point-min)) - (if (not (re-search-forward "^To:[ \t]*" nil t)) - nil - (setq from - (concat "to: " - (mail-strip-quoted-names - (buffer-substring - (point) - (progn (end-of-line) - (skip-chars-backward " \t") - (point))))))))) - (setq len (length from)) - (setq mch (string-match "[@%]" from)) - (format "%25s" - (if (or (not mch) (<= len 25)) - (substring from (max 0 (- len 25))) - (substring from - (setq lo (cond ((< (- mch 14) 0) 0) - ((< len (+ mch 11)) - (- len 25)) - (t (- mch 14)))) - (min len (+ lo 25)))))))) - (if rmail-summary-line-count-flag - (save-excursion - (save-restriction - (widen) - (let ((beg (rmail-msgbeg msgnum)) - (end (rmail-msgend msgnum)) - lines) - (save-excursion - (goto-char beg) - ;; Count only lines in the reformatted header, - ;; if we have reformatted it. - (search-forward "\n*** EOOH ***\n" end t) - (setq lines (count-lines (point) end))) - (format (cond - ((<= lines 9) " [%d]") - ((<= lines 99) " [%d]") - ((<= lines 999) " [%3d]") - (t "[%d]")) - lines)))) - " ") - " #" ;The # is part of the format. - (if (re-search-forward "^Subject:" nil t) - (progn (skip-chars-forward " \t") - (buffer-substring (point) - (progn (end-of-line) - (point)))) - (re-search-forward "[\n][\n]+" nil t) - (buffer-substring (point) (progn (end-of-line) (point)))) - "\n")) - -;; Simple motion in a summary buffer. - -(defun rmail-summary-next-all (&optional number) - (interactive "p") - (forward-line (if number number 1)) - ;; It doesn't look nice to move forward past the last message line. - (and (eobp) (> number 0) - (forward-line -1)) - (display-buffer rmail-buffer)) - -(defun rmail-summary-previous-all (&optional number) - (interactive "p") - (forward-line (- (if number number 1))) - ;; It doesn't look nice to move forward past the last message line. - (and (eobp) (< number 0) - (forward-line -1)) - (display-buffer rmail-buffer)) - -(defun rmail-summary-next-msg (&optional number) - "Display next non-deleted msg from rmail file. -With optional prefix argument NUMBER, moves forward this number of non-deleted -messages, or backward if NUMBER is negative." - (interactive "p") - (forward-line 0) - (and (> number 0) (end-of-line)) - (let ((count (if (< number 0) (- number) number)) - (search (if (> number 0) 're-search-forward 're-search-backward)) - (non-del-msg-found nil)) - (while (and (> count 0) (setq non-del-msg-found - (or (funcall search "^....[^D]" nil t) - non-del-msg-found))) - (setq count (1- count)))) - (beginning-of-line) - (display-buffer rmail-buffer)) - -(defun rmail-summary-previous-msg (&optional number) - (interactive "p") - (rmail-summary-next-msg (- (if number number 1)))) - -(defun rmail-summary-next-labeled-message (n labels) - "Show next message with LABEL. Defaults to last labels used. -With prefix argument N moves forward N messages with these labels." - (interactive "p\nsMove to next msg with labels: ") - (let (msg) - (save-excursion - (set-buffer rmail-buffer) - (rmail-next-labeled-message n labels) - (setq msg rmail-current-message)) - (rmail-summary-goto-msg msg))) - -(defun rmail-summary-previous-labeled-message (n labels) - "Show previous message with LABEL. Defaults to last labels used. -With prefix argument N moves backward N messages with these labels." - (interactive "p\nsMove to previous msg with labels: ") - (let (msg) - (save-excursion - (set-buffer rmail-buffer) - (rmail-previous-labeled-message n labels) - (setq msg rmail-current-message)) - (rmail-summary-goto-msg msg))) - -(defun rmail-summary-next-same-subject (n) - "Go to the next message in the summary having the same subject. -With prefix argument N, do this N times. -If N is negative, go backwards." - (interactive "p") - (let (subject search-regexp i found - (forward (> n 0))) - (save-excursion - (set-buffer rmail-buffer) - (setq subject (mail-fetch-field "Subject")) - (setq i rmail-current-message)) - (if (string-match "Re:[ \t]*" subject) - (setq subject (substring subject (match-end 0)))) - (setq search-regexp (concat "^Subject: *\\(Re: *\\)?" - (regexp-quote subject) - "\n")) - (save-excursion - (while (and (/= n 0) - (if forward - (not (eobp)) - (not (bobp)))) - (let (done) - (while (and (not done) - (if forward - (not (eobp)) - (not (bobp)))) - ;; Advance thru summary. - (forward-line (if forward 1 -1)) - ;; Get msg number of this line. - (setq i (string-to-int - (buffer-substring (point) - (min (point-max) (+ 5 (point)))))) - ;; See if that msg has desired subject. - (save-excursion - (set-buffer rmail-buffer) - (save-restriction - (widen) - (goto-char (rmail-msgbeg i)) - (search-forward "\n*** EOOH ***\n") - (let ((beg (point)) end) - (search-forward "\n\n") - (setq end (point)) - (goto-char beg) - (setq done (re-search-forward search-regexp end t)))))) - (if done (setq found i))) - (setq n (if forward (1- n) (1+ n))))) - (if found - (rmail-summary-goto-msg found) - (error "No %s message with same subject" - (if forward "following" "previous"))))) - -(defun rmail-summary-previous-same-subject (n) - "Go to the previous message in the summary having the same subject. -With prefix argument N, do this N times. -If N is negative, go forwards instead." - (interactive "p") - (rmail-summary-next-same-subject (- n))) - -;; Delete and undelete summary commands. - -(defun rmail-summary-delete-forward (&optional backward) - "Delete this message and move to next nondeleted one. -Deleted messages stay in the file until the \\[rmail-expunge] command is given. -With prefix argument, delete and move backward." - (interactive "P") - (let (end) - (rmail-summary-goto-msg) - (pop-to-buffer rmail-buffer) - (rmail-delete-message) - (let ((del-msg rmail-current-message)) - (pop-to-buffer rmail-summary-buffer) - (rmail-summary-mark-deleted del-msg) - (while (and (not (if backward (bobp) (eobp))) - (save-excursion (beginning-of-line) - (looking-at " *[0-9]+D"))) - (forward-line (if backward -1 1))) - ;; It looks ugly to move to the empty line at end of buffer. - (and (eobp) (not backward) - (forward-line -1))))) - -(defun rmail-summary-delete-backward () - "Delete this message and move to previous nondeleted one. -Deleted messages stay in the file until the \\[rmail-expunge] command is given." - (interactive) - (rmail-summary-delete-forward t)) - -(defun rmail-summary-mark-deleted (&optional n undel) - ;; Since third arg is t, this only alters the summary, not the Rmail buf. - (and n (rmail-summary-goto-msg n t t)) - (or (eobp) - (not (overlay-get rmail-summary-overlay 'face)) - (let ((buffer-read-only nil)) - (skip-chars-forward " ") - (skip-chars-forward "[0-9]") - (if undel - (if (looking-at "D") - (progn (delete-char 1) (insert " "))) - (delete-char 1) - (insert "D")))) - (beginning-of-line)) - -(defun rmail-summary-mark-undeleted (n) - (rmail-summary-mark-deleted n t)) - -(defun rmail-summary-deleted-p (&optional n) - (save-excursion - (and n (rmail-summary-goto-msg n nil t)) - (skip-chars-forward " ") - (skip-chars-forward "[0-9]") - (looking-at "D"))) - -(defun rmail-summary-undelete (&optional arg) - "Undelete current message. -Optional prefix ARG means undelete ARG previous messages." - (interactive "p") - (if (/= arg 1) - (rmail-summary-undelete-many arg) - (let ((buffer-read-only nil) - (opoint (point))) - (end-of-line) - (cond ((re-search-backward "\\(^ *[0-9]*\\)\\(D\\)" nil t) - (replace-match "\\1 ") - (rmail-summary-goto-msg) - (pop-to-buffer rmail-buffer) - (and (rmail-message-deleted-p rmail-current-message) - (rmail-undelete-previous-message)) - (pop-to-buffer rmail-summary-buffer)) - (t (goto-char opoint)))))) - -(defun rmail-summary-undelete-many (&optional n) - "Undelete all deleted msgs, optional prefix arg N means undelete N prev msgs." - (interactive "P") - (save-excursion - (set-buffer rmail-buffer) - (let* ((init-msg (if n rmail-current-message rmail-total-messages)) - (rmail-current-message init-msg) - (n (or n rmail-total-messages)) - (msgs-undeled 0)) - (while (and (> rmail-current-message 0) - (< msgs-undeled n)) - (if (rmail-message-deleted-p rmail-current-message) - (progn (rmail-set-attribute "deleted" nil) - (setq msgs-undeled (1+ msgs-undeled)))) - (setq rmail-current-message (1- rmail-current-message))) - (set-buffer rmail-summary-buffer) - (setq rmail-current-message init-msg msgs-undeled 0) - (while (and (> rmail-current-message 0) - (< msgs-undeled n)) - (if (rmail-summary-deleted-p rmail-current-message) - (progn (rmail-summary-mark-undeleted rmail-current-message) - (setq msgs-undeled (1+ msgs-undeled)))) - (setq rmail-current-message (1- rmail-current-message)))) - (rmail-summary-goto-msg))) - -;; Rmail Summary mode is suitable only for specially formatted data. -(put 'rmail-summary-mode 'mode-class 'special) - -(defun rmail-summary-mode () - "Rmail Summary Mode is invoked from Rmail Mode by using \\<rmail-mode-map>\\[rmail-summary]. -As commands are issued in the summary buffer, they are applied to the -corresponding mail messages in the rmail buffer. - -All normal editing commands are turned off. -Instead, nearly all the Rmail mode commands are available, -though many of them move only among the messages in the summary. - -These additional commands exist: - -\\[rmail-summary-undelete-many] Undelete all or prefix arg deleted messages. -\\[rmail-summary-wipe] Delete the summary and go to the Rmail buffer. - -Commands for sorting the summary: - -\\[rmail-summary-sort-by-date] Sort by date. -\\[rmail-summary-sort-by-subject] Sort by subject. -\\[rmail-summary-sort-by-author] Sort by author. -\\[rmail-summary-sort-by-recipient] Sort by recipient. -\\[rmail-summary-sort-by-correspondent] Sort by correspondent. -\\[rmail-summary-sort-by-lines] Sort by lines. -\\[rmail-summary-sort-by-keywords] Sort by keywords." - (interactive) - (kill-all-local-variables) - (setq major-mode 'rmail-summary-mode) - (setq mode-name "RMAIL Summary") - (setq truncate-lines t) - (setq buffer-read-only t) - (set-syntax-table text-mode-syntax-table) - (make-local-variable 'rmail-buffer) - (make-local-variable 'rmail-total-messages) - (make-local-variable 'rmail-current-message) - (setq rmail-current-message nil) - (make-local-variable 'rmail-summary-redo) - (setq rmail-summary-redo nil) - (make-local-variable 'revert-buffer-function) - (make-local-hook 'post-command-hook) - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults '(rmail-summary-font-lock-keywords t)) - (rmail-summary-enable) - (run-hooks 'rmail-summary-mode-hook)) - -;; Summary features need to be disabled during edit mode. -(defun rmail-summary-disable () - (use-local-map text-mode-map) - (remove-hook 'post-command-hook 'rmail-summary-rmail-update t) - (setq revert-buffer-function nil)) - -(defun rmail-summary-enable () - (use-local-map rmail-summary-mode-map) - (add-hook 'post-command-hook 'rmail-summary-rmail-update nil t) - (setq revert-buffer-function 'rmail-update-summary)) - -(defvar rmail-summary-put-back-unseen nil - "Used for communicating between calls to `rmail-summary-rmail-update'. -If it moves to a message within an Incremental Search, and removes -the `unseen' attribute from that message, it sets this flag -so that if the next motion between messages is in the same Incremental -Search, the `unseen' attribute is restored.") - -;; Show in Rmail the message described by the summary line that point is on, -;; but only if the Rmail buffer is already visible. -;; This is a post-command-hook in summary buffers. -(defun rmail-summary-rmail-update () - (let (buffer-read-only) - (save-excursion - ;; If at end of buffer, pretend we are on the last text line. - (if (eobp) - (forward-line -1)) - (beginning-of-line) - (skip-chars-forward " ") - (let ((msg-num (string-to-int (buffer-substring - (point) - (progn (skip-chars-forward "0-9") - (point)))))) - ;; Always leave `unseen' removed - ;; if we get out of isearch mode. - ;; Don't let a subsequent isearch restore that `unseen'. - (if (not isearch-mode) - (setq rmail-summary-put-back-unseen nil)) - - (or (eq rmail-current-message msg-num) - (let ((window (get-buffer-window rmail-buffer)) - (owin (selected-window))) - (if isearch-mode - (save-excursion - (set-buffer rmail-buffer) - ;; If we first saw the previous message in this search, - ;; and we have gone to a different message while searching, - ;; put back `unseen' on the former one. - (rmail-set-attribute "unseen" t - rmail-current-message) - ;; Arrange to do that later, for the new current message, - ;; if it still has `unseen'. - (setq rmail-summary-put-back-unseen - (rmail-message-labels-p msg-num ", ?\\(unseen\\),"))) - (setq rmail-summary-put-back-unseen nil)) - - ;; Go to the desired message. - (setq rmail-current-message msg-num) - - ;; Update the summary to show the message has been seen. - (if (= (following-char) ?-) - (progn - (delete-char 1) - (insert " "))) - - (if window - ;; Using save-window-excursion would cause the new value - ;; of point to get lost. - (unwind-protect - (progn - (select-window window) - (rmail-show-message msg-num t)) - (select-window owin)) - (if (buffer-name rmail-buffer) - (save-excursion - (set-buffer rmail-buffer) - (rmail-show-message msg-num t)))))) - (rmail-summary-update-highlight nil))))) - -(defvar rmail-summary-mode-map nil) - -(if rmail-summary-mode-map - nil - (setq rmail-summary-mode-map (make-keymap)) - (suppress-keymap rmail-summary-mode-map) - (define-key rmail-summary-mode-map "a" 'rmail-summary-add-label) - (define-key rmail-summary-mode-map "b" 'rmail-summary-bury) - (define-key rmail-summary-mode-map "c" 'rmail-summary-continue) - (define-key rmail-summary-mode-map "d" 'rmail-summary-delete-forward) - (define-key rmail-summary-mode-map "\C-d" 'rmail-summary-delete-backward) - (define-key rmail-summary-mode-map "e" 'rmail-summary-edit-current-message) - (define-key rmail-summary-mode-map "f" 'rmail-summary-forward) - (define-key rmail-summary-mode-map "g" 'rmail-summary-get-new-mail) - (define-key rmail-summary-mode-map "h" 'rmail-summary) - (define-key rmail-summary-mode-map "i" 'rmail-summary-input) - (define-key rmail-summary-mode-map "j" 'rmail-summary-goto-msg) - (define-key rmail-summary-mode-map "k" 'rmail-summary-kill-label) - (define-key rmail-summary-mode-map "l" 'rmail-summary-by-labels) - (define-key rmail-summary-mode-map "\e\C-h" 'rmail-summary) - (define-key rmail-summary-mode-map "\e\C-l" 'rmail-summary-by-labels) - (define-key rmail-summary-mode-map "\e\C-r" 'rmail-summary-by-recipients) - (define-key rmail-summary-mode-map "\e\C-s" 'rmail-summary-by-regexp) - (define-key rmail-summary-mode-map "\e\C-t" 'rmail-summary-by-topic) - (define-key rmail-summary-mode-map "m" 'rmail-summary-mail) - (define-key rmail-summary-mode-map "\M-m" 'rmail-summary-retry-failure) - (define-key rmail-summary-mode-map "n" 'rmail-summary-next-msg) - (define-key rmail-summary-mode-map "\en" 'rmail-summary-next-all) - (define-key rmail-summary-mode-map "\e\C-n" 'rmail-summary-next-labeled-message) - (define-key rmail-summary-mode-map "o" 'rmail-summary-output-to-rmail-file) - (define-key rmail-summary-mode-map "\C-o" 'rmail-summary-output) - (define-key rmail-summary-mode-map "p" 'rmail-summary-previous-msg) - (define-key rmail-summary-mode-map "\ep" 'rmail-summary-previous-all) - (define-key rmail-summary-mode-map "\e\C-p" 'rmail-summary-previous-labeled-message) - (define-key rmail-summary-mode-map "q" 'rmail-summary-quit) - (define-key rmail-summary-mode-map "r" 'rmail-summary-reply) - (define-key rmail-summary-mode-map "s" 'rmail-summary-expunge-and-save) - (define-key rmail-summary-mode-map "\es" 'rmail-summary-search) - (define-key rmail-summary-mode-map "t" 'rmail-summary-toggle-header) - (define-key rmail-summary-mode-map "u" 'rmail-summary-undelete) - (define-key rmail-summary-mode-map "\M-u" 'rmail-summary-undelete-many) - (define-key rmail-summary-mode-map "w" 'rmail-summary-wipe) - (define-key rmail-summary-mode-map "x" 'rmail-summary-expunge) - (define-key rmail-summary-mode-map "." 'rmail-summary-beginning-of-message) - (define-key rmail-summary-mode-map "<" 'rmail-summary-first-message) - (define-key rmail-summary-mode-map ">" 'rmail-summary-last-message) - (define-key rmail-summary-mode-map " " 'rmail-summary-scroll-msg-up) - (define-key rmail-summary-mode-map "\177" 'rmail-summary-scroll-msg-down) - (define-key rmail-summary-mode-map "?" 'describe-mode) - (define-key rmail-summary-mode-map "\C-c\C-n" 'rmail-summary-next-same-subject) - (define-key rmail-summary-mode-map "\C-c\C-p" 'rmail-summary-previous-same-subject) - (define-key rmail-summary-mode-map "\C-c\C-s\C-d" - 'rmail-summary-sort-by-date) - (define-key rmail-summary-mode-map "\C-c\C-s\C-s" - 'rmail-summary-sort-by-subject) - (define-key rmail-summary-mode-map "\C-c\C-s\C-a" - 'rmail-summary-sort-by-author) - (define-key rmail-summary-mode-map "\C-c\C-s\C-r" - 'rmail-summary-sort-by-recipient) - (define-key rmail-summary-mode-map "\C-c\C-s\C-c" - 'rmail-summary-sort-by-correspondent) - (define-key rmail-summary-mode-map "\C-c\C-s\C-l" - 'rmail-summary-sort-by-lines) - (define-key rmail-summary-mode-map "\C-c\C-s\C-k" - 'rmail-summary-sort-by-keywords) - ) - -;;; Menu bar bindings. - -(define-key rmail-summary-mode-map [menu-bar] (make-sparse-keymap)) - -(define-key rmail-summary-mode-map [menu-bar classify] - (cons "Classify" (make-sparse-keymap "Classify"))) - -(define-key rmail-summary-mode-map [menu-bar classify output-menu] - '("Output (Rmail Menu)..." . rmail-summary-output-menu)) - -(define-key rmail-summary-mode-map [menu-bar classify input-menu] - '("Input Rmail File (menu)..." . rmail-input-menu)) - -(define-key rmail-summary-mode-map [menu-bar classify input-menu] - '(nil)) - -(define-key rmail-summary-mode-map [menu-bar classify output-menu] - '(nil)) - -(define-key rmail-summary-mode-map [menu-bar classify output-inbox] - '("Output (inbox)..." . rmail-summary-output)) - -(define-key rmail-summary-mode-map [menu-bar classify output] - '("Output (Rmail)..." . rmail-summary-output-to-rmail-file)) - -(define-key rmail-summary-mode-map [menu-bar classify kill-label] - '("Kill Label..." . rmail-summary-kill-label)) - -(define-key rmail-summary-mode-map [menu-bar classify add-label] - '("Add Label..." . rmail-summary-add-label)) - -(define-key rmail-summary-mode-map [menu-bar summary] - (cons "Summary" (make-sparse-keymap "Summary"))) - -(define-key rmail-summary-mode-map [menu-bar summary senders] - '("By Senders..." . rmail-summary-by-senders)) - -(define-key rmail-summary-mode-map [menu-bar summary labels] - '("By Labels..." . rmail-summary-by-labels)) - -(define-key rmail-summary-mode-map [menu-bar summary recipients] - '("By Recipients..." . rmail-summary-by-recipients)) - -(define-key rmail-summary-mode-map [menu-bar summary topic] - '("By Topic..." . rmail-summary-by-topic)) - -(define-key rmail-summary-mode-map [menu-bar summary regexp] - '("By Regexp..." . rmail-summary-by-regexp)) - -(define-key rmail-summary-mode-map [menu-bar summary all] - '("All" . rmail-summary)) - -(define-key rmail-summary-mode-map [menu-bar mail] - (cons "Mail" (make-sparse-keymap "Mail"))) - -(define-key rmail-summary-mode-map [menu-bar mail rmail-summary-get-new-mail] - '("Get New Mail" . rmail-summary-get-new-mail)) - -(define-key rmail-summary-mode-map [menu-bar mail lambda] - '("----")) - -(define-key rmail-summary-mode-map [menu-bar mail continue] - '("Continue" . rmail-summary-continue)) - -(define-key rmail-summary-mode-map [menu-bar mail resend] - '("Re-send..." . rmail-summary-resend)) - -(define-key rmail-summary-mode-map [menu-bar mail forward] - '("Forward" . rmail-summary-forward)) - -(define-key rmail-summary-mode-map [menu-bar mail retry] - '("Retry" . rmail-summary-retry-failure)) - -(define-key rmail-summary-mode-map [menu-bar mail reply] - '("Reply" . rmail-summary-reply)) - -(define-key rmail-summary-mode-map [menu-bar mail mail] - '("Mail" . rmail-summary-mail)) - -(define-key rmail-summary-mode-map [menu-bar delete] - (cons "Delete" (make-sparse-keymap "Delete"))) - -(define-key rmail-summary-mode-map [menu-bar delete expunge/save] - '("Expunge/Save" . rmail-summary-expunge-and-save)) - -(define-key rmail-summary-mode-map [menu-bar delete expunge] - '("Expunge" . rmail-summary-expunge)) - -(define-key rmail-summary-mode-map [menu-bar delete undelete] - '("Undelete" . rmail-summary-undelete)) - -(define-key rmail-summary-mode-map [menu-bar delete delete] - '("Delete" . rmail-summary-delete-forward)) - -(define-key rmail-summary-mode-map [menu-bar move] - (cons "Move" (make-sparse-keymap "Move"))) - -(define-key rmail-summary-mode-map [menu-bar move search-back] - '("Search Back..." . rmail-summary-search-backward)) - -(define-key rmail-summary-mode-map [menu-bar move search] - '("Search..." . rmail-summary-search)) - -(define-key rmail-summary-mode-map [menu-bar move previous] - '("Previous Nondeleted" . rmail-summary-previous-msg)) - -(define-key rmail-summary-mode-map [menu-bar move next] - '("Next Nondeleted" . rmail-summary-next-msg)) - -(define-key rmail-summary-mode-map [menu-bar move last] - '("Last" . rmail-summary-last-message)) - -(define-key rmail-summary-mode-map [menu-bar move first] - '("First" . rmail-summary-first-message)) - -(define-key rmail-summary-mode-map [menu-bar move previous] - '("Previous" . rmail-summary-previous-all)) - -(define-key rmail-summary-mode-map [menu-bar move next] - '("Next" . rmail-summary-next-all)) - -(defvar rmail-summary-overlay nil) -(put 'rmail-summary-overlay 'permanent-local t) - -;; Go to message N in the summary buffer which is current, -;; and in the corresponding Rmail buffer. -;; If N is nil, use the message corresponding to point in the summary -;; and move to that message in the Rmail buffer. - -;; If NOWARN, don't say anything if N is out of range. -;; If SKIP-RMAIL, don't do anything to the Rmail buffer. - -(defun rmail-summary-goto-msg (&optional n nowarn skip-rmail) - (interactive "P") - (if (consp n) (setq n (prefix-numeric-value n))) - (if (eobp) (forward-line -1)) - (beginning-of-line) - (let* ((obuf (current-buffer)) - (buf rmail-buffer) - (cur (point)) - message-not-found - (curmsg (string-to-int - (buffer-substring (point) - (min (point-max) (+ 5 (point)))))) - (total (save-excursion (set-buffer buf) rmail-total-messages))) - ;; If message number N was specified, find that message's line - ;; or set message-not-found. - ;; If N wasn't specified or that message can't be found. - ;; set N by default. - (if (not n) - (setq n curmsg) - (if (< n 1) - (progn (message "No preceding message") - (setq n 1))) - (if (> n total) - (progn (message "No following message") - (goto-char (point-max)) - (rmail-summary-goto-msg nil nowarn skip-rmail))) - (goto-char (point-min)) - (if (not (re-search-forward (format "^%4d[^0-9]" n) nil t)) - (progn (or nowarn (message "Message %d not found" n)) - (setq n curmsg) - (setq message-not-found t) - (goto-char cur)))) - (beginning-of-line) - (skip-chars-forward " ") - (skip-chars-forward "0-9") - (save-excursion (if (= (following-char) ?-) - (let ((buffer-read-only nil)) - (delete-char 1) - (insert " ")))) - (rmail-summary-update-highlight message-not-found) - (beginning-of-line) - (if skip-rmail - nil - (let ((selwin (selected-window))) - (unwind-protect - (progn (pop-to-buffer buf) - (rmail-show-message n)) - (select-window selwin) - ;; The actions above can alter the current buffer. Preserve it. - (set-buffer obuf)))))) - -;; Update the highlighted line in an rmail summary buffer. -;; That should be current. We highlight the line point is on. -;; If NOT-FOUND is non-nil, we turn off highlighting. -(defun rmail-summary-update-highlight (not-found) - ;; Make sure we have an overlay to use. - (or rmail-summary-overlay - (progn - (make-local-variable 'rmail-summary-overlay) - (setq rmail-summary-overlay (make-overlay (point) (point))))) - ;; If this message is in the summary, use the overlay to highlight it. - ;; Otherwise, don't highlight anything. - (if not-found - (overlay-put rmail-summary-overlay 'face nil) - (move-overlay rmail-summary-overlay - (save-excursion (beginning-of-line) - (skip-chars-forward " ") - (point)) - (save-excursion (end-of-line) (point))) - (overlay-put rmail-summary-overlay 'face 'highlight))) - -(defun rmail-summary-scroll-msg-up (&optional dist) - "Scroll the Rmail window forward. -If the Rmail window is displaying the end of a message, -advance to the next message." - (interactive "P") - (if (eq dist '-) - (rmail-summary-scroll-msg-down nil) - (let ((rmail-buffer-window (get-buffer-window rmail-buffer))) - (if rmail-buffer-window - (if (let ((rmail-summary-window (selected-window))) - (select-window rmail-buffer-window) - (prog1 - ;; Is EOB visible in the buffer? - (save-excursion - (let ((ht (window-height (selected-window)))) - (move-to-window-line (- ht 2)) - (end-of-line) - (eobp))) - (select-window rmail-summary-window))) - (if (not rmail-summary-scroll-between-messages) - (error "End of buffer") - (rmail-summary-next-msg (or dist 1))) - (let ((other-window-scroll-buffer rmail-buffer)) - (scroll-other-window dist))) - ;; If it isn't visible at all, show the beginning. - (rmail-summary-beginning-of-message))))) - -(defun rmail-summary-scroll-msg-down (&optional dist) - "Scroll the Rmail window backward. -If the Rmail window is now displaying the beginning of a message, -move to the previous message." - (interactive "P") - (if (eq dist '-) - (rmail-summary-scroll-msg-up nil) - (let ((rmail-buffer-window (get-buffer-window rmail-buffer))) - (if rmail-buffer-window - (if (let ((rmail-summary-window (selected-window))) - (select-window rmail-buffer-window) - (prog1 - ;; Is BOB visible in the buffer? - (save-excursion - (move-to-window-line 0) - (beginning-of-line) - (bobp)) - (select-window rmail-summary-window))) - (if (not rmail-summary-scroll-between-messages) - (error "Beginning of buffer") - (rmail-summary-previous-msg (or dist 1))) - (let ((other-window-scroll-buffer rmail-buffer)) - (scroll-other-window-down dist))) - ;; If it isn't visible at all, show the beginning. - (rmail-summary-beginning-of-message))))) - -(defun rmail-summary-beginning-of-message () - "Show current message from the beginning." - (interactive) - (if (and (one-window-p) (not pop-up-frames)) - ;; If there is just one window, put the summary on the top. - (let ((buffer rmail-buffer)) - (split-window (selected-window) rmail-summary-window-size) - (select-window (frame-first-window)) - (pop-to-buffer rmail-buffer) - ;; If pop-to-buffer did not use that window, delete that - ;; window. (This can happen if it uses another frame.) - (or (eq buffer (window-buffer (next-window (frame-first-window)))) - (delete-other-windows))) - (pop-to-buffer rmail-buffer)) - (beginning-of-buffer) - (pop-to-buffer rmail-summary-buffer)) - -(defun rmail-summary-bury () - "Bury the Rmail buffer and the Rmail summary buffer." - (interactive) - (let ((buffer-to-bury (current-buffer))) - (let (window) - (while (setq window (get-buffer-window rmail-buffer)) - (set-window-buffer window (other-buffer rmail-buffer))) - (bury-buffer rmail-buffer)) - (switch-to-buffer (other-buffer buffer-to-bury)) - (bury-buffer buffer-to-bury))) - -(defun rmail-summary-quit () - "Quit out of Rmail and Rmail summary." - (interactive) - (rmail-summary-wipe) - (rmail-quit)) - -(defun rmail-summary-wipe () - "Kill and wipe away Rmail summary, remaining within Rmail." - (interactive) - (save-excursion (set-buffer rmail-buffer) (setq rmail-summary-buffer nil)) - (let ((local-rmail-buffer rmail-buffer)) - (kill-buffer (current-buffer)) - ;; Delete window if not only one. - (if (not (eq (selected-window) (next-window nil 'no-minibuf))) - (delete-window)) - ;; Switch windows to the rmail buffer, or switch to it in this window. - (pop-to-buffer local-rmail-buffer))) - -(defun rmail-summary-expunge () - "Actually erase all deleted messages and recompute summary headers." - (interactive) - (save-excursion - (set-buffer rmail-buffer) - (rmail-only-expunge)) - (rmail-update-summary)) - -(defun rmail-summary-expunge-and-save () - "Expunge and save RMAIL file." - (interactive) - (save-excursion - (set-buffer rmail-buffer) - (rmail-only-expunge)) - (rmail-update-summary) - (save-excursion - (set-buffer rmail-buffer) - (save-buffer)) - (set-buffer-modified-p nil)) - -(defun rmail-summary-get-new-mail () - "Get new mail and recompute summary headers." - (interactive) - (let (msg) - (save-excursion - (set-buffer rmail-buffer) - (rmail-get-new-mail) - ;; Get the proper new message number. - (setq msg rmail-current-message)) - ;; Make sure that message is displayed. - (or (zerop msg) - (rmail-summary-goto-msg msg)))) - -(defun rmail-summary-input (filename) - "Run Rmail on file FILENAME." - (interactive "FRun rmail on RMAIL file: ") - ;; We switch windows here, then display the other Rmail file there. - (pop-to-buffer rmail-buffer) - (rmail filename)) - -(defun rmail-summary-first-message () - "Show first message in Rmail file from summary buffer." - (interactive) - (beginning-of-buffer)) - -(defun rmail-summary-last-message () - "Show last message in Rmail file from summary buffer." - (interactive) - (end-of-buffer) - (forward-line -1)) - -(defvar rmail-summary-edit-map nil) -(if rmail-summary-edit-map - nil - (setq rmail-summary-edit-map - (nconc (make-sparse-keymap) text-mode-map)) - (define-key rmail-summary-edit-map "\C-c\C-c" 'rmail-cease-edit) - (define-key rmail-summary-edit-map "\C-c\C-]" 'rmail-abort-edit)) - -(defun rmail-summary-edit-current-message () - "Edit the contents of this message." - (interactive) - (pop-to-buffer rmail-buffer) - (rmail-edit-current-message) - (use-local-map rmail-summary-edit-map)) - -(defun rmail-summary-cease-edit () - "Finish editing message, then go back to Rmail summary buffer." - (interactive) - (rmail-cease-edit) - (pop-to-buffer rmail-summary-buffer)) - -(defun rmail-summary-abort-edit () - "Abort edit of current message; restore original contents. -Go back to summary buffer." - (interactive) - (rmail-abort-edit) - (pop-to-buffer rmail-summary-buffer)) - -(defun rmail-summary-search-backward (regexp &optional n) - "Show message containing next match for REGEXP. -Prefix argument gives repeat count; negative argument means search -backwards (through earlier messages). -Interactively, empty argument means use same regexp used last time." - (interactive - (let* ((reversep (>= (prefix-numeric-value current-prefix-arg) 0)) - (prompt - (concat (if reversep "Reverse " "") "Rmail search (regexp): ")) - regexp) - (if rmail-search-last-regexp - (setq prompt (concat prompt - "(default " - rmail-search-last-regexp - ") "))) - (setq regexp (read-string prompt)) - (cond ((not (equal regexp "")) - (setq rmail-search-last-regexp regexp)) - ((not rmail-search-last-regexp) - (error "No previous Rmail search string"))) - (list rmail-search-last-regexp - (prefix-numeric-value current-prefix-arg)))) - ;; Don't use save-excursion because that prevents point from moving - ;; properly in the summary buffer. - (let ((buffer (current-buffer))) - (unwind-protect - (progn - (set-buffer rmail-buffer) - (rmail-search regexp (- n))) - (set-buffer buffer)))) - -(defun rmail-summary-search (regexp &optional n) - "Show message containing next match for REGEXP. -Prefix argument gives repeat count; negative argument means search -backwards (through earlier messages). -Interactively, empty argument means use same regexp used last time." - (interactive - (let* ((reversep (< (prefix-numeric-value current-prefix-arg) 0)) - (prompt - (concat (if reversep "Reverse " "") "Rmail search (regexp): ")) - regexp) - (if rmail-search-last-regexp - (setq prompt (concat prompt - "(default " - rmail-search-last-regexp - ") "))) - (setq regexp (read-string prompt)) - (cond ((not (equal regexp "")) - (setq rmail-search-last-regexp regexp)) - ((not rmail-search-last-regexp) - (error "No previous Rmail search string"))) - (list rmail-search-last-regexp - (prefix-numeric-value current-prefix-arg)))) - ;; Don't use save-excursion because that prevents point from moving - ;; properly in the summary buffer. - (let ((buffer (current-buffer))) - (unwind-protect - (progn - (set-buffer rmail-buffer) - (rmail-search regexp n)) - (set-buffer buffer)))) - -(defun rmail-summary-toggle-header () - "Show original message header if pruned header currently shown, or vice versa." - (interactive) - (save-excursion - (set-buffer rmail-buffer) - (rmail-toggle-header)) - ;; Inside save-excursion, some changes to point in the RMAIL buffer are lost. - ;; Set point to point-min in the RMAIL buffer, if it is visible. - (let ((window (get-buffer-window rmail-buffer))) - (if window - ;; Using save-window-excursion would lose the new value of point. - (let ((owin (selected-window))) - (unwind-protect - (progn - (select-window window) - (goto-char (point-min))) - (select-window owin)))))) - - -(defun rmail-summary-add-label (label) - "Add LABEL to labels associated with current Rmail message. -Completion is performed over known labels when reading." - (interactive (list (save-excursion - (set-buffer rmail-buffer) - (rmail-read-label "Add label")))) - (save-excursion - (set-buffer rmail-buffer) - (rmail-add-label label))) - -(defun rmail-summary-kill-label (label) - "Remove LABEL from labels associated with current Rmail message. -Completion is performed over known labels when reading." - (interactive (list (save-excursion - (set-buffer rmail-buffer) - (rmail-read-label "Kill label")))) - (save-excursion - (set-buffer rmail-buffer) - (rmail-set-label label nil))) - -;;;; *** Rmail Summary Mailing Commands *** - -(defun rmail-summary-mail () - "Send mail in another window. -While composing the message, use \\[mail-yank-original] to yank the -original message into it." - (interactive) - (let ((window (get-buffer-window rmail-buffer))) - (if window - (select-window window) - (set-buffer rmail-buffer))) - (rmail-start-mail nil nil nil nil nil (current-buffer)) - (use-local-map (copy-keymap (current-local-map))) - (define-key (current-local-map) - "\C-c\C-c" 'rmail-summary-send-and-exit)) - -(defun rmail-summary-continue () - "Continue composing outgoing message previously being composed." - (interactive) - (let ((window (get-buffer-window rmail-buffer))) - (if window - (select-window window) - (set-buffer rmail-buffer))) - (rmail-start-mail t)) - -(defun rmail-summary-reply (just-sender) - "Reply to the current message. -Normally include CC: to all other recipients of original message; -prefix argument means ignore them. While composing the reply, -use \\[mail-yank-original] to yank the original message into it." - (interactive "P") - (let ((window (get-buffer-window rmail-buffer))) - (if window - (select-window window) - (set-buffer rmail-buffer))) - (rmail-reply just-sender) - (use-local-map (copy-keymap (current-local-map))) - (define-key (current-local-map) - "\C-c\C-c" 'rmail-summary-send-and-exit)) - -(defun rmail-summary-retry-failure () - "Edit a mail message which is based on the contents of the current message. -For a message rejected by the mail system, extract the interesting headers and -the body of the original message; otherwise copy the current message." - (interactive) - (let ((window (get-buffer-window rmail-buffer))) - (if window - (select-window window) - (set-buffer rmail-buffer))) - (rmail-retry-failure) - (use-local-map (copy-keymap (current-local-map))) - (define-key (current-local-map) - "\C-c\C-c" 'rmail-summary-send-and-exit)) - -(defun rmail-summary-send-and-exit () - "Send mail reply and return to summary buffer." - (interactive) - (mail-send-and-exit t)) - -(defun rmail-summary-forward (resend) - "Forward the current message to another user. -With prefix argument, \"resend\" the message instead of forwarding it; -see the documentation of `rmail-resend'." - (interactive "P") - (save-excursion - (let ((window (get-buffer-window rmail-buffer))) - (if window - (select-window window) - (set-buffer rmail-buffer))) - (rmail-forward resend) - (use-local-map (copy-keymap (current-local-map))) - (define-key (current-local-map) - "\C-c\C-c" 'rmail-summary-send-and-exit))) - -(defun rmail-summary-resend () - "Resend current message using 'rmail-resend'." - (interactive) - (save-excursion - (let ((window (get-buffer-window rmail-buffer))) - (if window - (select-window window) - (set-buffer rmail-buffer))) - (call-interactively 'rmail-resend))) - -;; Summary output commands. - -(defun rmail-summary-output-to-rmail-file (&optional file-name) - "Append the current message to an Rmail file named FILE-NAME. -If the file does not exist, ask if it should be created. -If file is being visited, the message is appended to the Emacs -buffer visiting that file." - (interactive) - (save-excursion - (set-buffer rmail-buffer) - (let ((rmail-delete-after-output nil)) - (if file-name - (rmail-output-to-rmail-file file-name) - (call-interactively 'rmail-output-to-rmail-file)))) - (if rmail-delete-after-output - (rmail-summary-delete-forward nil))) - -(defun rmail-summary-output-menu () - "Output current message to another Rmail file, chosen with a menu. -Also set the default for subsequent \\[rmail-output-to-rmail-file] commands. -The variables `rmail-secondary-file-directory' and -`rmail-secondary-file-regexp' control which files are offered in the menu." - (interactive) - (save-excursion - (set-buffer rmail-buffer) - (let ((rmail-delete-after-output nil)) - (call-interactively 'rmail-output-menu))) - (if rmail-delete-after-output - (rmail-summary-delete-forward nil))) - -(defun rmail-summary-output () - "Append this message to Unix mail file named FILE-NAME." - (interactive) - (save-excursion - (set-buffer rmail-buffer) - (let ((rmail-delete-after-output nil)) - (call-interactively 'rmail-output))) - (if rmail-delete-after-output - (rmail-summary-delete-forward nil))) - -(defun rmail-summary-construct-io-menu () - (let ((files (rmail-find-all-files rmail-secondary-file-directory))) - (if files - (progn - (define-key rmail-summary-mode-map [menu-bar classify input-menu] - (cons "Input Rmail File" - (rmail-list-to-menu "Input Rmail File" - files - 'rmail-summary-input))) - (define-key rmail-summary-mode-map [menu-bar classify output-menu] - (cons "Output Rmail File" - (rmail-list-to-menu "Output Rmail File" - files - 'rmail-summary-output-to-rmail-file)))) - (define-key rmail-summary-mode-map [menu-bar classify input-menu] - '("Input Rmail File" . rmail-disable-menu)) - (define-key rmail-summary-mode-map [menu-bar classify output-menu] - '("Output Rmail File" . rmail-disable-menu))))) - - -;; Sorting messages in Rmail Summary buffer. - -(defun rmail-summary-sort-by-date (reverse) - "Sort messages of current Rmail summary by date. -If prefix argument REVERSE is non-nil, sort them in reverse order." - (interactive "P") - (rmail-sort-from-summary (function rmail-sort-by-date) reverse)) - -(defun rmail-summary-sort-by-subject (reverse) - "Sort messages of current Rmail summary by subject. -If prefix argument REVERSE is non-nil, sort them in reverse order." - (interactive "P") - (rmail-sort-from-summary (function rmail-sort-by-subject) reverse)) - -(defun rmail-summary-sort-by-author (reverse) - "Sort messages of current Rmail summary by author. -If prefix argument REVERSE is non-nil, sort them in reverse order." - (interactive "P") - (rmail-sort-from-summary (function rmail-sort-by-author) reverse)) - -(defun rmail-summary-sort-by-recipient (reverse) - "Sort messages of current Rmail summary by recipient. -If prefix argument REVERSE is non-nil, sort them in reverse order." - (interactive "P") - (rmail-sort-from-summary (function rmail-sort-by-recipient) reverse)) - -(defun rmail-summary-sort-by-correspondent (reverse) - "Sort messages of current Rmail summary by other correspondent. -If prefix argument REVERSE is non-nil, sort them in reverse order." - (interactive "P") - (rmail-sort-from-summary (function rmail-sort-by-correspondent) reverse)) - -(defun rmail-summary-sort-by-lines (reverse) - "Sort messages of current Rmail summary by lines of the message. -If prefix argument REVERSE is non-nil, sort them in reverse order." - (interactive "P") - (rmail-sort-from-summary (function rmail-sort-by-lines) reverse)) - -(defun rmail-summary-sort-by-keywords (reverse labels) - "Sort messages of current Rmail summary by keywords. -If prefix argument REVERSE is non-nil, sort them in reverse order. -KEYWORDS is a comma-separated list of labels." - (interactive "P\nsSort by labels: ") - (rmail-sort-from-summary - (function (lambda (reverse) - (rmail-sort-by-keywords reverse labels))) - reverse)) - -(defun rmail-sort-from-summary (sortfun reverse) - "Sort Rmail messages from Summary buffer and update it after sorting." - (require 'rmailsort) - (let ((selwin (selected-window))) - (unwind-protect - (progn (pop-to-buffer rmail-buffer) - (funcall sortfun reverse)) - (select-window selwin)))) - -;;; rmailsum.el ends here diff --git a/lisp/mail/rnews.el b/lisp/mail/rnews.el deleted file mode 100644 index d748fe49958..00000000000 --- a/lisp/mail/rnews.el +++ /dev/null @@ -1,989 +0,0 @@ -;;; rnews.el --- USENET news reader for gnu emacs - -;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: news - -;; 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. - -;;; Change Log: - -;; Created Sun Mar 10,1985 at 21:35:01 ads and sundar@hernes.ai.mit.edu -;; Should do the point pdl stuff sometime -;; finito except pdl.... Sat Mar 16,1985 at 06:43:44 -;; lets keep the summary stuff out until we get it working .. -;; sundar@hermes.ai.mit.edu Wed Apr 10,1985 at 16:32:06 -;; hack slash maim. mly@prep.ai.mit.edu Thu 18 Apr, 1985 06:11:14 -;; modified to correct reentrance bug, to not bother with groups that -;; received no new traffic since last read completely, to find out -;; what traffic a group has available much more quickly when -;; possible, to do some completing reads for group names - should -;; be much faster... -;; KING@KESTREL.arpa, Thu Mar 13 09:03:28 1986 -;; made news-{next,previous}-group skip groups with no new messages; and -;; added checking for unsubscribed groups to news-add-news-group -;; tower@prep.ai.mit.edu Jul 18 1986 -;; bound rmail-output to C-o; and changed header-field commands binding to -;; agree with the new C-c C-f usage in sendmail -;; tower@prep Sep 3 1986 -;; added news-rotate-buffer-body -;; tower@prep Oct 17 1986 -;; made messages more user friendly, cleaned up news-inews -;; move posting and mail code to new file rnewpost.el -;; tower@prep Oct 29 1986 -;; added caesar-region, rename news-caesar-buffer-body, hacked accordingly -;; tower@prep Nov 21 1986 -;; added tower@prep 22 Apr 87 - -;;; Code: - -(require 'mail-utils) - -(autoload 'rmail-output "rmailout" - "Append this message to Unix mail file named FILE-NAME." - t) - -(autoload 'news-reply "rnewspost" - "Compose and post a reply to the current article on USENET. -While composing the reply, use \\[mail-yank-original] to yank the original -message into it." - t) - -(autoload 'news-mail-other-window "rnewspost" - "Send mail in another window. -While composing the message, use \\[mail-yank-original] to yank the -original message into it." - t) - -(autoload 'news-post-news "rnewspost" - "Begin editing a new USENET news article to be posted." - t) - -(autoload 'news-mail-reply "rnewspost" - "Mail a reply to the author of the current article. -While composing the reply, use \\[mail-yank-original] to yank the original -message into it." - t) - -(defvar news-group-hook-alist nil - "Alist of (GROUP-REGEXP . HOOK) pairs. -Just before displaying a message, each HOOK is called -if its GROUP-REGEXP matches the current newsgroup name.") - -(defvar rmail-last-file (expand-file-name "~/mbox.news")) - -;Now in paths.el. -;(defvar news-path "/usr/spool/news/" -; "The root directory below which all news files are stored.") - -(defvar news-startup-file "$HOME/.newsrc" "Contains ~/.newsrc") -(defvar news-certification-file "$HOME/.news-dates" "Contains ~/.news-dates") - -;; random headers that we decide to ignore. -(defvar news-ignored-headers - "^Path:\\|^Posting-Version:\\|^Article-I.D.:\\|^Expires:\\|^Date-Received:\\|^References:\\|^Control:\\|^Xref:\\|^Lines:\\|^Posted:\\|^Relay-Version:\\|^Message-ID:\\|^Nf-ID:\\|^Nf-From:\\|^Approved:\\|^Sender:" - "All random fields within the header of a message.") - -(defvar news-mode-map nil) -(defvar news-read-first-time-p t) -;; Contains the (dotified) news groups of which you are a member. -(defvar news-user-group-list nil) - -(defvar news-current-news-group nil) -(defvar news-current-group-begin nil) -(defvar news-current-group-end nil) -(defvar news-current-certifications nil - "An assoc list of a group name and the time at which it is -known that the group had no new traffic") -(defvar news-current-certifiable nil - "The time when the directory we are now working on was written") - -(defvar news-message-filter nil - "User specifiable filter function that will be called during -formatting of the news file") - -;(defvar news-mode-group-string "Starting-Up" -; "Mode line group name info is held in this variable") -(defvar news-list-of-files nil - "Global variable in which we store the list of files -associated with the current newsgroup") -(defvar news-list-of-files-possibly-bogus nil - "variable indicating we only are guessing at which files are available. -Not currently used.") - -;; association list in which we store lists of the form -;; (pointified-group-name (first last old-last)) -(defvar news-group-article-assoc nil) - -(defvar news-current-message-number 0 "Displayed Article Number") -(defvar news-total-current-group 0 "Total no of messages in group") - -(defvar news-unsubscribe-groups ()) -(defvar news-point-pdl () "List of visited news messages.") -(defvar news-no-jumps-p t) -(defvar news-buffer () "Buffer into which news files are read.") - -(defmacro news-push (item ref) - (list 'setq ref (list 'cons item ref))) - -(defmacro news-cadr (x) (list 'car (list 'cdr x))) -(defmacro news-cdar (x) (list 'cdr (list 'car x))) -(defmacro news-caddr (x) (list 'car (list 'cdr (list 'cdr x)))) -(defmacro news-cadar (x) (list 'car (list 'cdr (list 'car x)))) -(defmacro news-caadr (x) (list 'car (list 'car (list 'cdr x)))) -(defmacro news-cdadr (x) (list 'cdr (list 'car (list 'cdr x)))) - -(defmacro news-wins (pfx index) - (` (file-exists-p (concat (, pfx) "/" (int-to-string (, index)))))) - -(defvar news-max-plausible-gap 2 - "* In an rnews directory, the maximum possible gap size. -A gap is a sequence of missing messages between two messages that exist. -An empty file does not contribute to a gap -- it ends one.") - -(defun news-find-first-and-last (prefix base) - (and (news-wins prefix base) - (cons (news-find-first-or-last prefix base -1) - (news-find-first-or-last prefix base 1)))) - -(defmacro news-/ (a1 a2) -;; a form of / that guarantees that (/ -1 2) = 0 - (if (zerop (/ -1 2)) - (` (/ (, a1) (, a2))) - (` (if (< (, a1) 0) - (- (/ (- (, a1)) (, a2))) - (/ (, a1) (, a2)))))) - -(defun news-find-first-or-last (pfx base dirn) - ;; first use powers of two to find a plausible ceiling - (let ((original-dir dirn)) - (while (news-wins pfx (+ base dirn)) - (setq dirn (* dirn 2))) - (setq dirn (news-/ dirn 2)) - ;; Then use a binary search to find the high water mark - (let ((offset (news-/ dirn 2))) - (while (/= offset 0) - (if (news-wins pfx (+ base dirn offset)) - (setq dirn (+ dirn offset))) - (setq offset (news-/ offset 2)))) - ;; If this high-water mark is bogus, recurse. - (let ((offset (* news-max-plausible-gap original-dir))) - (while (and (/= offset 0) (not (news-wins pfx (+ base dirn offset)))) - (setq offset (- offset original-dir))) - (if (= offset 0) - (+ base dirn) - (news-find-first-or-last pfx (+ base dirn offset) original-dir))))) - -(defun rnews () -"Read USENET news for groups for which you are a member and add or -delete groups. -You can reply to articles posted and send articles to any group. - -Type \\[describe-mode] once reading news to get a list of rnews commands." - (interactive) - (let ((last-buffer (buffer-name))) - (make-local-variable 'rmail-last-file) - (switch-to-buffer (setq news-buffer (get-buffer-create "*news*"))) - (news-mode) - (setq news-buffer-save last-buffer) - (setq buffer-read-only nil) - (erase-buffer) - (setq buffer-read-only t) - (set-buffer-modified-p t) - (sit-for 0) - (message "Getting new USENET news...") - (news-set-mode-line) - (news-get-certifications) - (news-get-new-news))) - -(defun news-group-certification (group) - (cdr-safe (assoc group news-current-certifications))) - - -(defun news-set-current-certifiable () - ;; Record the date that corresponds to the directory you are about to check - (let ((file (concat news-path - (string-subst-char ?/ ?. news-current-news-group)))) - (setq news-current-certifiable - (nth 5 (file-attributes - (or (file-symlink-p file) file)))))) - -(defun news-get-certifications () - ;; Read the certified-read file from last session - (save-excursion - (save-window-excursion - (setq news-current-certifications - (car-safe - (condition-case var - (let* - ((file (substitute-in-file-name news-certification-file)) - (buf (find-file-noselect file))) - (and (file-exists-p file) - (progn - (switch-to-buffer buf 'norecord) - (unwind-protect - (read-from-string (buffer-string)) - (kill-buffer buf))))) - (error nil))))))) - -(defun news-write-certifications () - ;; Write a certification file. - ;; This is an assoc list of group names with doubletons that represent - ;; mod times of the directory when group is read completely. - (save-excursion - (save-window-excursion - (with-output-to-temp-buffer - "*CeRtIfIcAtIoNs*" - (print news-current-certifications)) - (let ((buf (get-buffer "*CeRtIfIcAtIoNs*"))) - (switch-to-buffer buf) - (write-file (substitute-in-file-name news-certification-file)) - (kill-buffer buf))))) - -(defun news-set-current-group-certification () - (let ((cgc (assoc news-current-news-group news-current-certifications))) - (if cgc (setcdr cgc news-current-certifiable) - (news-push (cons news-current-news-group news-current-certifiable) - news-current-certifications)))) - -(defun news-set-minor-modes () - "Creates a minor mode list that has group name, total articles, -and attribute for current article." - (setq news-minor-modes (list (cons 'foo - (concat news-current-message-number - "/" - news-total-current-group - (news-get-attribute-string))))) - ;; Detect Emacs versions 18.16 and up, which display - ;; directly from news-minor-modes by using a list for mode-name. - (or (boundp 'minor-mode-alist) - (setq minor-modes news-minor-modes))) - -(defun news-set-message-counters () - "Scan through current news-groups filelist to figure out how many messages -are there. Set counters for use with minor mode display." - (if (null news-list-of-files) - (setq news-current-message-number 0))) - -(if news-mode-map - nil - (setq news-mode-map (make-keymap)) - (suppress-keymap news-mode-map) - (define-key news-mode-map "." 'beginning-of-buffer) - (define-key news-mode-map " " 'scroll-up) - (define-key news-mode-map "\177" 'scroll-down) - (define-key news-mode-map "n" 'news-next-message) - (define-key news-mode-map "c" 'news-make-link-to-message) - (define-key news-mode-map "p" 'news-previous-message) - (define-key news-mode-map "j" 'news-goto-message) - (define-key news-mode-map "q" 'news-exit) - (define-key news-mode-map "e" 'news-exit) - (define-key news-mode-map "\ej" 'news-goto-news-group) - (define-key news-mode-map "\en" 'news-next-group) - (define-key news-mode-map "\ep" 'news-previous-group) - (define-key news-mode-map "l" 'news-list-news-groups) - (define-key news-mode-map "?" 'describe-mode) - (define-key news-mode-map "g" 'news-get-new-news) - (define-key news-mode-map "f" 'news-reply) - (define-key news-mode-map "m" 'news-mail-other-window) - (define-key news-mode-map "a" 'news-post-news) - (define-key news-mode-map "r" 'news-mail-reply) - (define-key news-mode-map "o" 'news-save-item-in-file) - (define-key news-mode-map "\C-o" 'rmail-output) - (define-key news-mode-map "t" 'news-show-all-headers) - (define-key news-mode-map "x" 'news-force-update) - (define-key news-mode-map "A" 'news-add-news-group) - (define-key news-mode-map "u" 'news-unsubscribe-current-group) - (define-key news-mode-map "U" 'news-unsubscribe-group) - (define-key news-mode-map "\C-c\C-r" 'news-caesar-buffer-body)) - -(defun news-mode () - "News Mode is used by M-x rnews for reading USENET Newsgroups articles. -New readers can find additional help in newsgroup: news.announce.newusers . -All normal editing commands are turned off. -Instead, these commands are available: - -. move point to front of this news article (same as Meta-<). -Space scroll to next screen of this news article. -Delete scroll down previous page of this news article. -n move to next news article, possibly next group. -p move to previous news article, possibly previous group. -j jump to news article specified by numeric position. -M-j jump to news group. -M-n goto next news group. -M-p goto previous news group. -l list all the news groups with current status. -? print this help message. -C-c C-r caesar rotate all letters by 13 places in the article's body (rot13). -g get new USENET news. -f post a reply article to USENET. -a post an original news article. -A add a newsgroup. -o save the current article in the named file (append if file exists). -C-o output this message to a Unix-format mail file (append it). -c \"copy\" (actually link) current or prefix-arg msg to file. - warning: target directory and message file must be on same device - (UNIX magic) -t show all the headers this news article originally had. -q quit reading news after updating .newsrc file. -e exit updating .newsrc file. -m mail a news article. Same as C-x 4 m. -x update last message seen to be the current message. -r mail a reply to this news article. Like m but initializes some fields. -u unsubscribe from current newsgroup. -U unsubscribe from specified newsgroup." - (interactive) - (kill-all-local-variables) - (make-local-variable 'news-read-first-time-p) - (setq news-read-first-time-p t) - (make-local-variable 'news-current-news-group) -; (setq news-current-news-group "??") - (make-local-variable 'news-current-group-begin) - (setq news-current-group-begin 0) - (make-local-variable 'news-current-message-number) - (setq news-current-message-number 0) - (make-local-variable 'news-total-current-group) - (make-local-variable 'news-buffer-save) - (make-local-variable 'version-control) - (setq version-control 'never) - (make-local-variable 'news-point-pdl) -; This breaks it. I don't have time to figure out why. -- RMS -; (make-local-variable 'news-group-article-assoc) - (setq major-mode 'news-mode) - (setq mode-line-process '(news-minor-modes)) - (setq mode-name "NEWS") - (news-set-mode-line) - (set-syntax-table text-mode-syntax-table) - (use-local-map news-mode-map) - (setq local-abbrev-table text-mode-abbrev-table) - (run-hooks 'news-mode-hook)) - -(defun string-subst-char (new old string) - (let (index) - (setq old (regexp-quote (char-to-string old)) - string (substring string 0)) - (while (setq index (string-match old string)) - (aset string index new))) - string) - -;; update read message number -(defmacro news-update-message-read (ngroup nno) - (list 'setcar - (list 'news-cdadr - (list 'assoc ngroup 'news-group-article-assoc)) - nno)) - -(defun news-parse-range (number-string) - "Parse string representing range of numbers of he form <a>-<b> -to a list (a . b)" - (let ((n (string-match "-" number-string))) - (if n - (cons (string-to-int (substring number-string 0 n)) - (string-to-int (substring number-string (1+ n)))) - (setq n (string-to-int number-string)) - (cons n n)))) - -;(defun is-in (elt lis) -; (catch 'foo -; (while lis -; (if (equal (car lis) elt) -; (throw 'foo t) -; (setq lis (cdr lis)))))) - -(defun news-get-new-news () - "Get new USENET news, if there is any for the current user." - (interactive) - (if (not (null news-user-group-list)) - (news-update-newsrc-file)) - (setq news-group-article-assoc ()) - (setq news-user-group-list ()) - (message "Looking up %s file..." news-startup-file) - (let ((file (substitute-in-file-name news-startup-file)) - (temp-user-groups ())) - (save-excursion - (let ((newsrcbuf (find-file-noselect file)) - start end endofline tem) - (set-buffer newsrcbuf) - (goto-char 0) - (while (search-forward ": " nil t) - (setq end (point)) - (beginning-of-line) - (setq start (point)) - (end-of-line) - (setq endofline (point)) - (setq tem (buffer-substring start (- end 2))) - (let ((range (news-parse-range - (buffer-substring end endofline)))) - (if (assoc tem news-group-article-assoc) - (message "You are subscribed twice to %s; I ignore second" - tem) - (setq temp-user-groups (cons tem temp-user-groups) - news-group-article-assoc - (cons (list tem (list (car range) - (cdr range) - (cdr range))) - news-group-article-assoc))))) - (kill-buffer newsrcbuf))) - (setq temp-user-groups (nreverse temp-user-groups)) - (message "Prefrobnicating...") - (switch-to-buffer news-buffer) - (setq news-user-group-list temp-user-groups) - (while (and temp-user-groups - (not (news-read-files-into-buffer - (car temp-user-groups) nil))) - (setq temp-user-groups (cdr temp-user-groups))) - (if (null temp-user-groups) - (message "No news is good news.") - (message "")))) - -(defun news-list-news-groups () - "Display all the news groups to which you belong." - (interactive) - (with-output-to-temp-buffer "*Newsgroups*" - (save-excursion - (set-buffer standard-output) - (insert - "News Group Msg No. News Group Msg No.\n") - (insert - "------------------------- -------------------------\n") - (let ((temp news-user-group-list) - (flag nil)) - (while temp - (let ((item (assoc (car temp) news-group-article-assoc))) - (insert (car item)) - (indent-to (if flag 52 20)) - (insert (int-to-string (news-cadr (news-cadr item)))) - (if flag - (insert "\n") - (indent-to 33)) - (setq temp (cdr temp) flag (not flag)))))))) - -;; Mode line hack -(defun news-set-mode-line () - "Set mode line string to something useful." - (setq mode-line-process - (concat " " - (if (integerp news-current-message-number) - (int-to-string news-current-message-number) - "??") - "/" - (if (integerp news-current-group-end) - (int-to-string news-current-group-end) - news-current-group-end))) - (setq mode-line-buffer-identification - (concat "NEWS: " - news-current-news-group - ;; Enough spaces to pad group name to 17 positions. - (substring " " - 0 (max 0 (- 17 (length news-current-news-group)))))) - (set-buffer-modified-p t) - (sit-for 0)) - -(defun news-goto-news-group (gp) - "Takes a string and goes to that news group." - (interactive (list (completing-read "NewsGroup: " - news-group-article-assoc))) - (message "Jumping to news group %s..." gp) - (news-select-news-group gp) - (message "Jumping to news group %s... done." gp)) - -(defun news-select-news-group (gp) - (let ((grp (assoc gp news-group-article-assoc))) - (if (null grp) - (error "Group %s not subscribed to" gp) - (progn - (news-update-message-read news-current-news-group - (news-cdar news-point-pdl)) - (news-read-files-into-buffer (car grp) nil) - (news-set-mode-line))))) - -(defun news-goto-message (arg) - "Goes to the article ARG in current newsgroup." - (interactive "p") - (if (null current-prefix-arg) - (setq arg (read-no-blanks-input "Go to article: " ""))) - (news-select-message arg)) - -(defun news-select-message (arg) - (if (stringp arg) (setq arg (string-to-int arg))) - (let ((file (concat news-path - (string-subst-char ?/ ?. news-current-news-group) - "/" arg))) - (if (= arg - (or (news-cadr (memq (news-cdar news-point-pdl) news-list-of-files)) - 0)) - (setcdr (car news-point-pdl) arg)) - (setq news-current-message-number arg) - (if (file-exists-p file) - (let ((buffer-read-only nil)) - (news-read-in-file file) - (news-set-mode-line)) - (news-set-mode-line) - (error "Article %d nonexistent" arg)))) - -(defun news-force-update () - "updates the position of last article read in the current news group" - (interactive) - (setcdr (car news-point-pdl) news-current-message-number) - (message "Updated to %d" news-current-message-number)) - -(defun news-next-message (arg) - "Move ARG messages forward within one newsgroup. -Negative ARG moves backward. -If ARG is 1 or -1, moves to next or previous newsgroup if at end." - (interactive "p") - (let ((no (+ arg news-current-message-number))) - (if (or (< no news-current-group-begin) - (> no news-current-group-end)) - (cond ((= arg 1) - (news-set-current-group-certification) - (news-next-group)) - ((= arg -1) - (news-previous-group)) - (t (error "Article out of range"))) - (let ((plist (news-get-motion-lists - news-current-message-number - news-list-of-files))) - (if (< arg 0) - (news-select-message (nth (1- (- arg)) (car (cdr plist)))) - (news-select-message (nth (1- arg) (car plist)))))))) - -(defun news-previous-message (arg) - "Move ARG messages backward in current newsgroup. -With no arg or arg of 1, move one message -and move to previous newsgroup if at beginning. -A negative ARG means move forward." - (interactive "p") - (news-next-message (- arg))) - -(defun news-move-to-group (arg) - "Given arg move forward or backward to a new newsgroup." - (let ((cg news-current-news-group)) - (let ((plist (news-get-motion-lists cg news-user-group-list)) - ngrp) - (if (< arg 0) - (or (setq ngrp (nth (1- (- arg)) (news-cadr plist))) - (error "No previous news groups")) - (or (setq ngrp (nth arg (car plist))) - (error "No more news groups"))) - (news-select-news-group ngrp)))) - -(defun news-next-group () - "Moves to the next user group." - (interactive) -; (message "Moving to next group...") - (news-move-to-group 0) - (while (null news-list-of-files) - (news-move-to-group 0))) -; (message "Moving to next group... done.") - -(defun news-previous-group () - "Moves to the previous user group." - (interactive) -; (message "Moving to previous group...") - (news-move-to-group -1) - (while (null news-list-of-files) - (news-move-to-group -1))) -; (message "Moving to previous group... done.") - -(defun news-get-motion-lists (arg listy) - "Given a msgnumber/group this will return a list of two lists; -one for moving forward and one for moving backward." - (let ((temp listy) - (result ())) - (catch 'out - (while temp - (if (equal (car temp) arg) - (throw 'out (cons (cdr temp) (list result))) - (setq result (nconc (list (car temp)) result)) - (setq temp (cdr temp))))))) - -;; miscellaneous io routines -(defun news-read-in-file (filename) - (erase-buffer) - (let ((start (point))) - (insert-file-contents filename) - (news-convert-format) - ;; Run each hook that applies to the current newsgroup. - (let ((hooks news-group-hook-alist)) - (while hooks - (goto-char start) - (if (string-match (car (car hooks)) news-group-name) - (funcall (cdr (car hooks)))) - (setq hooks (cdr hooks)))) - (goto-char start) - (forward-line 1) - (if (eobp) - (message "(Empty file?)") - (goto-char start)))) - -(defun news-convert-format () - (save-excursion - (save-restriction - (let* ((start (point)) - (end (condition-case () - (progn (search-forward "\n\n") (point)) - (error nil))) - has-from has-date) - (cond (end - (narrow-to-region start end) - (goto-char start) - (setq has-from (search-forward "\nFrom:" nil t)) - (cond ((and (not has-from) has-date) - (goto-char start) - (search-forward "\nDate:") - (beginning-of-line) - (kill-line) (kill-line))) - (news-delete-headers start) - (goto-char start))))))) - -(defun news-show-all-headers () - "Redisplay current news item with all original headers" - (interactive) - (let (news-ignored-headers - (buffer-read-only ())) - (erase-buffer) - (news-set-mode-line) - (news-read-in-file - (concat news-path - (string-subst-char ?/ ?. news-current-news-group) - "/" (int-to-string news-current-message-number))))) - -(defun news-delete-headers (pos) - (goto-char pos) - (and (stringp news-ignored-headers) - (while (re-search-forward news-ignored-headers nil t) - (beginning-of-line) - (delete-region (point) - (progn (re-search-forward "\n[^ \t]") - (forward-char -1) - (point)))))) - -(defun news-exit () - "Quit news reading session and update the .newsrc file." - (interactive) - (if (y-or-n-p "Do you really wanna quit reading news ? ") - (progn (message "Updating %s..." news-startup-file) - (news-update-newsrc-file) - (news-write-certifications) - (message "Updating %s... done" news-startup-file) - (message "Now do some real work") - (and (fboundp 'bury-buffer) (bury-buffer (current-buffer))) - (switch-to-buffer news-buffer-save) - (setq news-user-group-list ())) - (message ""))) - -(defun news-update-newsrc-file () - "Updates the .newsrc file in the users home dir." - (let ((newsrcbuf (find-file-noselect - (substitute-in-file-name news-startup-file))) - (tem news-user-group-list) - group) - (save-excursion - (if (not (null news-current-news-group)) - (news-update-message-read news-current-news-group - (news-cdar news-point-pdl))) - (set-buffer newsrcbuf) - (while tem - (setq group (assoc (car tem) news-group-article-assoc)) - (if (= (news-cadr (news-cadr group)) (news-caddr (news-cadr group))) - nil - (goto-char 0) - (if (search-forward (concat (car group) ": ") nil t) - (kill-line nil) - (insert (car group) ": \n") (backward-char 1)) - (insert (int-to-string (car (news-cadr group))) "-" - (int-to-string (news-cadr (news-cadr group))))) - (setq tem (cdr tem))) - (while news-unsubscribe-groups - (setq group (assoc (car news-unsubscribe-groups) - news-group-article-assoc)) - (goto-char 0) - (if (search-forward (concat (car group) ": ") nil t) - (progn - (backward-char 2) - (kill-line nil) - (insert "! " (int-to-string (car (news-cadr group))) - "-" (int-to-string (news-cadr (news-cadr group)))))) - (setq news-unsubscribe-groups (cdr news-unsubscribe-groups))) - (save-buffer) - (kill-buffer (current-buffer))))) - - -(defun news-unsubscribe-group (group) - "Removes you from newgroup GROUP." - (interactive (list (completing-read "Unsubscribe from group: " - news-group-article-assoc))) - (news-unsubscribe-internal group)) - -(defun news-unsubscribe-current-group () - "Removes you from the newsgroup you are now reading." - (interactive) - (if (y-or-n-p "Do you really want to unsubscribe from this group ? ") - (news-unsubscribe-internal news-current-news-group))) - -(defun news-unsubscribe-internal (group) - (let ((tem (assoc group news-group-article-assoc))) - (if tem - (progn - (setq news-unsubscribe-groups (cons group news-unsubscribe-groups)) - (news-update-message-read group (news-cdar news-point-pdl)) - (if (equal group news-current-news-group) - (news-next-group)) - (message "")) - (error "Not subscribed to group: %s" group)))) - -(defun news-save-item-in-file (file) - "Save the current article that is being read by appending to a file." - (interactive "FSave item in file: ") - (append-to-file (point-min) (point-max) file)) - -(defun news-get-pruned-list-of-files (gp-list end-file-no) - "Given a news group it finds all files in the news group. -The arg must be in slashified format. -Using ls was found to be too slow in a previous version." - (let - ((answer - (and - (not (and end-file-no - (equal (news-set-current-certifiable) - (news-group-certification gp-list)) - (setq news-list-of-files nil - news-list-of-files-possibly-bogus t))) - (let* ((file-directory (concat news-path - (string-subst-char ?/ ?. gp-list))) - tem - (last-winner - (and end-file-no - (news-wins file-directory end-file-no) - (news-find-first-or-last file-directory end-file-no 1)))) - (setq news-list-of-files-possibly-bogus t news-list-of-files nil) - (if last-winner - (progn - (setq news-list-of-files-possibly-bogus t - news-current-group-end last-winner) - (while (> last-winner end-file-no) - (news-push last-winner news-list-of-files) - (setq last-winner (1- last-winner))) - news-list-of-files) - (if (or (not (file-directory-p file-directory)) - (not (file-readable-p file-directory))) - nil - (setq news-list-of-files - (condition-case error - (directory-files file-directory) - (file-error - (if (string= (nth 2 error) "permission denied") - (message "Newsgroup %s is read-protected" - gp-list) - (signal 'file-error (cdr error))) - nil))) - (setq tem news-list-of-files) - (while tem - (if (or (not (string-match "^[0-9]*$" (car tem))) - ;; don't get confused by directories that look like numbers - (file-directory-p - (concat file-directory "/" (car tem))) - (<= (string-to-int (car tem)) end-file-no)) - (setq news-list-of-files - (delq (car tem) news-list-of-files))) - (setq tem (cdr tem))) - (if (null news-list-of-files) - (progn (setq news-current-group-end 0) - nil) - (setq news-list-of-files - (mapcar 'string-to-int news-list-of-files)) - (setq news-list-of-files (sort news-list-of-files '<)) - (setq news-current-group-end - (elt news-list-of-files - (1- (length news-list-of-files)))) - news-list-of-files))))))) - (or answer (progn (news-set-current-group-certification) nil)))) - -(defun news-read-files-into-buffer (group reversep) - (let* ((files-start-end (news-cadr (assoc group news-group-article-assoc))) - (start-file-no (car files-start-end)) - (end-file-no (news-cadr files-start-end)) - (buffer-read-only nil)) - (setq news-current-news-group group) - (setq news-current-message-number nil) - (setq news-current-group-end nil) - (news-set-mode-line) - (news-get-pruned-list-of-files group end-file-no) - (news-set-mode-line) - ;; @@ should be a lot smarter than this if we have to move - ;; @@ around correctly. - (setq news-point-pdl (list (cons (car files-start-end) - (news-cadr files-start-end)))) - (if (null news-list-of-files) - (progn (erase-buffer) - (setq news-current-group-end end-file-no) - (setq news-current-group-begin end-file-no) - (setq news-current-message-number end-file-no) - (news-set-mode-line) -; (message "No new articles in " group " group.") - nil) - (setq news-current-group-begin (car news-list-of-files)) - (if reversep - (setq news-current-message-number news-current-group-end) - (if (> (car news-list-of-files) end-file-no) - (setcdr (car news-point-pdl) (car news-list-of-files))) - (setq news-current-message-number news-current-group-begin)) - (news-set-message-counters) - (news-set-mode-line) - (news-read-in-file (concat news-path - (string-subst-char ?/ ?. group) - "/" - (int-to-string - news-current-message-number))) - (news-set-message-counters) - (news-set-mode-line) - t))) - -(defun news-add-news-group (gp) - "Resubscribe to or add a USENET news group named GROUP (a string)." -; @@ (completing-read ...) -; @@ could be based on news library file ../active (slightly fascist) -; @@ or (expensive to compute) all directories under the news spool directory - (interactive "sAdd news group: ") - (let ((file-dir (concat news-path (string-subst-char ?/ ?. gp)))) - (save-excursion - (if (null (assoc gp news-group-article-assoc)) - (let ((newsrcbuf (find-file-noselect - (substitute-in-file-name news-startup-file)))) - (if (file-directory-p file-dir) - (progn - (switch-to-buffer newsrcbuf) - (goto-char 0) - (if (search-forward (concat gp "! ") nil t) - (progn - (message "Re-subscribing to group %s." gp) - ;;@@ news-unsubscribe-groups isn't being used - ;;(setq news-unsubscribe-groups - ;; (delq gp news-unsubscribe-groups)) - (backward-char 2) - (delete-char 1) - (insert ":")) - (progn - (message - "Added %s to your list of newsgroups." gp) - (end-of-buffer) - (insert gp ": 1-1\n"))) - (search-backward gp nil t) - (let (start end endofline tem) - (search-forward ": " nil t) - (setq end (point)) - (beginning-of-line) - (setq start (point)) - (end-of-line) - (setq endofline (point)) - (setq tem (buffer-substring start (- end 2))) - (let ((range (news-parse-range - (buffer-substring end endofline)))) - (setq news-group-article-assoc - (cons (list tem (list (car range) - (cdr range) - (cdr range))) - news-group-article-assoc)))) - (save-buffer) - (kill-buffer (current-buffer))) - (message "Newsgroup %s doesn't exist." gp))) - (message "Already subscribed to group %s." gp))))) - -(defun news-make-link-to-message (number newname) - "Forges a link to an rnews message numbered number (current if no arg) -Good for hanging on to a message that might or might not be -automatically deleted." - (interactive "P -FName to link to message: ") - (add-name-to-file - (concat news-path - (string-subst-char ?/ ?. news-current-news-group) - "/" (if number - (prefix-numeric-value number) - news-current-message-number)) - newname)) - -;;; caesar-region written by phr@prep.ai.mit.edu Nov 86 -;;; modified by tower@prep Nov 86 -(defun caesar-region (&optional n) - "Caesar rotation of region by N, default 13, for decrypting netnews." - (interactive (if current-prefix-arg ; Was there a prefix arg? - (list (prefix-numeric-value current-prefix-arg)) - (list nil))) - (cond ((not (numberp n)) (setq n 13)) - (t (setq n (mod n 26)))) ;canonicalize N - (if (not (zerop n)) ; no action needed for a rot of 0 - (progn - (if (or (not (boundp 'caesar-translate-table)) - (/= (aref caesar-translate-table ?a) (+ ?a n))) - (let ((i 0) (lower "abcdefghijklmnopqrstuvwxyz") upper) - (message "Building caesar-translate-table...") - (setq caesar-translate-table (make-vector 256 0)) - (while (< i 256) - (aset caesar-translate-table i i) - (setq i (1+ i))) - (setq lower (concat lower lower) upper (upcase lower) i 0) - (while (< i 26) - (aset caesar-translate-table (+ ?a i) (aref lower (+ i n))) - (aset caesar-translate-table (+ ?A i) (aref upper (+ i n))) - (setq i (1+ i))) - (message "Building caesar-translate-table... done"))) - (let ((from (region-beginning)) - (to (region-end)) - (i 0) str len) - (setq str (buffer-substring from to)) - (setq len (length str)) - (while (< i len) - (aset str i (aref caesar-translate-table (aref str i))) - (setq i (1+ i))) - (goto-char from) - (kill-region from to) - (insert str))))) - -;;; news-caesar-buffer-body written by paul@media-lab.mit.edu Wed Oct 1, 1986 -;;; hacked further by tower@prep.ai.mit.edu -(defun news-caesar-buffer-body (&optional rotnum) - "Caesar rotates all letters in the current buffer by 13 places. -Used to encode/decode possibly offensive messages (commonly in net.jokes). -With prefix arg, specifies the number of places to rotate each letter forward. -Mail and USENET news headers are not rotated." - (interactive (if current-prefix-arg ; Was there a prefix arg? - (list (prefix-numeric-value current-prefix-arg)) - (list nil))) - (save-excursion - (let ((buffer-status buffer-read-only)) - (setq buffer-read-only nil) - ;; setup the region - (set-mark (if (progn (goto-char (point-min)) - (search-forward - (concat "\n" - (if (equal major-mode 'news-mode) - "" - mail-header-separator) - "\n") nil t)) - (point) - (point-min))) - (goto-char (point-max)) - (caesar-region rotnum) - (setq buffer-read-only buffer-status)))) - -(provide 'rnews) - -;;; rnews.el ends here diff --git a/lisp/mail/rnewspost.el b/lisp/mail/rnewspost.el deleted file mode 100644 index 3d6be2505f0..00000000000 --- a/lisp/mail/rnewspost.el +++ /dev/null @@ -1,439 +0,0 @@ -;;; rnewspost.el --- USENET news poster/mailer for GNU Emacs - -;; Copyright (C) 1985, 1986, 1987, 1995 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; Keywords: mail, news - -;; 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. - -;;; Change Log: - -;; moved posting and mail code from rnews.el -;; tower@prep.ai.mit.edu Wed Oct 29 1986 -;; brought posting code almost up to the revision of RFC 850 for News 2.11 -;; - couldn't see handling the special meaning of the Keyword: poster -;; - not worth the code space to support the old A news Title: (which -;; Subject: replaced) and Article-I.D.: (which Message-ID: replaced) -;; tower@prep Nov 86 -;; changed C-c C-r key-binding due to rename of news-caesar-buffer-body -;; tower@prep 21 Nov 86 -;; added (require 'rnews) tower@prep 22 Apr 87 -;; restricted call of news-show-all-headers in news-post-news & news-reply -;; tower@prep 28 Apr 87 -;; commented out Posting-Front-End to save USENET bytes tower@prep Jul 31 87 -;; commented out -n and -t args in news-inews tower@prep 15 Oct 87 - -;Now in paths.el. -;(defvar news-inews-program "inews" -; "Function to post news.") - -;; Replying and posting news items are done by these functions. -;; imported from rmail and modified to work with rnews ... -;; Mon Mar 25,1985 at 03:07:04 ads@mit-hermes. -;; this is done so that rnews can operate independently from rmail.el and -;; sendmail and doesn't have to autoload these functions. -;; -;;; >> Nuked by Mly to autoload those functions again, as the duplication of -;;; >> code was making maintenance too difficult. - -;;; Code: - -(require 'sendmail) -(require 'rnews) - -(defvar news-reply-mode-map () "Mode map used by news-reply.") - -(or news-reply-mode-map - (progn - (setq news-reply-mode-map (make-keymap)) - (define-key news-reply-mode-map "\C-c\C-f\C-d" 'news-reply-distribution) - (define-key news-reply-mode-map "\C-c\C-f\C-k" 'news-reply-keywords) - (define-key news-reply-mode-map "\C-c\C-f\C-n" 'news-reply-newsgroups) - (define-key news-reply-mode-map "\C-c\C-f\C-f" 'news-reply-followup-to) - (define-key news-reply-mode-map "\C-c\C-f\C-s" 'mail-subject) - (define-key news-reply-mode-map "\C-c\C-f\C-a" 'news-reply-summary) - (define-key news-reply-mode-map "\C-c\C-t" 'mail-text) - (define-key news-reply-mode-map "\C-c\C-r" 'news-caesar-buffer-body) - (define-key news-reply-mode-map "\C-c\C-w" 'news-reply-signature) - (define-key news-reply-mode-map "\C-c\C-y" 'news-reply-yank-original) - (define-key news-reply-mode-map "\C-c\C-q" 'mail-fill-yanked-message) - (define-key news-reply-mode-map "\C-c\C-c" 'news-inews) - (define-key news-reply-mode-map "\C-c\C-s" 'news-inews) - (define-key news-reply-mode-map [menu-bar] (make-sparse-keymap)) - (define-key news-reply-mode-map [menu-bar fields] - (cons "Fields" (make-sparse-keymap "Fields"))) - (define-key news-reply-mode-map [menu-bar fields news-reply-distribution] - '("Distribution" . news-reply-distribution)) - (define-key news-reply-mode-map [menu-bar fields news-reply-keywords] - '("Keywords" . news-reply-keywords)) - (define-key news-reply-mode-map [menu-bar fields news-reply-newsgroups] - '("Newsgroups" . news-reply-newsgroups)) - (define-key news-reply-mode-map [menu-bar fields news-reply-followup-to] - '("Followup-to" . news-reply-followup-to)) - (define-key news-reply-mode-map [menu-bar fields mail-subject] - '("Subject" . mail-subject)) - (define-key news-reply-mode-map [menu-bar fields news-reply-summary] - '("Summary" . news-reply-summary)) - (define-key news-reply-mode-map [menu-bar fields mail-text] - '("Text" . mail-text)) - (define-key news-reply-mode-map [menu-bar news] - (cons "News" (make-sparse-keymap "News"))) - (define-key news-reply-mode-map [menu-bar news news-caesar-buffer-body] - '("Rot13" . news-caesar-buffer-body)) - (define-key news-reply-mode-map [menu-bar news news-reply-yank-original] - '("Yank Original" . news-reply-yank-original)) - (define-key news-reply-mode-map [menu-bar news mail-fill-yanked-message] - '("Fill Yanked Messages" . mail-fill-yanked-message)) - (define-key news-reply-mode-map [menu-bar news news-inews] - '("Send" . news-inews)))) - -(defun news-reply-mode () - "Major mode for editing news to be posted on USENET. -First-time posters are asked to please read the articles in newsgroup: - news.announce.newusers . -Like Text Mode but with these additional commands: - -C-c C-s news-inews (post the message) C-c C-c news-inews -C-c C-f move to a header field (and create it if there isn't): - C-c C-f C-n move to Newsgroups: C-c C-f C-s move to Subj: - C-c C-f C-f move to Followup-To: C-c C-f C-k move to Keywords: - C-c C-f C-d move to Distribution: C-c C-f C-a move to Summary: -C-c C-y news-reply-yank-original (insert current message, in NEWS). -C-c C-q mail-fill-yanked-message (fill what was yanked). -C-c C-r caesar rotate all letters by 13 places in the article's body (rot13)." - (interactive) - ;; require... - (or (fboundp 'mail-setup) (load "sendmail")) - (kill-all-local-variables) - (make-local-variable 'mail-reply-buffer) - (setq mail-reply-buffer nil) - (set-syntax-table text-mode-syntax-table) - (use-local-map news-reply-mode-map) - (setq local-abbrev-table text-mode-abbrev-table) - (setq major-mode 'news-reply-mode) - (setq mode-name "News Reply") - (make-local-variable 'paragraph-separate) - (make-local-variable 'paragraph-start) - (setq paragraph-start - (concat "^" (regexp-quote mail-header-separator) "$\\|" - paragraph-start)) - (setq paragraph-separate - (concat "^" (regexp-quote mail-header-separator) "$\\|" - paragraph-separate)) - (run-hooks 'text-mode-hook 'news-reply-mode-hook)) - -(defvar news-reply-yank-from "" - "Save `From:' field for `news-reply-yank-original'.") - -(defvar news-reply-yank-message-id "" - "Save `Message-Id:' field for `news-reply-yank-original'.") - -(defun news-reply-yank-original (arg) - "Insert the message being replied to, if any (in Mail mode). -Puts point before the text and mark after. -Indents each nonblank line ARG spaces (default 3). -Just \\[universal-argument] as argument means don't indent -and don't delete any header fields." - (interactive "P") - (mail-yank-original arg) - (exchange-point-and-mark) - (run-hooks 'news-reply-header-hook)) - -(defvar news-reply-header-hook - '(lambda () - (insert "In article " news-reply-yank-message-id - " " news-reply-yank-from " writes:\n\n")) - "Hook for inserting a header at the top of a yanked message.") - -(defun news-reply-newsgroups () - "Move point to end of `Newsgroups:' field. -RFC 850 constrains the `Newsgroups:' field to be a comma-separated list -of valid newsgroup names at your site. For example, - Newsgroups: news.misc,comp.misc,rec.misc" - (interactive) - (expand-abbrev) - (goto-char (point-min)) - (mail-position-on-field "Newsgroups")) - -(defun news-reply-followup-to () - "Move point to end of `Followup-To:' field. Create the field if none. -One usually requests followups to only one newsgroup. -RFC 850 constrains the `Followup-To:' field to be a comma-separated list -of valid newsgroups names at your site, and it must be a subset of the -`Newsgroups:' field. For example: - Newsgroups: news.misc,comp.misc,rec.misc,misc.misc,soc.misc - Followup-To: news.misc,comp.misc,rec.misc" - (interactive) - (expand-abbrev) - (or (mail-position-on-field "Followup-To" t) - (progn (mail-position-on-field "newsgroups") - (insert "\nFollowup-To: "))) - ;; @@ could do a completing read based on the Newsgroups: field to - ;; @@ fill in the Followup-To: field -) - -(defun news-reply-distribution () - "Move point to end of `Distribution:' optional field. -Create the field if none. Without this field the posting goes to all of -USENET. The field is used to restrict the posting to parts of USENET." - (interactive) - (expand-abbrev) - (mail-position-on-field "Distribution") - ;; @@could do a completing read based on the news library file: - ;; @@ ../distributions to fill in the field. - ) - -(defun news-reply-keywords () - "Move point to end of `Keywords:' optional field. Create the field if none. -Used as an aid to the news reader, it can contain a few, well selected keywords -identifying the message." - (interactive) - (expand-abbrev) - (mail-position-on-field "Keywords")) - -(defun news-reply-summary () - "Move point to end of `Summary:' optional field. Create the field if none. -Used as an aid to the news reader, it can contain a succinct -summary (abstract) of the message." - (interactive) - (expand-abbrev) - (mail-position-on-field "Summary")) - -(defun news-reply-signature () - "The inews program appends `~/.signature' automatically." - (interactive) - (message "Posting news will append your signature automatically.")) - -(defun news-setup (to subject in-reply-to newsgroups replybuffer) - "Set up the news reply or posting buffer with the proper headers and mode." - (setq mail-reply-buffer replybuffer) - (let ((mail-setup-hook nil) - ;; Avoid inserting a signature. - (mail-signature)) - (if (null to) - ;; this hack is needed so that inews wont be confused by - ;; the fcc: and bcc: fields - (let ((mail-self-blind nil) - (mail-archive-file-name nil)) - (mail-setup to subject in-reply-to nil replybuffer nil) - (beginning-of-line) - (delete-region (point) (progn (forward-line 1) (point))) - (goto-char (point-max))) - (mail-setup to subject in-reply-to nil replybuffer nil)) - ;;;(mail-position-on-field "Posting-Front-End") - ;;;(insert (emacs-version)) - (goto-char (point-max)) - (if (let ((case-fold-search t)) - (re-search-backward "^Subject:" (point-min) t)) - (progn (beginning-of-line) - (insert "Newsgroups: " (or newsgroups "") "\n") - (if (not newsgroups) - (backward-char 1) - (goto-char (point-max))))) - (run-hooks 'news-setup-hook))) - -(defun news-inews () - "Send a news message using inews." - (interactive) - (let* (newsgroups subject - (case-fold-search nil)) - (save-excursion - (save-restriction - (goto-char (point-min)) - (search-forward (concat "\n" mail-header-separator "\n")) - (narrow-to-region (point-min) (point)) - (setq newsgroups (mail-fetch-field "newsgroups") - subject (mail-fetch-field "subject"))) - (widen) - (goto-char (point-min)) - (run-hooks 'news-inews-hook) - (goto-char (point-min)) - (search-forward (concat "\n" mail-header-separator "\n")) - (replace-match "\n\n") - (goto-char (point-max)) - ;; require a newline at the end for inews to append .signature to - (or (= (preceding-char) ?\n) - (insert ?\n)) - (message "Posting to USENET...") - (call-process-region (point-min) (point-max) - news-inews-program nil 0 nil - "-h") ; take all header lines! - ;@@ setting of subject and newsgroups still needed? - ;"-t" subject - ;"-n" newsgroups - (message "Posting to USENET... done") - (goto-char (point-min)) ;restore internal header separator - (search-forward "\n\n") - (replace-match (concat "\n" mail-header-separator "\n")) - (set-buffer-modified-p nil)) - (and (fboundp 'bury-buffer) (bury-buffer)))) - -;@@ shares some code with news-reply and news-post-news -(defun news-mail-reply () - "Mail a reply to the author of the current article. -While composing the reply, use \\[news-reply-yank-original] to yank the -original message into it." - (interactive) - (let (from cc subject date to reply-to message-id - (buffer (current-buffer))) - (save-restriction - (narrow-to-region (point-min) (progn (goto-line (point-min)) - (search-forward "\n\n") - (- (point) 1))) - (setq from (mail-fetch-field "from") - subject (mail-fetch-field "subject") - reply-to (mail-fetch-field "reply-to") - date (mail-fetch-field "date") - message-id (mail-fetch-field "message-id"))) - (setq to from) - (pop-to-buffer "*mail*") - (mail nil - (if reply-to reply-to to) - subject - (let ((stop-pos (string-match " *at \\| *@ \\| *(\\| *<" from))) - (concat (if stop-pos (substring from 0 stop-pos) from) - "'s message " - (if message-id - (concat message-id " of ") - "of ") - date)) - nil - buffer))) - -;@@ the guts of news-reply and news-post-news should be combined. -tower -(defun news-reply () - "Compose and post a reply (aka a followup) to the current article on USENET. -While composing the followup, use \\[news-reply-yank-original] to yank the -original message into it." - (interactive) - (if (y-or-n-p "Are you sure you want to followup to all of USENET? ") - (let (from cc subject date to followup-to newsgroups message-of - references distribution message-id - (buffer (current-buffer))) - (save-restriction - (and (not (= 0 (buffer-size))) ;@@real problem is non-existence of - ;@@ of article file - (equal major-mode 'news-mode) ;@@ if rmail-mode, - ;@@ should show full headers - (progn - (news-show-all-headers) ;@@ should save/restore header state, - ;@@ but rnews.el lacks support - (narrow-to-region (point-min) (progn (goto-char (point-min)) - (search-forward "\n\n") - (- (point) 1))))) - (setq from (mail-fetch-field "from") - news-reply-yank-from from - ;; @@ not handling old Title: field - subject (mail-fetch-field "subject") - date (mail-fetch-field "date") - followup-to (mail-fetch-field "followup-to") - newsgroups (or followup-to - (mail-fetch-field "newsgroups")) - references (mail-fetch-field "references") - ;; @@ not handling old Article-I.D.: field - distribution (mail-fetch-field "distribution") - message-id (mail-fetch-field "message-id") - news-reply-yank-message-id message-id) - (pop-to-buffer "*post-news*") - (news-reply-mode) - (if (and (buffer-modified-p) - (not - (y-or-n-p "Unsent article being composed; erase it? "))) - () - (progn - (erase-buffer) - (and subject - (progn (if (string-match "\\`Re: " subject) - (while (string-match "\\`Re: " subject) - (setq subject (substring subject 4)))) - (setq subject (concat "Re: " subject)))) - (and from - (progn - (let ((stop-pos - (string-match " *at \\| *@ \\| *(\\| *<" from))) - (setq message-of - (concat - (if stop-pos (substring from 0 stop-pos) from) - "'s message " - (if message-id - (concat message-id " of ") - "of ") - date))))) - (news-setup - nil - subject - message-of - newsgroups - buffer) - (if followup-to - (progn (news-reply-followup-to) - (insert followup-to))) - (if distribution - (progn - (mail-position-on-field "Distribution") - (insert distribution))) - (mail-position-on-field "References") - (if references - (insert references)) - (if (and references message-id) - (insert " ")) - (if message-id - (insert message-id)) - (goto-char (point-max)))))) - (message ""))) - -;@@ the guts of news-reply and news-post-news should be combined. -tower -;;;###autoload -(defun news-post-news () - "Begin editing a new USENET news article to be posted. -Type \\[describe-mode] once editing the article to get a list of commands." - (interactive) - (if (y-or-n-p "Are you sure you want to post to all of USENET? ") - (let ((buffer (current-buffer))) - (save-restriction - (and (not (= 0 (buffer-size))) ;@@real problem is non-existence of - ;@@ of article file - (equal major-mode 'news-mode) ;@@ if rmail-mode, - ;@@ should show full headers - (progn - (news-show-all-headers) ;@@ should save/restore header state, - ;@@ but rnews.el lacks support - (narrow-to-region (point-min) (progn (goto-char (point-min)) - (search-forward "\n\n") - (- (point) 1))))) - (setq news-reply-yank-from (mail-fetch-field "from") - ;; @@ not handling old Article-I.D.: field - news-reply-yank-message-id (mail-fetch-field "message-id"))) - (pop-to-buffer "*post-news*") - (news-reply-mode) - (if (and (buffer-modified-p) - (not (y-or-n-p "Unsent article being composed; erase it? "))) - () ;@@ not saving point from last time - (progn (erase-buffer) - (news-setup () () () () buffer)))) - (message ""))) - -(defun news-mail-other-window () - "Send mail in another window. -While composing the message, use \\[news-reply-yank-original] to yank the -original message into it." - (interactive) - (mail-other-window nil nil nil nil nil (current-buffer))) - -;;; rnewspost.el ends here diff --git a/lisp/mail/sendmail.el b/lisp/mail/sendmail.el deleted file mode 100644 index 0f697450c5a..00000000000 --- a/lisp/mail/sendmail.el +++ /dev/null @@ -1,1228 +0,0 @@ -;;; sendmail.el --- mail sending commands for Emacs. - -;; Copyright (C) 1985, 86, 92, 93, 94, 95, 96 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; 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: - -;; This mode provides mail-sending facilities from within Emacs. It is -;; documented in the Emacs user's manual. - -;;; Code: - -;;;###autoload -(defvar mail-from-style 'angles "\ -*Specifies how \"From:\" fields look. - -If `nil', they contain just the return address like: - king@grassland.com -If `parens', they look like: - king@grassland.com (Elvis Parsley) -If `angles', they look like: - Elvis Parsley <king@grassland.com>") - -;;;###autoload -(defvar mail-self-blind nil "\ -*Non-nil means insert BCC to self in messages to be sent. -This is done when the message is initialized, -so you can remove or alter the BCC field to override the default.") - -;;;###autoload -(defvar mail-interactive nil "\ -*Non-nil means when sending a message wait for and display errors. -nil means let mailer mail back a message to report errors.") - -;;;###autoload -(defvar mail-yank-ignored-headers "^via:\\|^mail-from:\\|^origin:\\|^status:\\|^remailed\\|^received:\\|^message-id:\\|^summary-line:\\|^to:\\|^subject:\\|^in-reply-to:\\|^return-path:" "\ -*Delete these headers from old message when it's inserted in a reply.") - -;; Useful to set in site-init.el -;;;###autoload -(defvar send-mail-function 'sendmail-send-it "\ -Function to call to send the current buffer as mail. -The headers should be delimited by a line whose contents -match the variable `mail-header-separator'.") - -;;;###autoload -(defvar mail-header-separator "--text follows this line--" "\ -*Line used to separate headers from text in messages being composed.") - -;; Set up mail-header-separator for use as a category text property. -(put 'mail-header-separator 'rear-nonsticky '(category)) -;;; This was a nice idea, for preventing accidental modification of -;;; the separator. But I found it also prevented or obstructed -;;; certain deliberate operations, such as copying the separator line -;;; up to the top to send myself a copy of an already sent outgoing message -;;; and other things. So I turned it off. --rms. -;;;(put 'mail-header-separator 'read-only t) - -;;;###autoload -(defvar mail-archive-file-name nil "\ -*Name of file to write all outgoing messages in, or nil for none. -This can be an inbox file or an Rmail file.") - -;;;###autoload -(defvar mail-default-reply-to nil - "*Address to insert as default Reply-to field of outgoing messages. -If nil, it will be initialized from the REPLYTO environment variable -when you first send mail.") - -;;;###autoload -(defvar mail-alias-file nil - "*If non-nil, the name of a file to use instead of `/usr/lib/aliases'. -This file defines aliases to be expanded by the mailer; this is a different -feature from that of defining aliases in `.mailrc' to be expanded in Emacs. -This variable has no effect unless your system uses sendmail as its mailer.") - -;;;###autoload -(defvar mail-personal-alias-file "~/.mailrc" - "*If non-nil, the name of the user's personal mail alias file. -This file typically should be in same format as the `.mailrc' file used by -the `Mail' or `mailx' program. -This file need not actually exist.") - -(defvar mail-setup-hook nil - "Normal hook, run each time a new outgoing mail message is initialized. -The function `mail-setup' runs this hook.") - -(defvar mail-aliases t - "Alist of mail address aliases, -or t meaning should be initialized from your mail aliases file. -\(The file's name is normally `~/.mailrc', but your MAILRC environment -variable can override that name.) -The alias definitions in the file have this form: - alias ALIAS MEANING") - -(defvar mail-alias-modtime nil - "The modification time of your mail alias file when it was last examined.") - -(defvar mail-yank-prefix nil - "*Prefix insert on lines of yanked message being replied to. -nil means use indentation.") -(defvar mail-indentation-spaces 3 - "*Number of spaces to insert at the beginning of each cited line. -Used by `mail-yank-original' via `mail-indent-citation'.") -(defvar mail-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 t). -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 mail agents should no longer use it.") - -(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 t). -And each hook function should leave point and mark around the citation -text as modified. - -If this hook is entirely empty (nil), a default action is taken -instead of no action.") - -(defvar mail-abbrevs-loaded nil) -(defvar mail-mode-map nil) - -(autoload 'build-mail-aliases "mailalias" - "Read mail aliases from user's personal aliases file and set `mail-aliases'." - nil) - -(autoload 'expand-mail-aliases "mailalias" - "Expand all mail aliases in suitable header fields found between BEG and END. -Suitable header fields are `To', `Cc' and `Bcc' and their `Resent-' variants. -Optional second arg EXCLUDE may be a regular expression defining text to be -removed from alias expansions." - nil) - -;;;###autoload -(defvar mail-signature nil - "*Text inserted at end of mail buffer when a message is initialized. -If t, it means to insert the contents of the file `mail-signature-file'.") - -(defvar mail-signature-file "~/.signature" - "*File containing the text inserted at end of mail buffer.") - -(defvar mail-reply-action nil) -(defvar mail-send-actions nil - "A list of actions to be performed upon successful sending of a message.") -(put 'mail-reply-action 'permanent-local t) -(put 'mail-send-actions 'permanent-local t) - -(defvar mail-default-headers nil - "*A string containing header lines, to be inserted in outgoing messages. -It is inserted before you edit the message, -so you can edit or delete these lines.") - -(defvar mail-bury-selects-summary t - "*If non-nil, try to show RMAIL summary buffer after returning from mail. -The functions \\[mail-send-on-exit] or \\[mail-dont-send] select -the RMAIL summary buffer before returning, if it exists and this variable -is non-nil.") - -;; Note: could use /usr/ucb/mail instead of sendmail; -;; options -t, and -v if not interactive. -(defvar mail-mailer-swallows-blank-line - (if (and (string-match "sparc-sun-sunos\\(\\'\\|[^5]\\)" system-configuration) - (file-readable-p "/etc/sendmail.cf") - (let ((buffer (get-buffer-create " *temp*"))) - (unwind-protect - (save-excursion - (set-buffer buffer) - (insert-file-contents "/etc/sendmail.cf") - (goto-char (point-min)) - (let ((case-fold-search nil)) - (re-search-forward "^OR\\>" nil t))) - (kill-buffer buffer)))) - ;; According to RFC822, "The field-name must be composed of printable - ;; ASCII characters (i.e. characters that have decimal values between - ;; 33 and 126, except colon)", i.e. any chars except ctl chars, - ;; space, or colon. - '(looking-at "[ \t]\\|[][!\"#$%&'()*+,-./0-9;<=>?@A-Z\\\\^_`a-z{|}~]+:")) - "Set this non-nil if the system's mailer runs the header and body together. -\(This problem exists on Sunos 4 when sendmail is run in remote mode.) -The value should be an expression to test whether the problem will -actually occur.") - -(defvar mail-mode-syntax-table nil - "Syntax table used while in mail mode.") - -(if (not mail-mode-syntax-table) - (progn - (setq mail-mode-syntax-table (copy-syntax-table text-mode-syntax-table)) - (modify-syntax-entry ?% ". " mail-mode-syntax-table))) - -(defvar mail-font-lock-keywords - (eval-when-compile - (let* ((cite-chars "[>|}]") - (cite-prefix "A-Za-z") - (cite-suffix (concat cite-prefix "0-9_.@-`'\""))) - (list '("^To:" . font-lock-function-name-face) - '("^B?CC:\\|^Reply-to:" . font-lock-keyword-face) - '("^\\(Subject:\\)[ \t]*\\(.+\\)?" - (1 font-lock-comment-face) (2 font-lock-type-face nil t)) - ;; Use EVAL to delay in case `mail-header-separator' gets changed. - '(eval cons (concat "^" (regexp-quote mail-header-separator) "$") - 'font-lock-comment-face) - ;; Use MATCH-ANCHORED to effectively anchor the regexp left side. - `(,cite-chars - (,(concat "\\=[ \t]*" - "\\([" cite-prefix "]+[" cite-suffix "]*\\)?" - cite-chars ".*") - (beginning-of-line) (end-of-line) - (0 font-lock-reference-face))) - '("^\\(X-[A-Za-z0-9-]+\\|In-reply-to\\):.*" - . font-lock-string-face)))) - "Additional expressions to highlight in Mail mode.") - -(defvar mail-send-hook nil - "Normal hook run before sending mail, in Mail mode.") - -(defun sendmail-sync-aliases () - (let ((modtime (nth 5 (file-attributes mail-personal-alias-file)))) - (or (equal mail-alias-modtime modtime) - (setq mail-alias-modtime modtime - mail-aliases t)))) - -(defun mail-setup (to subject in-reply-to cc replybuffer actions) - (or mail-default-reply-to - (setq mail-default-reply-to (getenv "REPLYTO"))) - (sendmail-sync-aliases) - (if (eq mail-aliases t) - (progn - (setq mail-aliases nil) - (if (file-exists-p mail-personal-alias-file) - (build-mail-aliases)))) - (setq mail-send-actions actions) - (setq mail-reply-action replybuffer) - (goto-char (point-min)) - (insert "To: ") - (save-excursion - (if to - ;; Here removed code to extract names from within <...> - ;; on the assumption that mail-strip-quoted-names - ;; has been called and has done so. - (let ((fill-prefix "\t") - (address-start (point))) - (insert to "\n") - (fill-region-as-paragraph address-start (point-max))) - (newline)) - (if cc - (let ((fill-prefix "\t") - (address-start (progn (insert "CC: ") (point)))) - (insert cc "\n") - (fill-region-as-paragraph address-start (point-max)))) - (if in-reply-to - (let ((fill-prefix "\t") - (fill-column 78) - (address-start (point))) - (insert "In-reply-to: " in-reply-to "\n") - (fill-region-as-paragraph address-start (point-max)))) - (insert "Subject: " (or subject "") "\n") - (if mail-default-headers - (insert mail-default-headers)) - (if mail-default-reply-to - (insert "Reply-to: " mail-default-reply-to "\n")) - (if mail-self-blind - (insert "BCC: " user-mail-address "\n")) - (if mail-archive-file-name - (insert "FCC: " mail-archive-file-name "\n")) - (put-text-property (point) - (progn - (insert mail-header-separator "\n") - (1- (point))) - 'category 'mail-header-separator) - ;; Insert the signature. But remember the beginning of the message. - (if to (setq to (point))) - (cond ((eq mail-signature t) - (if (file-exists-p mail-signature-file) - (progn - (insert "\n\n-- \n") - (insert-file-contents mail-signature-file)))) - (mail-signature - (insert mail-signature))) - (goto-char (point-max)) - (or (bolp) (newline))) - (if to (goto-char to)) - (or to subject in-reply-to - (set-buffer-modified-p nil)) - (run-hooks 'mail-setup-hook)) - -;;;###autoload -(defun mail-mode () - "Major mode for editing mail to be sent. -Like Text Mode but with these additional commands: -C-c C-s mail-send (send the message) C-c C-c mail-send-and-exit -C-c C-f move to a header field (and create it if there isn't): - C-c C-f C-t move to To: C-c C-f C-s move to Subject: - C-c C-f C-c move to CC: C-c C-f C-b move to BCC: - C-c C-f C-f move to FCC: -C-c C-t mail-text (move to beginning of message text). -C-c C-w mail-signature (insert `mail-signature-file' file). -C-c C-y mail-yank-original (insert current message, in Rmail). -C-c C-q mail-fill-yanked-message (fill what was yanked). -C-c C-v mail-sent-via (add a Sent-via field for each To or CC)." - (interactive) - (kill-all-local-variables) - (make-local-variable 'mail-reply-action) - (make-local-variable 'mail-send-actions) - (set-syntax-table mail-mode-syntax-table) - (use-local-map mail-mode-map) - (setq local-abbrev-table text-mode-abbrev-table) - (setq major-mode 'mail-mode) - (setq mode-name "Mail") - (setq buffer-offer-save t) - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults '(mail-font-lock-keywords t)) - (make-local-variable 'paragraph-separate) - (make-local-variable 'paragraph-start) - (make-local-variable 'normal-auto-fill-function) - (setq normal-auto-fill-function 'mail-mode-auto-fill) - (setq fill-paragraph-function 'mail-mode-fill-paragraph) - ;; `-- ' 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]*[-_][-_][-_]+$\\|-- $\\|-----\\|" - paragraph-start)) - (setq paragraph-separate (concat (regexp-quote mail-header-separator) - "$\\|[ \t]*[-_][-_][-_]+$\\|-- $\\|-----\\|" - paragraph-separate)) - (run-hooks 'text-mode-hook 'mail-mode-hook)) - -(defun mail-mode-auto-fill () - "Carry out Auto Fill for Mail mode. -If within the headers, this makes the new lines into continuation lines." - (if (< (point) - (save-excursion - (goto-char (point-min)) - (if (search-forward mail-header-separator nil t) - (point) - 0))) - (let ((old-line-start (save-excursion (beginning-of-line) (point)))) - (if (do-auto-fill) - (save-excursion - (beginning-of-line) - (while (not (eq (point) old-line-start)) - (insert " ") - (forward-line -1)) - t))) - (do-auto-fill))) - -(defun mail-mode-fill-paragraph (arg) - ;; Do something special only if within the headers. - (if (< (point) - (save-excursion - (goto-char (point-min)) - (if (search-forward mail-header-separator nil t) - (point) - 0))) - (let (beg end fieldname) - (re-search-backward "^[-a-zA-Z]+:" nil 'yes) - (setq beg (point)) - (setq fieldname - (downcase (buffer-substring beg (1- (match-end 0))))) - (forward-line 1) - ;; Find continuation lines and get rid of their continuation markers. - (while (looking-at "[ \t]") - (delete-horizontal-space) - (forward-line 1)) - (setq end (point-marker)) - (goto-char beg) - ;; If this field contains addresses, - ;; make sure we can fill after each address. - (if (member fieldname - '("to" "cc" "bcc" "from" "reply-to" - "resent-to" "resent-cc" "resent-bcc" - "resent-from" "resent-reply-to")) - (while (search-forward "," end t) - (or (looking-at "[ \t]") - (insert " ")))) - (fill-region-as-paragraph beg end) - ;; Mark all lines except the first as continuations. - (goto-char beg) - (forward-line 1) - (while (< (point) end) - (insert " ") - (forward-line 1)) - (move-marker end nil) - t))) - -;;; Set up keymap. - -(if mail-mode-map - nil - (setq mail-mode-map (nconc (make-sparse-keymap) text-mode-map)) - (define-key mail-mode-map "\M-\t" 'mail-complete) - (define-key mail-mode-map "\C-c?" 'describe-mode) - (define-key mail-mode-map "\C-c\C-f\C-t" 'mail-to) - (define-key mail-mode-map "\C-c\C-f\C-b" 'mail-bcc) - (define-key mail-mode-map "\C-c\C-f\C-f" 'mail-fcc) - (define-key mail-mode-map "\C-c\C-f\C-c" 'mail-cc) - (define-key mail-mode-map "\C-c\C-f\C-s" 'mail-subject) - (define-key mail-mode-map "\C-c\C-f\C-r" 'mail-reply-to) - (define-key mail-mode-map "\C-c\C-t" 'mail-text) - (define-key mail-mode-map "\C-c\C-y" 'mail-yank-original) - (define-key mail-mode-map "\C-c\C-r" 'mail-yank-region) - (define-key mail-mode-map "\C-c\C-q" 'mail-fill-yanked-message) - (define-key mail-mode-map "\C-c\C-w" 'mail-signature) - (define-key mail-mode-map "\C-c\C-v" 'mail-sent-via) - (define-key mail-mode-map "\C-c\C-c" 'mail-send-and-exit) - (define-key mail-mode-map "\C-c\C-s" 'mail-send)) - -(define-key mail-mode-map [menu-bar mail] - (cons "Mail" (make-sparse-keymap "Mail"))) - -(define-key mail-mode-map [menu-bar mail fill] - '("Fill Citation" . mail-fill-yanked-message)) - -(define-key mail-mode-map [menu-bar mail yank] - '("Cite Original" . mail-yank-original)) - -(define-key mail-mode-map [menu-bar mail signature] - '("Insert Signature" . mail-signature)) - -(define-key mail-mode-map [menu-bar mail cancel] - '("Cancel" . mail-dont-send)) - -(define-key mail-mode-map [menu-bar mail send-stay] - '("Send, Keep Editing" . mail-send)) - -(define-key mail-mode-map [menu-bar mail send] - '("Send Message" . mail-send-and-exit)) - -(define-key mail-mode-map [menu-bar headers] - (cons "Headers" (make-sparse-keymap "Move to Header"))) - -(define-key mail-mode-map [menu-bar headers reply-to] - '("Reply-To" . mail-reply-to)) - -(define-key mail-mode-map [menu-bar headers sent-via] - '("Sent Via" . mail-sent-via)) - -(define-key mail-mode-map [menu-bar headers text] - '("Text" . mail-text)) - -(define-key mail-mode-map [menu-bar headers bcc] - '("Bcc" . mail-bcc)) - -(define-key mail-mode-map [menu-bar headers fcc] - '("Fcc" . mail-fcc)) - -(define-key mail-mode-map [menu-bar headers cc] - '("Cc" . mail-cc)) - -(define-key mail-mode-map [menu-bar headers subject] - '("Subject" . mail-subject)) - -(define-key mail-mode-map [menu-bar headers to] - '("To" . mail-to)) - -;; User-level commands for sending. - -(defun mail-send-and-exit (arg) - "Send message like `mail-send', then, if no errors, exit from mail buffer. -Prefix arg means don't delete this window." - (interactive "P") - (mail-send) - (mail-bury arg)) - -(defun mail-dont-send (arg) - "Don't send the message you have been editing. -Prefix arg means don't delete this window." - (interactive "P") - (mail-bury arg)) - -(defun mail-bury (arg) - "Bury this mail buffer." - (let ((newbuf (other-buffer (current-buffer)))) - (bury-buffer (current-buffer)) - (if (and (or (window-dedicated-p (frame-selected-window)) - (assq 'mail-dedicated-frame (frame-parameters))) - (not (null (delq (selected-frame) (visible-frame-list))))) - (delete-frame (selected-frame)) - (let (rmail-flag summary-buffer) - (and (not arg) - (not (one-window-p)) - (save-excursion - (set-buffer (window-buffer (next-window (selected-window) 'not))) - (setq rmail-flag (eq major-mode 'rmail-mode)) - (setq summary-buffer - (and mail-bury-selects-summary - (boundp 'rmail-summary-buffer) - rmail-summary-buffer - (buffer-name rmail-summary-buffer) - (not (get-buffer-window rmail-summary-buffer)) - rmail-summary-buffer)))) - (if rmail-flag - ;; If the Rmail buffer has a summary, show that. - (if summary-buffer (switch-to-buffer summary-buffer) - (delete-window)) - (switch-to-buffer newbuf)))))) - -(defun mail-send () - "Send the message in the current buffer. -If `mail-interactive' is non-nil, wait for success indication -or error messages, and inform user. -Otherwise any failure is reported in a message back to -the user from the mailer." - (interactive) - (if (if buffer-file-name - (y-or-n-p "Send buffer contents as mail message? ") - (or (buffer-modified-p) - (y-or-n-p "Message already sent; resend? "))) - (let ((inhibit-read-only t)) - (run-hooks 'mail-send-hook) - (message "Sending...") - (funcall send-mail-function) - ;; Now perform actions on successful sending. - (while mail-send-actions - (condition-case nil - (apply (car (car mail-send-actions)) - (cdr (car mail-send-actions))) - (error)) - (setq mail-send-actions (cdr mail-send-actions))) - (message "Sending...done") - ;; If buffer has no file, mark it as unmodified and delete autosave. - (if (not buffer-file-name) - (progn - (set-buffer-modified-p nil) - (delete-auto-save-file-if-necessary t)))))) - -;; This does the real work of sending a message via sendmail. -;; It is called via the variable send-mail-function. - -(defun sendmail-send-it () - (require 'mail-utils) - (let ((errbuf (if mail-interactive - (generate-new-buffer " sendmail errors") - 0)) - (tembuf (generate-new-buffer " sendmail temp")) - (case-fold-search nil) - resend-to-addresses - delimline - fcc-was-found - (mailbuf (current-buffer))) - (unwind-protect - (save-excursion - (set-buffer tembuf) - (erase-buffer) - (insert-buffer-substring mailbuf) - (goto-char (point-max)) - ;; require one newline at the end. - (or (= (preceding-char) ?\n) - (insert ?\n)) - ;; Change header-delimiter to be what sendmail expects. - (goto-char (point-min)) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "\n")) - (replace-match "\n") - (backward-char 1) - (setq delimline (point-marker)) - (sendmail-sync-aliases) - (if mail-aliases - (expand-mail-aliases (point-min) delimline)) - (goto-char (point-min)) - ;; ignore any blank lines in the header - (while (and (re-search-forward "\n\n\n*" delimline t) - (< (point) delimline)) - (replace-match "\n")) - (let ((case-fold-search t)) - (goto-char (point-min)) - (while (re-search-forward "^Resent-\\(to\\|cc\\|bcc\\):" delimline t) - (setq resend-to-addresses - (save-restriction - (narrow-to-region (point) - (save-excursion - (end-of-line) - (point))) - (append (mail-parse-comma-list) - resend-to-addresses))) - ;; Delete Resent-BCC ourselves - (if (save-excursion (beginning-of-line) - (looking-at "resent-bcc")) - (delete-region (save-excursion (beginning-of-line) (point)) - (save-excursion (end-of-line) (1+ (point)))))) -;;; Apparently this causes a duplicate Sender. -;;; ;; If the From is different than current user, insert Sender. -;;; (goto-char (point-min)) -;;; (and (re-search-forward "^From:" delimline t) -;;; (progn -;;; (require 'mail-utils) -;;; (not (string-equal -;;; (mail-strip-quoted-names -;;; (save-restriction -;;; (narrow-to-region (point-min) delimline) -;;; (mail-fetch-field "From"))) -;;; (user-login-name)))) -;;; (progn -;;; (forward-line 1) -;;; (insert "Sender: " (user-login-name) "\n"))) - ;; Don't send out a blank subject line - (goto-char (point-min)) - (if (re-search-forward "^Subject:\\([ \t]*\n\\)+\\b" delimline t) - (replace-match "") - ;; This one matches a Subject just before the header delimiter. - (if (and (re-search-forward "^Subject:\\([ \t]*\n\\)+" delimline t) - (= (match-end 0) delimline)) - (replace-match ""))) - ;; Put the "From:" field in unless for some odd reason - ;; they put one in themselves. - (goto-char (point-min)) - (if (not (re-search-forward "^From:" delimline t)) - (let* ((login user-mail-address) - (fullname (user-full-name))) - (cond ((eq mail-from-style 'angles) - (insert "From: " fullname) - (let ((fullname-start (+ (point-min) 6)) - (fullname-end (point-marker))) - (goto-char fullname-start) - ;; Look for a character that cannot appear unquoted - ;; according to RFC 822. - (if (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" - fullname-end 1) - (progn - ;; Quote fullname, escaping specials. - (goto-char fullname-start) - (insert "\"") - (while (re-search-forward "[\"\\]" - fullname-end 1) - (replace-match "\\\\\\&" t)) - (insert "\"")))) - (insert " <" login ">\n")) - ((eq mail-from-style 'parens) - (insert "From: " login " (") - (let ((fullname-start (point))) - (insert fullname) - (let ((fullname-end (point-marker))) - (goto-char fullname-start) - ;; RFC 822 says \ and nonmatching parentheses - ;; must be escaped in comments. - ;; Escape every instance of ()\ ... - (while (re-search-forward "[()\\]" fullname-end 1) - (replace-match "\\\\\\&" t)) - ;; ... then undo escaping of matching parentheses, - ;; including matching nested parentheses. - (goto-char fullname-start) - (while (re-search-forward - "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)" - fullname-end 1) - (replace-match "\\1(\\3)" t) - (goto-char fullname-start)))) - (insert ")\n")) - ((null mail-from-style) - (insert "From: " login "\n"))))) - ;; Insert an extra newline if we need it to work around - ;; Sun's bug that swallows newlines. - (goto-char (1+ delimline)) - (if (eval mail-mailer-swallows-blank-line) - (newline)) - ;; Find and handle any FCC fields. - (goto-char (point-min)) - (if (re-search-forward "^FCC:" delimline t) - (progn - (setq fcc-was-found t) - (mail-do-fcc delimline))) - (if mail-interactive - (save-excursion - (set-buffer errbuf) - (erase-buffer)))) - (goto-char (point-min)) - (if (let ((case-fold-search t)) - (re-search-forward "^To:\\|^cc:\\|^bcc:\\|^resent-to:\ -\\|^resent-cc:\\|^resent-bcc:" - delimline t)) - (let ((default-directory "/")) - (apply 'call-process-region - (append (list (point-min) (point-max) - (if (boundp 'sendmail-program) - sendmail-program - "/usr/lib/sendmail") - nil errbuf nil "-oi") - ;; Always specify who from, - ;; since some systems have broken sendmails. - (list "-f" (user-login-name)) - ;;; ;; Don't say "from root" if running under su. - ;;; (and (equal (user-real-login-name) "root") - ;;; (list "-f" (user-login-name))) - (and mail-alias-file - (list (concat "-oA" mail-alias-file))) - (if mail-interactive - ;; These mean "report errors to terminal" - ;; and "deliver interactively" - '("-oep" "-odi") - ;; These mean "report errors by mail" - ;; and "deliver in background". - '("-oem" "-odb")) - ;; Get the addresses from the message - ;; unless this is a resend. - ;; We must not do that for a resend - ;; because we would find the original addresses. - ;; For a resend, include the specific addresses. - (or resend-to-addresses - '("-t"))))) - (or fcc-was-found - (error "No recipients"))) - (if mail-interactive - (save-excursion - (set-buffer errbuf) - (goto-char (point-min)) - (while (re-search-forward "\n\n* *" nil t) - (replace-match "; ")) - (if (not (zerop (buffer-size))) - (error "Sending...failed to %s" - (buffer-substring (point-min) (point-max))))))) - (kill-buffer tembuf) - (if (bufferp errbuf) - (kill-buffer errbuf))))) - -(defun mail-do-fcc (header-end) - (let (fcc-list - (rmailbuf (current-buffer)) - (time (current-time)) - (tembuf (generate-new-buffer " rmail output")) - (case-fold-search t)) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward "^FCC:[ \t]*" header-end t) - (setq fcc-list (cons (buffer-substring (point) - (progn - (end-of-line) - (skip-chars-backward " \t") - (point))) - fcc-list)) - (delete-region (match-beginning 0) - (progn (forward-line 1) (point)))) - (set-buffer tembuf) - (erase-buffer) - ;; This initial newline is written out if the fcc file already exists. - (insert "\nFrom " (user-login-name) " " - (current-time-string time) "\n") - ;; Insert the time zone before the year. - (forward-char -1) - (forward-word -1) - (require 'mail-utils) - (insert (mail-rfc822-time-zone time) " ") - (goto-char (point-max)) - (insert-buffer-substring rmailbuf) - ;; Make sure messages are separated. - (goto-char (point-max)) - (insert ?\n) - (goto-char 2) - ;; ``Quote'' "^From " as ">From " - ;; (note that this isn't really quoting, as there is no requirement - ;; that "^[>]+From " be quoted in the same transparent way.) - (let ((case-fold-search nil)) - (while (search-forward "\nFrom " nil t) - (forward-char -5) - (insert ?>))) - (while fcc-list - (let* ((buffer (find-buffer-visiting (car fcc-list))) - (curbuf (current-buffer)) - (beg (point-min)) (end (point-max)) - (beg2 (save-excursion (goto-char (point-min)) - (forward-line 2) (point)))) - (if buffer - ;; File is present in a buffer => append to that buffer. - (save-excursion - (set-buffer buffer) - ;; Keep the end of the accessible portion at the same place - ;; unless it is the end of the buffer. - (let ((max (if (/= (1+ (buffer-size)) (point-max)) - (point-max)))) - (unwind-protect - ;; Code below lifted from rmailout.el - ;; function rmail-output-to-rmail-file: - (let ((buffer-read-only nil) - (msg (and (boundp 'rmail-current-message) - rmail-current-message))) - ;; If MSG is non-nil, buffer is in RMAIL mode. - (if msg - (progn - (rmail-maybe-set-message-counters) - (widen) - (narrow-to-region (point-max) (point-max)) - (insert "\C-l\n0, unseen,,\n*** EOOH ***\n" - "Date: " (mail-rfc822-date) "\n") - (insert-buffer-substring curbuf beg2 end) - (insert "\n\C-_") - (goto-char (point-min)) - (widen) - (search-backward "\n\^_") - (narrow-to-region (point) (point-max)) - (rmail-count-new-messages t) - (rmail-show-message msg) - (setq max nil)) - ;; Output file not in rmail mode - ;; => just insert at the end. - (narrow-to-region (point-min) (1+ (buffer-size))) - (goto-char (point-max)) - (insert-buffer-substring curbuf beg end))) - (if max (narrow-to-region (point-min) max))))) - ;; Else append to the file directly. - (if (and (file-exists-p (car fcc-list)) - (mail-file-babyl-p (car fcc-list))) - ;; If the file is a Babyl file, - ;; convert the message to Babyl format. - (save-excursion - (set-buffer (get-buffer-create " mail-temp")) - (setq buffer-read-only nil) - (erase-buffer) - (insert "\C-l\n0, unseen,,\n*** EOOH ***\n" - "Date: " (mail-rfc822-date) "\n") - (insert-buffer-substring curbuf beg2 end) - (insert "\n\C-_") - (write-region (point-min) (point-max) (car fcc-list) t) - (erase-buffer)) - (write-region - (1+ (point-min)) (point-max) (car fcc-list) t)))) - (setq fcc-list (cdr fcc-list)))) - (kill-buffer tembuf))) - -(defun mail-sent-via () - "Make a Sent-via header line from each To or CC header line." - (interactive) - (save-excursion - (goto-char (point-min)) - ;; find the header-separator - (search-forward (concat "\n" mail-header-separator "\n")) - (forward-line -1) - ;; put a marker at the end of the header - (let ((end (point-marker)) - (case-fold-search t) - to-line) - (goto-char (point-min)) - ;; search for the To: lines and make Sent-via: lines from them - ;; search for the next To: line - (while (re-search-forward "^\\(to\\|cc\\):" end t) - ;; Grab this line plus all its continuations, sans the `to:'. - (let ((to-line - (buffer-substring (point) - (progn - (if (re-search-forward "^[^ \t\n]" end t) - (backward-char 1) - (goto-char end)) - (point))))) - ;; Insert a copy, with altered header field name. - (insert-before-markers "Sent-via:" to-line)))))) - -(defun mail-to () - "Move point to end of To-field." - (interactive) - (expand-abbrev) - (mail-position-on-field "To")) - -(defun mail-subject () - "Move point to end of Subject-field." - (interactive) - (expand-abbrev) - (mail-position-on-field "Subject")) - -(defun mail-cc () - "Move point to end of CC-field. Create a CC field if none." - (interactive) - (expand-abbrev) - (or (mail-position-on-field "cc" t) - (progn (mail-position-on-field "to") - (insert "\nCC: ")))) - -(defun mail-bcc () - "Move point to end of BCC-field. Create a BCC field if none." - (interactive) - (expand-abbrev) - (or (mail-position-on-field "bcc" t) - (progn (mail-position-on-field "to") - (insert "\nBCC: ")))) - -(defun mail-fcc (folder) - "Add a new FCC field, with file name completion." - (interactive "FFolder carbon copy: ") - (expand-abbrev) - (or (mail-position-on-field "fcc" t) ;Put new field after exiting FCC. - (mail-position-on-field "to")) - (insert "\nFCC: " folder)) - -(defun mail-reply-to () - "Move point to end of Reply-To-field." - (interactive) - (expand-abbrev) - (mail-position-on-field "Reply-To")) - -(defun mail-position-on-field (field &optional soft) - (let (end - (case-fold-search t)) - (goto-char (point-min)) - (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$")) - (setq end (match-beginning 0)) - (goto-char (point-min)) - (if (re-search-forward (concat "^" (regexp-quote field) ":") end t) - (progn - (re-search-forward "^[^ \t]" nil 'move) - (beginning-of-line) - (skip-chars-backward "\n") - t) - (or soft - (progn (goto-char end) - (insert field ": \n") - (skip-chars-backward "\n"))) - nil))) - -(defun mail-text () - "Move point to beginning of message text." - (interactive) - (expand-abbrev) - (goto-char (point-min)) - (search-forward (concat "\n" mail-header-separator "\n"))) - -(defun mail-signature (atpoint) - "Sign letter with contents of the file `mail-signature-file'. -Prefix arg means put contents at point." - (interactive "P") - (save-excursion - (or atpoint - (goto-char (point-max))) - (skip-chars-backward " \t\n") - (end-of-line) - (or atpoint - (delete-region (point) (point-max))) - (insert "\n\n-- \n") - (insert-file-contents (expand-file-name mail-signature-file)))) - -(defun mail-fill-yanked-message (&optional justifyp) - "Fill the paragraphs of a message yanked into this one. -Numeric argument means justify as well." - (interactive "P") - (save-excursion - (goto-char (point-min)) - (search-forward (concat "\n" mail-header-separator "\n") nil t) - (fill-individual-paragraphs (point) - (point-max) - justifyp - t))) - -(defun mail-indent-citation () - "Modify text just inserted from a message to be cited. -The inserted text should be the region. -When this function returns, the region is again around the modified text. - -Normally, indent each nonblank line `mail-indentation-spaces' spaces. -However, if `mail-yank-prefix' is non-nil, insert that prefix on each line." - (mail-yank-clear-headers (region-beginning) (region-end)) - (if (null mail-yank-prefix) - (indent-rigidly (region-beginning) (region-end) - mail-indentation-spaces) - (save-excursion - (goto-char (region-beginning)) - (while (< (point) (region-end)) - (insert mail-yank-prefix) - (forward-line 1))))) - -(defun mail-yank-original (arg) - "Insert the message being replied to, if any (in rmail). -Puts point after the text and mark before. -Normally, indents each nonblank line ARG spaces (default 3). -However, if `mail-yank-prefix' is non-nil, insert that prefix on each line. - -Just \\[universal-argument] as argument means don't indent, insert no prefix, -and don't delete any header fields." - (interactive "P") - (if mail-reply-action - (let ((start (point)) - (original mail-reply-action)) - (and (consp original) (eq (car original) 'insert-buffer) - (setq original (nth 1 original))) - (if (consp original) - (apply (car original) (cdr original)) - ;; If the original message is in another window in the same frame, - ;; delete that window to save screen space. - ;; t means don't alter other frames. - (delete-windows-on original t) - (insert-buffer original)) - (if (consp arg) - nil - (goto-char start) - (let ((mail-indentation-spaces (if arg (prefix-numeric-value arg) - mail-indentation-spaces))) - (if mail-citation-hook - (run-hooks 'mail-citation-hook) - (if mail-yank-hooks - (run-hooks 'mail-yank-hooks) - (mail-indent-citation))))) - ;; This is like exchange-point-and-mark, but doesn't activate the mark. - ;; It is cleaner to avoid activation, even though the command - ;; loop would deactivate the mark because we inserted text. - (goto-char (prog1 (mark t) - (set-marker (mark-marker) (point) (current-buffer)))) - (if (not (eolp)) (insert ?\n))))) - -(defun mail-yank-clear-headers (start end) - (if (< end start) - (let (temp) - (setq temp start start end end temp))) - (if mail-yank-ignored-headers - (save-excursion - (goto-char start) - (if (search-forward "\n\n" end t) - (save-restriction - (narrow-to-region start (point)) - (goto-char start) - (while (let ((case-fold-search t)) - (re-search-forward mail-yank-ignored-headers nil t)) - (beginning-of-line) - (delete-region (point) - (progn (re-search-forward "\n[^ \t]") - (forward-char -1) - (point))))))))) - -(defun mail-yank-region (arg) - "Insert the selected region from the message being replied to. -Puts point after the text and mark before. -Normally, indents each nonblank line ARG spaces (default 3). -However, if `mail-yank-prefix' is non-nil, insert that prefix on each line. - -Just \\[universal-argument] as argument means don't indent, insert no prefix, -and don't delete any header fields." - (interactive "P") - (and (consp mail-reply-action) - (eq (car mail-reply-action) 'insert-buffer) - (let ((buffer (nth 1 mail-reply-action)) - (start (point))) - ;; Insert the citation text. - (insert (with-current-buffer buffer - (buffer-substring (point) (mark)))) - (push-mark start) - ;; Indent or otherwise annotate the citation text. - (if (consp arg) - nil - (let ((mail-indentation-spaces (if arg (prefix-numeric-value arg) - mail-indentation-spaces))) - (if mail-citation-hook - (run-hooks 'mail-citation-hook) - (if mail-yank-hooks - (run-hooks 'mail-yank-hooks) - (mail-indent-citation)))))))) - -;; Put these last, to reduce chance of lossage from quitting in middle of loading the file. - -;;;###autoload -(defun mail (&optional noerase to subject in-reply-to cc replybuffer actions) - "Edit a message to be sent. Prefix arg means resume editing (don't erase). -When this function returns, the buffer `*mail*' is selected. -The value is t if the message was newly initialized; otherwise, nil. - -Optionally, the signature file `mail-signature-file' can be inserted at the -end; see the variable `mail-signature'. - -\\<mail-mode-map> -While editing message, type \\[mail-send-and-exit] to send the message and exit. - -Various special commands starting with C-c are available in sendmail mode -to move to message header fields: -\\{mail-mode-map} - -If `mail-self-blind' is non-nil, a BCC to yourself is inserted -when the message is initialized. - -If `mail-default-reply-to' is non-nil, it should be an address (a string); -a Reply-to: field with that address is inserted. - -If `mail-archive-file-name' is non-nil, an FCC field with that file name -is inserted. - -The normal hook `mail-setup-hook' is run after the message is -initialized. It can add more default fields to the message. - -When calling from a program, the first argument if non-nil says -not to erase the existing contents of the `*mail*' buffer. - -The second through fifth arguments, - TO, SUBJECT, IN-REPLY-TO and CC, specify if non-nil - the initial contents of those header fields. - These arguments should not have final newlines. -The sixth argument REPLYBUFFER is a buffer which contains an - original message being replied to, or else an action - of the form (FUNCTION . ARGS) which says how to insert the original. - Or it can be nil, if not replying to anything. -The seventh argument ACTIONS is a list of actions to take - if/when the message is sent. Each action looks like (FUNCTION . ARGS); - when the message is sent, we apply FUNCTION to ARGS. - This is how Rmail arranges to mark messages `answered'." - (interactive "P") -;;; This is commented out because I found it was confusing in practice. -;;; It is easy enough to rename *mail* by hand with rename-buffer -;;; if you want to have multiple mail buffers. -;;; And then you can control which messages to save. --rms. -;;; (let ((index 1) -;;; buffer) -;;; ;; If requested, look for a mail buffer that is modified and go to it. -;;; (if noerase -;;; (progn -;;; (while (and (setq buffer -;;; (get-buffer (if (= 1 index) "*mail*" -;;; (format "*mail*<%d>" index)))) -;;; (not (buffer-modified-p buffer))) -;;; (setq index (1+ index))) -;;; (if buffer (switch-to-buffer buffer) -;;; ;; If none exists, start a new message. -;;; ;; This will never re-use an existing unmodified mail buffer -;;; ;; (since index is not 1 anymore). Perhaps it should. -;;; (setq noerase nil)))) -;;; ;; Unless we found a modified message and are happy, start a new message. -;;; (if (not noerase) -;;; (progn -;;; ;; Look for existing unmodified mail buffer. -;;; (while (and (setq buffer -;;; (get-buffer (if (= 1 index) "*mail*" -;;; (format "*mail*<%d>" index)))) -;;; (buffer-modified-p buffer)) -;;; (setq index (1+ index))) -;;; ;; If none, make a new one. -;;; (or buffer -;;; (setq buffer (generate-new-buffer "*mail*"))) -;;; ;; Go there and initialize it. -;;; (switch-to-buffer buffer) -;;; (erase-buffer) -;;; (setq default-directory (expand-file-name "~/")) -;;; (auto-save-mode auto-save-default) -;;; (mail-mode) -;;; (mail-setup to subject in-reply-to cc replybuffer actions) -;;; (if (and buffer-auto-save-file-name -;;; (file-exists-p buffer-auto-save-file-name)) -;;; (message "Auto save file for draft message exists; consider M-x mail-recover")) -;;; t)) - (pop-to-buffer "*mail*") - ;; Put the auto-save file in the home dir - ;; to avoid any danger that it can't be written. - (if (file-exists-p (expand-file-name "~/")) - (setq default-directory (expand-file-name "~/"))) - (auto-save-mode auto-save-default) - (mail-mode) - ;; Disconnect the buffer from its visited file - ;; (in case the user has actually visited a file *mail*). -; (set-visited-file-name nil) - (let (initialized) - (and (not noerase) - (or (not (buffer-modified-p)) - (y-or-n-p "Unsent message being composed; erase it? ")) - (let ((inhibit-read-only t)) - (erase-buffer) - (mail-setup to subject in-reply-to cc replybuffer actions) - (setq initialized t))) - (if (and buffer-auto-save-file-name - (file-exists-p buffer-auto-save-file-name)) - (message "Auto save file for draft message exists; consider M-x mail-recover")) - initialized)) - -(defun mail-recover () - "Reread contents of current buffer from its last auto-save file." - (interactive) - (let ((file-name (make-auto-save-file-name))) - (cond ((save-window-excursion - (if (not (eq system-type 'vax-vms)) - (with-output-to-temp-buffer "*Directory*" - (buffer-disable-undo standard-output) - (let ((default-directory "/")) - (call-process - "ls" nil standard-output nil "-l" file-name)))) - (yes-or-no-p (format "Recover auto save file %s? " file-name))) - (let ((buffer-read-only nil)) - (erase-buffer) - (insert-file-contents file-name nil))) - (t (error "mail-recover cancelled"))))) - -;;;###autoload -(defun mail-other-window (&optional noerase to subject in-reply-to cc replybuffer sendactions) - "Like `mail' command, but display mail buffer in another window." - (interactive "P") - (let ((pop-up-windows t) - (special-display-buffer-names nil) - (special-display-regexps nil) - (same-window-buffer-names nil) - (same-window-regexps nil)) - (pop-to-buffer "*mail*")) - (mail noerase to subject in-reply-to cc replybuffer sendactions)) - -;;;###autoload -(defun mail-other-frame (&optional noerase to subject in-reply-to cc replybuffer sendactions) - "Like `mail' command, but display mail buffer in another frame." - (interactive "P") - (let ((pop-up-frames t) - (special-display-buffer-names nil) - (special-display-regexps nil) - (same-window-buffer-names nil) - (same-window-regexps nil)) - (pop-to-buffer "*mail*")) - (mail noerase to subject in-reply-to cc replybuffer sendactions)) - -;;; Do not execute these when sendmail.el is loaded, -;;; only in loaddefs.el. -;;;###autoload (define-key ctl-x-map "m" 'mail) -;;;###autoload (define-key ctl-x-4-map "m" 'mail-other-window) -;;;###autoload (define-key ctl-x-5-map "m" 'mail-other-frame) - -;;;###autoload (add-hook 'same-window-buffer-names "*mail*") - -;;; Do not add anything but external entries on this page. - -(provide 'sendmail) - -;;; sendmail.el ends here diff --git a/lisp/mail/smtpmail.el b/lisp/mail/smtpmail.el deleted file mode 100644 index 925a6ec2e83..00000000000 --- a/lisp/mail/smtpmail.el +++ /dev/null @@ -1,525 +0,0 @@ -;; Simple SMTP protocol (RFC 821) for sending mail - -;; Copyright (C) 1995, 1996 Free Software Foundation, Inc. - -;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp> -;; Maintainer: Brian D. Carlstrom <bdc@ai.mit.edu> -;; 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: - -;; Send Mail to smtp host from smtpmail temp buffer. - -;; Please add these lines in your .emacs(_emacs). -;; -;;(setq send-mail-function 'smtpmail-send-it) -;;(setq smtpmail-default-smtp-server "YOUR SMTP HOST") -;;(setq smtpmail-smtp-service "smtp") -;;(setq smtpmail-local-domain "YOUR DOMAIN NAME") -;;(setq smtpmail-debug-info t) -;;(load-library "smtpmail") -;;(setq smtpmail-code-conv-from nil) -;;(setq user-full-name "YOUR NAME HERE") - -;;; Code: - -(require 'sendmail) - -;;; -(defvar smtpmail-default-smtp-server nil - "*Specify default SMTP server.") - -(defvar smtpmail-smtp-server - (or (getenv "SMTPSERVER") smtpmail-default-smtp-server) - "*The name of the host running SMTP server.") - -(defvar smtpmail-smtp-service 25 - "*SMTP service port number. smtp or 25 .") - -(defvar smtpmail-local-domain nil - "*Local domain name without a host name. -If the function (system-name) returns the full internet address, -don't define this value.") - -(defvar smtpmail-debug-info nil - "*smtpmail debug info printout. messages and process buffer.") - -(defvar smtpmail-code-conv-from nil ;; *junet* - "*smtpmail code convert from this code to *internal*..for tiny-mime..") - -;;; -;;; -;;; - -(defun smtpmail-send-it () - (require 'mail-utils) - (let ((errbuf (if mail-interactive - (generate-new-buffer " smtpmail errors") - 0)) - (tembuf (generate-new-buffer " smtpmail temp")) - (case-fold-search nil) - resend-to-addresses - delimline - (mailbuf (current-buffer))) - (unwind-protect - (save-excursion - (set-buffer tembuf) - (erase-buffer) - (insert-buffer-substring mailbuf) - (goto-char (point-max)) - ;; require one newline at the end. - (or (= (preceding-char) ?\n) - (insert ?\n)) - ;; Change header-delimiter to be what sendmail expects. - (goto-char (point-min)) - (re-search-forward - (concat "^" (regexp-quote mail-header-separator) "\n")) - (replace-match "\n") - (backward-char 1) - (setq delimline (point-marker)) -;; (sendmail-synch-aliases) - (if mail-aliases - (expand-mail-aliases (point-min) delimline)) - (goto-char (point-min)) - ;; ignore any blank lines in the header - (while (and (re-search-forward "\n\n\n*" delimline t) - (< (point) delimline)) - (replace-match "\n")) - (let ((case-fold-search t)) - (goto-char (point-min)) - (goto-char (point-min)) - (while (re-search-forward "^Resent-to:" delimline t) - (setq resend-to-addresses - (save-restriction - (narrow-to-region (point) - (save-excursion - (end-of-line) - (point))) - (append (mail-parse-comma-list) - resend-to-addresses)))) -;;; Apparently this causes a duplicate Sender. -;;; ;; If the From is different than current user, insert Sender. -;;; (goto-char (point-min)) -;;; (and (re-search-forward "^From:" delimline t) -;;; (progn -;;; (require 'mail-utils) -;;; (not (string-equal -;;; (mail-strip-quoted-names -;;; (save-restriction -;;; (narrow-to-region (point-min) delimline) -;;; (mail-fetch-field "From"))) -;;; (user-login-name)))) -;;; (progn -;;; (forward-line 1) -;;; (insert "Sender: " (user-login-name) "\n"))) - ;; Don't send out a blank subject line - (goto-char (point-min)) - (if (re-search-forward "^Subject:[ \t]*\n" delimline t) - (replace-match "")) - ;; Put the "From:" field in unless for some odd reason - ;; they put one in themselves. - (goto-char (point-min)) - (if (not (re-search-forward "^From:" delimline t)) - (let* ((login user-mail-address) - (fullname (user-full-name))) - (cond ((eq mail-from-style 'angles) - (insert "From: " fullname) - (let ((fullname-start (+ (point-min) 6)) - (fullname-end (point-marker))) - (goto-char fullname-start) - ;; Look for a character that cannot appear unquoted - ;; according to RFC 822. - (if (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" - fullname-end 1) - (progn - ;; Quote fullname, escaping specials. - (goto-char fullname-start) - (insert "\"") - (while (re-search-forward "[\"\\]" - fullname-end 1) - (replace-match "\\\\\\&" t)) - (insert "\"")))) - (insert " <" login ">\n")) - ((eq mail-from-style 'parens) - (insert "From: " login " (") - (let ((fullname-start (point))) - (insert fullname) - (let ((fullname-end (point-marker))) - (goto-char fullname-start) - ;; RFC 822 says \ and nonmatching parentheses - ;; must be escaped in comments. - ;; Escape every instance of ()\ ... - (while (re-search-forward "[()\\]" fullname-end 1) - (replace-match "\\\\\\&" t)) - ;; ... then undo escaping of matching parentheses, - ;; including matching nested parentheses. - (goto-char fullname-start) - (while (re-search-forward - "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)" - fullname-end 1) - (replace-match "\\1(\\3)" t) - (goto-char fullname-start)))) - (insert ")\n")) - ((null mail-from-style) - (insert "From: " login "\n"))))) - ;; Insert an extra newline if we need it to work around - ;; Sun's bug that swallows newlines. - (goto-char (1+ delimline)) - (if (eval mail-mailer-swallows-blank-line) - (newline)) - ;; Find and handle any FCC fields. - (goto-char (point-min)) - (if (re-search-forward "^FCC:" delimline t) - (mail-do-fcc delimline)) - (if mail-interactive - (save-excursion - (set-buffer errbuf) - (erase-buffer)))) - ;; - ;; - ;; - (setq smtpmail-address-buffer (generate-new-buffer "*smtp-mail*")) - (setq smtpmail-recipient-address-list - (or resend-to-addresses - (smtpmail-deduce-address-list tembuf (point-min) delimline))) - (kill-buffer smtpmail-address-buffer) - - (smtpmail-do-bcc delimline) - - (if (not (null smtpmail-recipient-address-list)) - (if (not (smtpmail-via-smtp smtpmail-recipient-address-list tembuf)) - (error "Sending failed; SMTP protocol error")) - (error "Sending failed; no recipients")) - ) - (kill-buffer tembuf) - (if (bufferp errbuf) - (kill-buffer errbuf))))) - - -;(defun smtpmail-via-smtp (host,port,sender,destination,smtpmail-text-buffer) - -(defun smtpmail-fqdn () - (if smtpmail-local-domain - (concat (system-name) "." smtpmail-local-domain) - (system-name))) - -(defun smtpmail-via-smtp (recipient smtpmail-text-buffer) - (let ((process nil) - (host smtpmail-smtp-server) - (port smtpmail-smtp-service) - response-code - greeting - process-buffer) - (unwind-protect - (catch 'done - ;; get or create the trace buffer - (setq process-buffer - (get-buffer-create (format "*trace of SMTP session to %s*" host))) - - ;; clear the trace buffer of old output - (save-excursion - (set-buffer process-buffer) - (erase-buffer)) - - ;; open the connection to the server - (setq process (open-network-stream "SMTP" process-buffer host port)) - (and (null process) (throw 'done nil)) - - ;; set the send-filter - (set-process-filter process 'smtpmail-process-filter) - - (save-excursion - (set-buffer process-buffer) - (make-local-variable 'smtpmail-read-point) - (setq smtpmail-read-point (point-min)) - - - (if (or (null (car (setq greeting (smtpmail-read-response process)))) - (not (integerp (car greeting))) - (>= (car greeting) 400)) - (throw 'done nil) - ) - - ;; HELO - (smtpmail-send-command process (format "HELO %s" (smtpmail-fqdn))) - - (if (or (null (car (setq response-code (smtpmail-read-response process)))) - (not (integerp (car response-code))) - (>= (car response-code) 400)) - (throw 'done nil) - ) - - ;; MAIL FROM: <sender> -; (smtpmail-send-command process (format "MAIL FROM:%s@%s" (user-login-name) (smtpmail-fqdn))) - (smtpmail-send-command process (format "MAIL FROM: <%s>" user-mail-address)) - - (if (or (null (car (setq response-code (smtpmail-read-response process)))) - (not (integerp (car response-code))) - (>= (car response-code) 400)) - (throw 'done nil) - ) - - ;; RCPT TO: <recipient> - (let ((n 0)) - (while (not (null (nth n recipient))) - (smtpmail-send-command process (format "RCPT TO: <%s>" (nth n recipient))) - (setq n (1+ n)) - - (if (or (null (car (setq response-code (smtpmail-read-response process)))) - (not (integerp (car response-code))) - (>= (car response-code) 400)) - (throw 'done nil) - ) - )) - - ;; DATA - (smtpmail-send-command process "DATA") - - (if (or (null (car (setq response-code (smtpmail-read-response process)))) - (not (integerp (car response-code))) - (>= (car response-code) 400)) - (throw 'done nil) - ) - - ;; Mail contents - (smtpmail-send-data process smtpmail-text-buffer) - - ;;DATA end "." - (smtpmail-send-command process ".") - - (if (or (null (car (setq response-code (smtpmail-read-response process)))) - (not (integerp (car response-code))) - (>= (car response-code) 400)) - (throw 'done nil) - ) - - ;;QUIT -; (smtpmail-send-command process "QUIT") -; (and (null (car (smtpmail-read-response process))) -; (throw 'done nil)) - t )) - (if process - (save-excursion - (set-buffer (process-buffer process)) - (smtpmail-send-command process "QUIT") - (smtpmail-read-response process) - -; (if (or (null (car (setq response-code (smtpmail-read-response process)))) -; (not (integerp (car response-code))) -; (>= (car response-code) 400)) -; (throw 'done nil) -; ) - (delete-process process)))))) - - -(defun smtpmail-process-filter (process output) - (save-excursion - (set-buffer (process-buffer process)) - (goto-char (point-max)) - (insert output))) - -(defun smtpmail-read-response (process) - (let ((case-fold-search nil) - (response-string nil) - (response-continue t) - (return-value '(nil "")) - match-end) - -; (setq response-string nil) -; (setq response-continue t) -; (setq return-value '(nil "")) - - (while response-continue - (goto-char smtpmail-read-point) - (while (not (search-forward "\r\n" nil t)) - (accept-process-output process) - (goto-char smtpmail-read-point)) - - (setq match-end (point)) - (if (null response-string) - (setq response-string - (buffer-substring smtpmail-read-point (- match-end 2)))) - - (goto-char smtpmail-read-point) - (if (looking-at "[0-9]+ ") - (progn (setq response-continue nil) -; (setq return-value response-string) - - (if smtpmail-debug-info - (message response-string)) - - (setq smtpmail-read-point match-end) - (setq return-value - (cons (string-to-int - (buffer-substring (match-beginning 0) (match-end 0))) - response-string))) - - (if (looking-at "[0-9]+-") - (progn (setq smtpmail-read-point match-end) - (setq response-continue t)) - (progn - (setq smtpmail-read-point match-end) - (setq response-continue nil) - (setq return-value - (cons nil response-string)) - ) - ))) - (setq smtpmail-read-point match-end) - return-value)) - - -(defun smtpmail-send-command (process command) - (goto-char (point-max)) - (if (= (aref command 0) ?P) - (insert "PASS <omitted>\r\n") - (insert command "\r\n")) - (setq smtpmail-read-point (point)) - (process-send-string process command) - (process-send-string process "\r\n")) - -(defun smtpmail-send-data-1 (process data) - (goto-char (point-max)) - - (if (not (null smtpmail-code-conv-from)) - (setq data (code-convert-string data smtpmail-code-conv-from *internal*))) - - (if smtpmail-debug-info - (insert data "\r\n")) - - (setq smtpmail-read-point (point)) - ;; Escape "." at start of a line - (if (eq (string-to-char data) ?.) - (process-send-string process ".")) - (process-send-string process data) - (process-send-string process "\r\n") - ) - -(defun smtpmail-send-data (process buffer) - (let - ((data-continue t) - (sending-data nil) - this-line - this-line-end) - - (save-excursion - (set-buffer buffer) - (goto-char (point-min))) - - (while data-continue - (save-excursion - (set-buffer buffer) - (beginning-of-line) - (setq this-line (point)) - (end-of-line) - (setq this-line-end (point)) - (setq sending-data nil) - (setq sending-data (buffer-substring this-line this-line-end)) - (if (/= (forward-line 1) 0) - (setq data-continue nil))) - - (smtpmail-send-data-1 process sending-data) - ) - ) - ) - - -(defun smtpmail-deduce-address-list (smtpmail-text-buffer header-start header-end) - "Get address list suitable for smtp RCPT TO: <address>." - (require 'mail-utils) ;; pick up mail-strip-quoted-names - (let - ((case-fold-search t) - (simple-address-list "") - this-line - this-line-end - addr-regexp) - - (unwind-protect - (save-excursion - ;; - (set-buffer smtpmail-address-buffer) (erase-buffer) - (insert-buffer-substring smtpmail-text-buffer header-start header-end) - (goto-char (point-min)) - ;; RESENT-* fields should stop processing of regular fields. - (save-excursion - (if (re-search-forward "^RESENT-TO:" header-end t) - (setq addr-regexp "^\\(RESENT-TO:\\|RESENT-CC:\\|RESENT-BCC:\\)") - (setq addr-regexp "^\\(TO:\\|CC:\\|BCC:\\)"))) - - (while (re-search-forward addr-regexp header-end t) - (replace-match "") - (setq this-line (match-beginning 0)) - (forward-line 1) - ;; get any continuation lines - (while (and (looking-at "^[ \t]+") (< (point) header-end)) - (forward-line 1)) - (setq this-line-end (point-marker)) - (setq simple-address-list - (concat simple-address-list " " - (mail-strip-quoted-names (buffer-substring this-line this-line-end)))) - ) - (erase-buffer) - (insert-string " ") - (insert-string simple-address-list) - (insert-string "\n") - (subst-char-in-region (point-min) (point-max) 10 ? t);; newline --> blank - (subst-char-in-region (point-min) (point-max) ?, ? t);; comma --> blank - (subst-char-in-region (point-min) (point-max) 9 ? t);; tab --> blank - - (goto-char (point-min)) - ;; tidyness in case hook is not robust when it looks at this - (while (re-search-forward "[ \t]+" header-end t) (replace-match " ")) - - (goto-char (point-min)) - (let (recipient-address-list) - (while (re-search-forward " \\([^ ]+\\) " (point-max) t) - (backward-char 1) - (setq recipient-address-list (cons (buffer-substring (match-beginning 1) (match-end 1)) - recipient-address-list)) - ) - (setq smtpmail-recipient-address-list recipient-address-list)) - - ) - ) - ) - ) - - -(defun smtpmail-do-bcc (header-end) - "Delete BCC: and their continuation lines from the header area. -There may be multiple BCC: lines, and each may have arbitrarily -many continuation lines." - (let ((case-fold-search t)) - (save-excursion (goto-char (point-min)) - ;; iterate over all BCC: lines - (while (re-search-forward "^BCC:" header-end t) - (delete-region (match-beginning 0) (progn (forward-line 1) (point))) - ;; get rid of any continuation lines - (while (and (looking-at "^[ \t].*\n") (< (point) header-end)) - (replace-match "")) - ) - ) ;; save-excursion - ) ;; let - ) - - - -(provide 'smtpmail) - -;; smtpmail.el ends here diff --git a/lisp/mail/supercite.el b/lisp/mail/supercite.el deleted file mode 100644 index 8babd369099..00000000000 --- a/lisp/mail/supercite.el +++ /dev/null @@ -1,2020 +0,0 @@ -;;; supercite.el --- minor mode for citing mail and news replies - -;; Copyright (C) 1993 Free Software Foundation, Inc. - -;; Author: 1993 Barry A. Warsaw, Century Computing, Inc. <bwarsaw@cen.com> -;; Maintainer: supercite-help@anthem.nlm.nih.gov -;; Created: February 1993 -;; Version: 3.1 -;; Last Modified: 1993/09/22 18:58:46 -;; Keywords: mail, news - -;; supercite.el revision: 3.54 - -;; 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. - -;; LCD Archive Entry -;; supercite|Barry A. Warsaw|supercite-help@anthem.nlm.nih.gov -;; |Mail and news reply citation package -;; |1993/09/22 18:58:46|3.1| - -;; Code: - - -(require 'regi) - -;; start user configuration variables -;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv - -(defvar sc-auto-fill-region-p t - "*If non-nil, automatically fill each paragraph after it has been cited.") - -(defvar sc-blank-lines-after-headers 1 - "*Number of blank lines to leave after mail headers have been nuked. -Set to nil, to use whatever blank lines happen to occur naturally.") - -(defvar sc-citation-leader " " - "*String comprising first part of a citation.") -(defvar sc-citation-delimiter ">" - "*String comprising third part of a citation. -This string is used in both nested and non-nested citations.") -(defvar sc-citation-separator " " - "*String comprising fourth and last part of a citation.") - -(defvar sc-citation-leader-regexp "[ \t]*" - "*Regexp describing citation leader for a cited line. -This should NOT have a leading `^' character.") - -;; Nemacs and Mule users note: please see the texinfo manual for -;; suggestions on setting these variables. -(defvar sc-citation-root-regexp "[-._a-zA-Z0-9]*" - "*Regexp describing variable root part of a citation for a cited line. -This should NOT have a leading `^' character. See also -`sc-citation-nonnested-root-regexp'.") -(defvar sc-citation-nonnested-root-regexp "[-._a-zA-Z0-9]+" - "*Regexp describing the variable root part of a nested citation. -This should NOT have a leading `^' character. This variable is -related to `sc-citation-root-regexp' but whereas that variable -describes both nested and non-nested citation roots, this variable -describes only nested citation roots.") -(defvar sc-citation-delimiter-regexp "[>]+" - "*Regexp describing citation delimiter for a cited line. -This should NOT have a leading `^' character.") -(defvar sc-citation-separator-regexp "[ \t]*" - "*Regexp describing citation separator for a cited line. -This should NOT have a leading `^' character.") - -(defvar sc-cite-blank-lines-p nil - "*If non-nil, put a citation on blank lines.") - -(defvar sc-cite-frame-alist '() - "*Alist for frame selection during citing. -Each element of this list has the following form: - - (INFOKEY ((REGEXP . FRAME) - (REGEXP . FRAME) - (...))) - -Where INFOKEY is a key for `sc-mail-field', REGEXP is a regular -expression to match against the INFOKEY's value. FRAME is a citation -frame, or a variable containing a citation frame.") -(defvar sc-uncite-frame-alist '() - "*Alist for frame selection during unciting. -See the variable `sc-cite-frame-alist' for details.") -(defvar sc-recite-frame-alist '() - "*Alist for frame selection during reciting. -See the variable `sc-cite-frame-alist' for details.") - -(defvar sc-default-cite-frame - '(;; initialize fill state and temporary variables when entering - ;; frame. this makes things run much faster - (begin (progn - (sc-fill-if-different) - (setq sc-tmp-nested-regexp (sc-cite-regexp "") - sc-tmp-nonnested-regexp (sc-cite-regexp) - sc-tmp-dumb-regexp - (concat "\\(" - (sc-cite-regexp "") - "\\)" - (sc-cite-regexp sc-citation-nonnested-root-regexp)) - ))) - ;; blank lines mean paragraph separators, so fill the last cited - ;; paragraph, unless sc-cite-blank-lines-p is non-nil, in which - ;; case we treat blank lines just like any other line. - ("^[ \t]*$" (if sc-cite-blank-lines-p - (sc-cite-line) - (sc-fill-if-different ""))) - ;; do nothing if looking at a reference tag. make sure that the - ;; tag string isn't the empty string since this will match every - ;; line. it cannot be nil. - (sc-reference-tag-string (if (string= sc-reference-tag-string "") - (list 'continue) - nil)) - ;; this regexp catches nested citations in which the author cited - ;; a non-nested citation with a dumb citer. - (sc-tmp-dumb-regexp (sc-cite-coerce-dumb-citer)) - ;; if we are looking at a nested citation then add a citation level - (sc-tmp-nested-regexp (sc-add-citation-level)) - ;; if we're looking at a non-nested citation, coerce it to our style - (sc-tmp-nonnested-regexp (sc-cite-coerce-cited-line)) - ;; we must be looking at an uncited line. if we are in nested - ;; citations, just add a citation level - (sc-nested-citation-p (sc-add-citation-level)) - ;; we're looking at an uncited line and we are in non-nested - ;; citations, so cite it with a non-nested citation - (t (sc-cite-line)) - ;; be sure when we're done that we fill the last cited paragraph. - (end (sc-fill-if-different "")) - ) - "*Default REGI frame for citing a region.") - -(defvar sc-default-uncite-frame - '(;; do nothing on a blank line - ("^[ \t]*$" nil) - ;; if the line is cited, uncite it - ((sc-cite-regexp) (sc-uncite-line)) - ) - "*Default REGI frame for unciting a region.") - -(defvar sc-default-recite-frame - '(;; initialize fill state when entering frame - (begin (sc-fill-if-different)) - ;; do nothing on a blank line - ("^[ \t]*$" nil) - ;; if we're looking at a cited line, recite it - ((sc-cite-regexp) (sc-recite-line (sc-cite-regexp))) - ;; otherwise, the line is uncited, so just cite it - (t (sc-cite-line)) - ;; be sure when we're done that we fill the last cited paragraph. - (end (sc-fill-if-different "")) - ) - "*Default REGI frame for reciting a region.") - -(defvar sc-cite-region-limit t - "*This variable controls automatic citation of yanked text. -Legal values are: - -non-nil -- cite the entire region, regardless of its size -nil -- do not cite the region at all -<integer> -- a number indicating the threshold for citation. When - the number of lines in the region is greater than this - value, a warning message will be printed and the region - will not be cited. Lines in region are counted with - `count-lines'. - -The gathering of attribution information is not affected by the value -of this variable. The number of lines in the region is calculated -*after* all mail headers are removed. This variable is only consulted -during the initial citing via `sc-cite-original'.") - -(defvar sc-confirm-always-p t - "*If non-nil, always confirm attribution string before citing text body.") - -(defvar sc-default-attribution "Anon" - "*String used when author's attribution cannot be determined.") -(defvar sc-default-author-name "Anonymous" - "*String used when author's name cannot be determined.") - -(defvar sc-downcase-p nil - "*Non-nil means downcase the attribution and citation strings.") - -(defvar sc-electric-circular-p t - "*If non-nil, treat electric references as circular.") -(defvar sc-electric-mode-hook nil - "*Hook for `sc-electric-mode' electric references mode.") -(defvar sc-electric-references-p nil - "*Use electric references if non-nil.") - -(defvar sc-fixup-whitespace-p nil - "*If non-nil, delete all leading white space before citing.") - -(defvar sc-load-hook nil - "*Hook which gets run once after Supercite loads.") -(defvar sc-pre-hook nil - "*Hook which gets run before each invocation of `sc-cite-original'.") -(defvar sc-post-hook nil - "*Hook which gets run after each invocation of `sc-cite-original'.") - -(defvar sc-mail-warn-if-non-rfc822-p t - "*Warn if mail headers don't conform to RFC822.") -(defvar sc-mumble "" - "*Value returned by `sc-mail-field' if field isn't in mail headers.") - -(defvar sc-name-filter-alist - '(("^\\(Mr\\|Mrs\\|Ms\\|Dr\\)[.]?$" . 0) - ("^\\(Jr\\|Sr\\)[.]?$" . last) - ("^ASTS$" . 0) - ("^[I]+$" . last)) - "*Name list components which are filtered out as noise. -This variable contains an association list where each element is of -the form: (REGEXP . POSITION). - -REGEXP is a regular expression which matches the name list component. -Match is performed using `string-match'. POSITION is the position in -the name list which can match the regular expression, starting at zero -for the first element. Use `last' to match the last element in the -list and `any' to match all elements.") - -(defvar sc-nested-citation-p nil - "*Controls whether to use nested or non-nested citation style. -Non-nil uses nested citations, nil uses non-nested citations.") - -(defvar sc-nuke-mail-headers 'all - "*Controls mail header nuking. -Used in conjunction with `sc-nuke-mail-header-list'. Legal values are: - -`all' -- nuke all mail headers -`none' -- don't nuke any mail headers -`specified' -- nuke headers specified in `sc-nuke-mail-header-list' -`keep' -- keep headers specified in `sc-nuke-mail-header-list'") - -(defvar sc-nuke-mail-header-list nil - "*List of mail header regexps to remove or keep in body of reply. -This list contains regular expressions describing the mail headers to -keep or nuke, depending on the value of `sc-nuke-mail-headers'.") - -(defvar sc-preferred-attribution-list - '("sc-lastchoice" "x-attribution" "firstname" "initials" "lastname") - "*Specifies what to use as the attribution string. -Supercite creates a list of possible attributions when it scans the -mail headers from the original message. Each attribution choice is -associated with a key in an attribution alist. Supercite tries to -pick a \"preferred\" attribution by matching the attribution alist -keys against the elements in `sc-preferred-attribution-list' in order. -The first non-empty string value found is used as the preferred -attribution. - -Note that Supercite now honors the X-Attribution: mail field. If -present in the original message, the value of this field should always -be used to select the most preferred attribution since it reflects how -the original author would like to be distinguished. It should be -considered bad taste to put any attribution preference key before -\"x-attribution\" in this list, except perhaps for \"sc-lastchoice\" -\(see below). - -Supercite remembers the last attribution used when reciting an already -cited paragraph. This attribution will always be saved with the -\"sc-lastchoice\" key, which can be used in this list. Note that the -last choice is always reset after every call of `sc-cite-original'. - -Barring error conditions, the following preferences are always present -in the attribution alist: - -\"emailname\" -- email terminus name -\"initials\" -- initials of author -\"firstname\" -- first name of author -\"lastname\" -- last name of author -\"middlename-1\" -- first middle name of author -\"middlename-2\" -- second middle name of author -... - -Middle name indexes can be any positive integer greater than 0, -although it is unlikely that many authors will supply more than one -middle name, if that many. The string of all middle names is -associated with the key \"middlenames\".") - -(defvar sc-attrib-selection-list nil - "*An alist for selecting preferred attribution based on mail headers. -Each element of this list has the following form: - - (INFOKEY ((REGEXP . ATTRIBUTION) - (REGEXP . ATTRIBUTION) - (...))) - -Where INFOKEY is a key for `sc-mail-field', REGEXP is a regular -expression to match against the INFOKEY's value. ATTRIBUTION can be a -string or a list. If its a string, then it is the attribution that is -selected by `sc-select-attribution'. If it is a list, it is `eval'd -and the return value must be a string, which is used as the selected -attribution. Note that the variable `sc-preferred-attribution-list' -must contain an element of the string \"sc-consult\" for this variable -to be consulted during attribution selection.") - -(defvar sc-attribs-preselect-hook nil - "*Hook to run before selecting an attribution.") -(defvar sc-attribs-postselect-hook nil - "*Hook to run after selecting an attribution, but before confirmation.") - -(defvar sc-pre-cite-hook nil - "*Hook to run before citing a region of text.") -(defvar sc-pre-uncite-hook nil - "*Hook to run before unciting a region of text.") -(defvar sc-pre-recite-hook nil - "*Hook to run before reciting a region of text.") - -(defvar sc-preferred-header-style 4 - "*Index into `sc-rewrite-header-list' specifying preferred header style. -Index zero accesses the first function in the list.") - -(defvar sc-reference-tag-string ">>>>> " - "*String used at the beginning of built-in reference headers.") - -(defvar sc-rewrite-header-list - '((sc-no-header) - (sc-header-on-said) - (sc-header-inarticle-writes) - (sc-header-regarding-adds) - (sc-header-attributed-writes) - (sc-header-author-writes) - (sc-header-verbose) - (sc-no-blank-line-or-header) - ) - "*List of reference header rewrite functions. -The variable `sc-preferred-header-style' controls which function in -this list is chosen for automatic reference header insertions. -Electric reference mode will cycle through this list of functions.") - -(defvar sc-titlecue-regexp "\\s +-+\\s +" - "*Regular expression describing the separator between names and titles. -Set to nil to treat entire field as a name.") - -(defvar sc-use-only-preference-p nil - "*Controls what happens when the preferred attribution cannot be found. -If non-nil, then `sc-default-attribution' will be used. If nil, then -some secondary scheme will be employed to find a suitable attribution -string.") - -;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -;; end user configuration variables - -(defconst sc-version "3.1" - "Supercite version number.") -(defconst sc-help-address "supercite-help@anthem.nlm.nih.gov" - "Address accepting submissions of bug reports.") - -(defvar sc-mail-info nil - "Alist of mail header information gleaned from reply buffer.") -(defvar sc-attributions nil - "Alist of attributions for use when citing.") - -(defconst sc-emacs-features - (let ((version 'v18) - (flavor 'GNU)) - (if (string= (substring emacs-version 0 2) "19") - (setq version 'v19)) - (if (string-match "Lucid" emacs-version) - (setq flavor 'Lucid)) - ;; cobble up list - (list version flavor)) - "A list describing what version of Emacs we're running on. -Known flavors are: - -All GNU18's: (v18 GNU) -FSF19.x : (v19 GNU) -Lucid19.x : (v19 Lucid)") - - -(defvar sc-tmp-nested-regexp nil - "Temporary regepx describing nested citations.") -(defvar sc-tmp-nonnested-regexp nil - "Temporary regexp describing non-nested citations.") -(defvar sc-tmp-dumb-regexp nil - "Temp regexp describing non-nested citation cited with a nesting citer.") - -(defvar sc-minor-mode nil - "Supercite minor mode on flag.") -(defvar sc-mode-string " SC" - "Supercite minor mode string.") - -(make-variable-buffer-local 'sc-mail-info) -(make-variable-buffer-local 'sc-attributions) -(make-variable-buffer-local 'sc-minor-mode) - - -;; ====================================================================== -;; supercite keymaps - -(defvar sc-mode-map-prefix "\C-c\C-p" - "*Key binding to install Supercite keymap. -If this is nil, Supercite keymap is not installed.") - -(defvar sc-T-keymap () - "Keymap for sub-keymap of setting and toggling functions.") -(if sc-T-keymap - () - (setq sc-T-keymap (make-sparse-keymap)) - (define-key sc-T-keymap "a" 'sc-S-preferred-attribution-list) - (define-key sc-T-keymap "b" 'sc-T-mail-nuke-blank-lines) - (define-key sc-T-keymap "c" 'sc-T-confirm-always) - (define-key sc-T-keymap "d" 'sc-T-downcase) - (define-key sc-T-keymap "e" 'sc-T-electric-references) - (define-key sc-T-keymap "f" 'sc-T-auto-fill-region) - (define-key sc-T-keymap "h" 'sc-T-describe) - (define-key sc-T-keymap "l" 'sc-S-cite-region-limit) - (define-key sc-T-keymap "n" 'sc-S-mail-nuke-mail-headers) - (define-key sc-T-keymap "N" 'sc-S-mail-header-nuke-list) - (define-key sc-T-keymap "o" 'sc-T-electric-circular) - (define-key sc-T-keymap "p" 'sc-S-preferred-header-style) - (define-key sc-T-keymap "s" 'sc-T-nested-citation) - (define-key sc-T-keymap "u" 'sc-T-use-only-preferences) - (define-key sc-T-keymap "w" 'sc-T-fixup-whitespace) - (define-key sc-T-keymap "?" 'sc-T-describe) - ) - -(defvar sc-mode-map () - "Keymap for Supercite quasi-mode.") -(if sc-mode-map - () - (setq sc-mode-map (make-sparse-keymap)) - (define-key sc-mode-map "c" 'sc-cite-region) - (define-key sc-mode-map "f" 'sc-mail-field-query) - (define-key sc-mode-map "g" 'sc-mail-process-headers) - (define-key sc-mode-map "h" 'sc-describe) - (define-key sc-mode-map "i" 'sc-insert-citation) - (define-key sc-mode-map "o" 'sc-open-line) - (define-key sc-mode-map "r" 'sc-recite-region) - (define-key sc-mode-map "\C-p" 'sc-raw-mode-toggle) - (define-key sc-mode-map "u" 'sc-uncite-region) - (define-key sc-mode-map "v" 'sc-version) - (define-key sc-mode-map "w" 'sc-insert-reference) - (define-key sc-mode-map "\C-t" sc-T-keymap) - (define-key sc-mode-map "\C-b" 'sc-submit-bug-report) - (define-key sc-mode-map "?" 'sc-describe) - ) - -(defvar sc-electric-mode-map () - "Keymap for `sc-electric-mode' electric references mode.") -(if sc-electric-mode-map - nil - (setq sc-electric-mode-map (make-sparse-keymap)) - (define-key sc-electric-mode-map "p" 'sc-eref-prev) - (define-key sc-electric-mode-map "n" 'sc-eref-next) - (define-key sc-electric-mode-map "s" 'sc-eref-setn) - (define-key sc-electric-mode-map "j" 'sc-eref-jump) - (define-key sc-electric-mode-map "x" 'sc-eref-abort) - (define-key sc-electric-mode-map "q" 'sc-eref-abort) - (define-key sc-electric-mode-map "\r" 'sc-eref-exit) - (define-key sc-electric-mode-map "\n" 'sc-eref-exit) - (define-key sc-electric-mode-map "g" 'sc-eref-goto) - (define-key sc-electric-mode-map "?" 'describe-mode) - (define-key sc-electric-mode-map "\C-h" 'describe-mode) - (define-key sc-electric-mode-map [f1] 'describe-mode) - (define-key sc-electric-mode-map [help] 'describe-mode) - ) - -(defvar sc-minibuffer-local-completion-map nil - "Keymap for minibuffer confirmation of attribution strings.") -(if sc-minibuffer-local-completion-map - () - (setq sc-minibuffer-local-completion-map - (copy-keymap minibuffer-local-completion-map)) - (define-key sc-minibuffer-local-completion-map "\C-t" 'sc-toggle-fn) - (define-key sc-minibuffer-local-completion-map " " 'self-insert-command)) - -(defvar sc-minibuffer-local-map nil - "Keymap for minibuffer confirmation of attribution strings.") -(if sc-minibuffer-local-map - () - (setq sc-minibuffer-local-map (copy-keymap minibuffer-local-map)) - (define-key sc-minibuffer-local-map "\C-t" 'sc-toggle-fn)) - - -;; ====================================================================== -;; utility functions - -(defun sc-completing-read (prompt table &optional predicate require-match - initial-contents history) - "Compatibility between Emacs 18 and 19 `completing-read'. -In version 18, the HISTORY argument is ignored." - (if (memq 'v19 sc-emacs-features) - (funcall 'completing-read prompt table predicate require-match - initial-contents history) - (funcall 'completing-read prompt table predicate require-match - (or (car-safe initial-contents) - initial-contents)))) - -(defun sc-read-string (prompt &optional initial-contents history) - "Compatibility between Emacs 18 and 19 `read-string'. -In version 18, the HISTORY argument is ignored." - (if (memq 'v19 sc-emacs-features) - ;; maybe future versions will take a `history' argument: - (read-string prompt initial-contents) - (read-string prompt initial-contents))) - -(if (fboundp 'match-string) - (defalias 'sc-submatch 'match-string) - (defun sc-submatch (matchnum &optional string) - "Returns `match-beginning' and `match-end' sub-expression for MATCHNUM. -If optional STRING is provided, take sub-expression using `substring' -of argument, otherwise use `buffer-substring' on current buffer. Note -that `match-data' must have already been generated and no error -checking is performed by this function." - (if string - (substring string (match-beginning matchnum) (match-end matchnum)) - (buffer-substring (match-beginning matchnum) (match-end matchnum))))) - -(if (fboundp 'member) - (defalias 'sc-member 'member) - (defun sc-member (elt list) - "Like `memq', but uses `equal' instead of `eq'. -Emacs19 has a builtin function `member' which does exactly this." - (catch 'elt-is-member - (while list - (if (equal elt (car list)) - (throw 'elt-is-member list)) - (setq list (cdr list)))))) - -;; One day maybe Emacs will have this... -(if (fboundp 'string-text) - (defalias 'sc-string-text 'string-text) - (defun sc-string-text (string) - "Return STRING with all text properties removed." - (let ((string (copy-sequence string))) - (set-text-properties 0 (length string) nil string) - string))) - -(defun sc-ask (alist) - "Ask a question in the minibuffer requiring a single character answer. -This function is kind of an extension of `y-or-n-p' where a single -letter is used to answer a question. Question is formed from ALIST -which has members of the form: (WORD . LETTER). WORD is the long -word form, while LETTER is the letter for selecting that answer. The -selected letter is returned, or nil if the question was not answered. -Note that WORD is a string and LETTER is a character. All LETTERs in -the list should be unique." - (let* ((prompt (concat - (mapconcat (function (lambda (elt) (car elt))) alist ", ") - "? (" - (mapconcat - (function - (lambda (elt) (char-to-string (cdr elt)))) alist "/") - ") ")) - (p prompt) - (event - (if (memq 'Lucid sc-emacs-features) - (allocate-event) - nil))) - (while (stringp p) - (if (let ((cursor-in-echo-area t) - (inhibit-quit t)) - (message "%s" p) - ;; lets be good neighbors and be compatible with all emacsen - (cond - ((memq 'v18 sc-emacs-features) - (setq event (read-char))) - ((memq 'Lucid sc-emacs-features) - (next-command-event event)) - (t ; must be FSF19 - (setq event (read-event)))) - (prog1 quit-flag (setq quit-flag nil))) - (progn - (message "%s%s" p (single-key-description event)) - (and (memq 'Lucid sc-emacs-features) - (deallocate-event event)) - (setq quit-flag nil) - (signal 'quit '()))) - (let ((char - (if (memq 'Lucid sc-emacs-features) - (let* ((key (and (key-press-event-p event) (event-key event))) - (char (and key (event-to-character event)))) - char) - event)) - elt) - (if char (setq char (downcase char))) - (cond - ((setq elt (rassq char alist)) - (message "%s%s" p (car elt)) - (setq p (cdr elt))) - ((and (memq 'Lucid sc-emacs-features) - (button-release-event-p event)) ; ignore them - nil) - (t - (message "%s%s" p (single-key-description event)) - (if (memq 'Lucid sc-emacs-features) - (ding nil 'y-or-n-p) - (ding)) - (discard-input) - (if (eq p prompt) - (setq p (concat "Try again. " prompt))))))) - (and (memq 'Lucid sc-emacs-features) - (deallocate-event event)) - p)) - -(defun sc-scan-info-alist (alist) - "Find a match in the info alist that matches a regexp in ALIST." - (let ((sc-mumble "") - rtnvalue) - (while alist - (let* ((elem (car alist)) - (infokey (car elem)) - (infoval (sc-mail-field infokey)) - (mlist (car (cdr elem)))) - (while mlist - (let* ((ml-elem (car mlist)) - (regexp (car ml-elem)) - (thing (cdr ml-elem))) - (if (string-match regexp infoval) - ;; we found a match, time to return - (setq rtnvalue thing - mlist nil - alist nil) - ;; else we didn't find a match - (setq mlist (cdr mlist)) - ))) ;end of mlist loop - (setq alist (cdr alist)) - )) ;end of alist loop - rtnvalue)) - - -;; ====================================================================== -;; extract mail field information from headers in reply buffer - -;; holder variables for bc happiness -(defvar sc-mail-headers-start nil - "Start of header fields.") -(defvar sc-mail-headers-end nil - "End of header fields.") -(defvar sc-mail-field-history nil - "For minibuffer completion on mail field queries.") -(defvar sc-mail-field-modification-history nil - "For minibuffer completion on mail field modifications.") -(defvar sc-mail-glom-frame - '((begin (setq sc-mail-headers-start (point))) - ("^x-attribution:[ \t]+.*$" (sc-mail-fetch-field t) nil t) - ("^\\S +:.*$" (sc-mail-fetch-field) nil t) - ("^$" (list 'abort '(step . 0))) - ("^[ \t]+" (sc-mail-append-field)) - (sc-mail-warn-if-non-rfc822-p (sc-mail-error-in-mail-field)) - (end (setq sc-mail-headers-end (point)))) - "Regi frame for glomming mail header information.") - -;; regi functions -(defun sc-mail-fetch-field (&optional attribs-p) - "Insert a key and value into `sc-mail-info' alist. -If optional ATTRIBS-P is non-nil, the key/value pair is placed in -`sc-attributions' too." - (if (string-match "^\\(\\S *\\)\\s *:\\s +\\(.*\\)$" curline) - (let* ((key (downcase (sc-string-text (sc-submatch 1 curline)))) - (val (sc-string-text (sc-submatch 2 curline))) - (keyval (cons key val))) - (setq sc-mail-info (cons keyval sc-mail-info)) - (if attribs-p - (setq sc-attributions (cons keyval sc-attributions))) - )) - nil) - -(defun sc-mail-append-field () - "Append a continuation line onto the last fetched mail field's info." - (let ((keyval (car sc-mail-info))) - (if (and keyval (string-match "^\\s *\\(.*\\)$" curline)) - (setcdr keyval (concat (cdr keyval) " " - (sc-string-text (sc-submatch 1 curline)))))) - nil) - -(defun sc-mail-error-in-mail-field () - "Issue warning that mail headers don't conform to RFC 822." - (let* ((len (min (length curline) 10)) - (ellipsis (if (< len (length curline)) "..." "")) - (msg "Mail header \"%s%s\" doesn't conform to RFC 822. skipping...")) - (message msg (substring curline 0 len) ellipsis)) - (beep) - (sit-for 2) - nil) - -;; mail header nuking -(defvar sc-mail-last-header-nuked-p nil - "True if the last header was nuked.") - -(defun sc-mail-nuke-line () - "Nuke the current mail header line." - (delete-region (regi-pos 'bol) (regi-pos 'bonl)) - '((step . -1))) - -(defun sc-mail-nuke-header-line () - "Delete current-line and set up for possible continuation." - (setq sc-mail-last-header-nuked-p t) - (sc-mail-nuke-line)) - -(defun sc-mail-nuke-continuation-line () - "Delete a continuation line if the last header line was deleted." - (if sc-mail-last-header-nuked-p - (sc-mail-nuke-line))) - -(defun sc-mail-cleanup-blank-lines () - "Leave some blank lines after original mail headers are nuked. -The number of lines left is specified by `sc-blank-lines-after-headers'." - (if sc-blank-lines-after-headers - (save-restriction - (widen) - (skip-chars-backward " \t\n") - (forward-line 1) - (delete-blank-lines) - (beginning-of-line) - (if (looking-at "[ \t]*$") - (delete-region (regi-pos 'bol) (regi-pos 'bonl))) - (insert-char ?\n sc-blank-lines-after-headers))) - nil) - -(defun sc-mail-build-nuke-frame () - "Build the regiframe for nuking mail headers." - (let (every-func entry-func nonentry-func) - (cond - ((eq sc-nuke-mail-headers 'all) - (setq every-func '(progn (forward-line -1) (sc-mail-nuke-line)))) - ((eq sc-nuke-mail-headers 'specified) - (setq entry-func '(sc-mail-nuke-header-line) - nonentry-func '(setq sc-mail-last-header-nuked-p nil))) - ((eq sc-nuke-mail-headers 'keep) - (setq entry-func '(setq sc-mail-last-header-nuked-p nil) - nonentry-func '(sc-mail-nuke-header-line))) - ;; we never get far enough to interpret a frame if s-n-m-h == 'none - ((eq sc-nuke-mail-headers 'none)) - (t (error "Illegal value for sc-nuke-mail-headers: %s" - sc-nuke-mail-headers)) - ) ; end-cond - (append - (and entry-func - (regi-mapcar sc-nuke-mail-header-list entry-func nil t)) - (and nonentry-func (list (list "^\\S +:.*$" nonentry-func))) - (and (not every-func) - '(("^[ \t]+" (sc-mail-nuke-continuation-line)))) - '((begin (setq sc-mail-last-header-zapped-p nil))) - '((end (sc-mail-cleanup-blank-lines))) - (and every-func (list (list 'every every-func))) - ))) - -;; mail processing and zapping. this is the top level entry defun to -;; all header processing. -(defun sc-mail-process-headers (start end) - "Process original mail message's mail headers. -After processing, mail headers may be nuked. Header information is -stored in `sc-mail-info', and any old information is lost unless an -error occurs." - (interactive "r") - (let ((info (copy-alist sc-mail-info)) - (attribs (copy-alist sc-attributions))) - (setq sc-mail-info nil - sc-attributions nil) - (regi-interpret sc-mail-glom-frame start end) - (if (null sc-mail-info) - (progn - (message "No mail headers found! Restoring old information.") - (setq sc-mail-info info - sc-attributions attribs)) - (regi-interpret (sc-mail-build-nuke-frame) - sc-mail-headers-start sc-mail-headers-end) - ))) - - -;; let the user change mail field information -(defun sc-mail-field (field) - "Return the mail header field value associated with FIELD. -If there was no mail header with FIELD as its key, return the value of -`sc-mumble'. FIELD is case insensitive." - (or (cdr (assoc (downcase field) sc-mail-info)) sc-mumble)) - -(defun sc-mail-field-query (arg) - "View the value of a mail field. -With `\\[universal-argument]', prompts for action on mail field. -Action can be one of: View, Modify, Add, or Delete." - (interactive "P") - (let* ((alist '(("view" . ?v) ("modify" . ?m) ("add" . ?a) ("delete" . ?d))) - (action (if (not arg) ?v (sc-ask alist))) - key) - (if (not action) - () - (setq key (sc-completing-read - (concat (car (rassq action alist)) - " information key: ") - sc-mail-info nil - (if (eq action ?a) nil 'noexit) - nil 'sc-mail-field-history)) - (cond - ((eq action ?v) - (message "%s: %s" key (cdr (assoc key sc-mail-info)))) - ((eq action ?d) - (setq sc-mail-info (delq (assoc key sc-mail-info) sc-mail-info))) - ((eq action ?m) - (let ((keyval (assoc key sc-mail-info))) - ;; first put initial value onto list if not already there - (if (not (sc-member (cdr keyval) - sc-mail-field-modification-history)) - (setq sc-mail-field-modification-history - (cons (cdr keyval) sc-mail-field-modification-history))) - (setcdr keyval (sc-read-string - (concat key ": ") (cdr keyval) - 'sc-mail-field-modification-history)))) - ((eq action ?a) - (setq sc-mail-info - (cons (cons key - (sc-read-string (concat key ": "))) sc-mail-info))) - )))) - - -;; ====================================================================== -;; attributions - -(defvar sc-attribution-confirmation-history nil - "History for confirmation of attribution strings.") -(defvar sc-citation-confirmation-history nil - "History for confirmation of attribution prefixes.") - -(defun sc-attribs-%@-addresses (from &optional delim) - "Extract the author's email terminus from email address FROM. -Match addresses of the style ``name%[stuff].'' when called with DELIM -of \"%\" and addresses of the style ``[stuff]name@[stuff]'' when -called with DELIM \"@\". If DELIM is nil or not provided, matches -addresses of the style ``name''." - (and (string-match (concat "[-a-zA-Z0-9_.]+" delim) from 0) - (substring from - (match-beginning 0) - (- (match-end 0) (if (null delim) 0 1))))) - -(defun sc-attribs-!-addresses (from) - "Extract the author's email terminus from email address FROM. -Match addresses of the style ``[stuff]![stuff]...!name[stuff].''" - (let ((eos (length from)) - (mstart (string-match "![-a-zA-Z0-9_.]+\\([^-!a-zA-Z0-9_.]\\|$\\)" - from 0)) - (mend (match-end 0))) - (and mstart - (substring from (1+ mstart) (- mend (if (= mend eos) 0 1))) - ))) - -(defun sc-attribs-<>-addresses (from) - "Extract the author's email terminus from email address FROM. -Match addresses of the style ``<name[stuff]>.''" - (and (string-match "<\\(.*\\)>" from) - (sc-submatch 1 from))) - -(defun sc-get-address (from author) - "Get the full email address path from FROM. -AUTHOR is the author's name (which is removed from the address)." - (let ((eos (length from))) - (if (string-match (concat "\\(^\\|^\"\\)" author - "\\(\\s +\\|\"\\s +\\)") from 0) - (let ((address (substring from (match-end 0) eos))) - (if (and (= (aref address 0) ?<) - (= (aref address (1- (length address))) ?>)) - (substring address 1 (1- (length address))) - address)) - (if (string-match "[-a-zA-Z0-9!@%._]+" from 0) - (sc-submatch 0 from) - "") - ))) - -(defun sc-attribs-emailname (from) - "Get the email terminus name from FROM." - (or - (sc-attribs-%@-addresses from "%") - (sc-attribs-%@-addresses from "@") - (sc-attribs-!-addresses from) - (sc-attribs-<>-addresses from) - (sc-attribs-%@-addresses from) - (substring from 0 10))) - -(defun sc-name-substring (string start end extend) - "Extract the specified substring of STRING from START to END. -EXTEND is the number of characters on each side to extend the -substring." - (and start - (let ((sos (+ start extend)) - (eos (- end extend))) - (substring string sos - (or (string-match sc-titlecue-regexp string sos) eos) - )))) - -(defun sc-attribs-extract-namestring (from) - "Extract the name string from FROM. -This should be the author's full name minus an optional title." - (let ((namestring - (or - ;; If there is a <...> in the name, - ;; treat everything before that as the full name. - ;; Even if it contains parens, use the whole thing. - ;; On the other hand, we do look for quotes in the usual way. - (and (string-match " *<.*>" from 0) - (let ((before-angles - (sc-name-substring from 0 (match-beginning 0) 0))) - (if (string-match "\".*\"" before-angles 0) - (sc-name-substring - before-angles (match-beginning 0) (match-end 0) 1) - before-angles))) - (sc-name-substring - from (string-match "(.*)" from 0) (match-end 0) 1) - (sc-name-substring - from (string-match "\".*\"" from 0) (match-end 0) 1) - (sc-name-substring - from (string-match "\\([-.a-zA-Z0-9_]+\\s +\\)+<" from 0) - (match-end 1) 0) - (sc-attribs-emailname from)))) - ;; strip off any leading or trailing whitespace - (if namestring - (let ((bos 0) - (eos (1- (length namestring)))) - (while (and (<= bos eos) - (memq (aref namestring bos) '(32 ?\t))) - (setq bos (1+ bos))) - (while (and (> eos bos) - (memq (aref namestring eos) '(32 ?\t))) - (setq eos (1- eos))) - (substring namestring bos (1+ eos)))))) - -(defun sc-attribs-chop-namestring (namestring) - "Convert NAMESTRING to a list of names. -example: (sc-namestring-to-list \"John Xavier Doe\") - => (\"John\" \"Xavier\" \"Doe\")" - (if (string-match "\\([ \t]*\\)\\([^ \t._]+\\)\\([ \t]*\\)" namestring) - (cons (sc-submatch 2 namestring) - (sc-attribs-chop-namestring (substring namestring (match-end 3))) - ))) - -(defun sc-attribs-strip-initials (namelist) - "Extract the author's initials from the NAMELIST." - (mapconcat - (function - (lambda (name) - (if (< 0 (length name)) - (substring name 0 1)))) - namelist "")) - -(defun sc-guess-attribution (&optional string) - "Guess attribution string on current line. -If attribution cannot be guessed, nil is returned. Optional STRING if -supplied, is used instead of the line point is on in the current buffer." - (let ((start 0) - (string (or string (buffer-substring (regi-pos 'bol) (regi-pos 'eol)))) - attribution) - (and - (= start (or (string-match sc-citation-leader-regexp string start) -1)) - (setq start (match-end 0)) - (= start (or (string-match sc-citation-root-regexp string start) 1)) - (setq attribution (sc-submatch 0 string) - start (match-end 0)) - (= start (or (string-match sc-citation-delimiter-regexp string start) -1)) - (setq start (match-end 0)) - (= start (or (string-match sc-citation-separator-regexp string start) -1)) - attribution))) - -(defun sc-attribs-filter-namelist (namelist) - "Filter out noise in NAMELIST according to `sc-name-filter-alist'." - (let ((elements (length namelist)) - (position -1) - keepers filtered-list) - (mapcar - (function - (lambda (name) - (setq position (1+ position)) - (let ((keep-p t)) - (mapcar - (function - (lambda (filter) - (let ((regexp (car filter)) - (pos (cdr filter))) - (if (and (string-match regexp name) - (or (and (numberp pos) - (= pos position)) - (and (eq pos 'last) - (= position (1- elements))) - (eq pos 'any))) - (setq keep-p nil)) - ))) - sc-name-filter-alist) - (if keep-p - (setq keepers (cons position keepers))) - ))) - namelist) - (mapcar - (function - (lambda (position) - (setq filtered-list (cons (nth position namelist) filtered-list)) - )) - keepers) - filtered-list)) - -(defun sc-attribs-chop-address (from) - "Extract attribution information from FROM. -This populates the `sc-attributions' with the list of possible attributions." - (if (and (stringp from) - (< 0 (length from))) - (let* ((sc-mumble "") - (namestring (sc-attribs-extract-namestring from)) - (namelist (sc-attribs-filter-namelist - (sc-attribs-chop-namestring namestring))) - (revnames (reverse (cdr namelist))) - (firstname (car namelist)) - (midnames (reverse (cdr revnames))) - (lastname (car revnames)) - (initials (sc-attribs-strip-initials namelist)) - (emailname (sc-attribs-emailname from)) - (n 1) - author middlenames) - - ;; put basic information - (setq - ;; put middle names and build sc-author entry - middlenames (mapconcat - (function - (lambda (midname) - (let ((key-attribs (format "middlename-%d" n)) - (key-mail (format "sc-middlename-%d" n))) - (setq - sc-attributions (cons (cons key-attribs midname) - sc-attributions) - sc-mail-info (cons (cons key-mail midname) - sc-mail-info) - n (1+ n)) - midname))) - midnames " ") - - author (concat firstname " " middlenames (and midnames " ") lastname) - - sc-attributions (append - (list - (cons "firstname" firstname) - (cons "lastname" lastname) - (cons "emailname" emailname) - (cons "initials" initials)) - sc-attributions) - sc-mail-info (append - (list - (cons "sc-firstname" firstname) - (cons "sc-middlenames" middlenames) - (cons "sc-lastname" lastname) - (cons "sc-emailname" emailname) - (cons "sc-initials" initials) - (cons "sc-author" author) - (cons "sc-from-address" (sc-get-address - (sc-mail-field "from") - namestring)) - (cons "sc-reply-address" (sc-get-address - (sc-mail-field "reply-to") - namestring)) - (cons "sc-sender-address" (sc-get-address - (sc-mail-field "sender") - namestring)) - ) - sc-mail-info) - )) - ;; from string is empty - (setq sc-mail-info (cons (cons "sc-author" sc-default-author-name) - sc-mail-info)))) - -(defvar sc-attrib-or-cite nil - "Used to toggle between attribution input or citation input.") - -(defun sc-toggle-fn () - "Toggle between attribution selection and citation selection. -Only used during confirmation." - (interactive) - (setq sc-attrib-or-cite (not sc-attrib-or-cite)) - (throw 'sc-reconfirm t)) - -(defun sc-select-attribution () - "Select an attribution from `sc-attributions'. - -Variables involved in selection process include: - `sc-preferred-attribution-list' - `sc-use-only-preference-p' - `sc-confirm-always-p' - `sc-default-attribution' - `sc-attrib-selection-list'. - -Runs the hook `sc-attribs-preselect-hook' before selecting an -attribution and the hook `sc-attribs-postselect-hook' after making the -selection but before querying is performed. During -`sc-attribs-postselect-hook' the variable `citation' is bound to the -auto-selected citation string and the variable `attribution' is bound -to the auto-selected attribution string." - (run-hooks 'sc-attribs-preselect-hook) - (let ((query-p sc-confirm-always-p) - attribution citation - (attriblist sc-preferred-attribution-list)) - - ;; first cruise through sc-preferred-attribution-list looking for - ;; a match in either sc-attributions or sc-mail-info. if the - ;; element is "sc-consult", then we have to do the alist - ;; consultation phase - (while attriblist - (let* ((preferred (car attriblist))) - (cond - ((string= preferred "sc-consult") - ;; we've been told to consult the attribution vs. mail - ;; header key alist. we do this until we find a match in - ;; the sc-attrib-selection-list. if we do not find a match, - ;; we continue scanning attriblist - (let ((attrib (sc-scan-info-alist sc-attrib-selection-list))) - (cond - ((not attrib) - (setq attriblist (cdr attriblist))) - ((stringp attrib) - (setq attribution attrib - attriblist nil)) - ((listp attrib) - (setq attribution (eval attrib) - attriblist nil)) - (t (error "%s did not evaluate to a string or list!" - "sc-attrib-selection-list")) - ))) - ((setq attribution (cdr (assoc preferred sc-attributions))) - (setq attriblist nil)) - (t - (setq attriblist (cdr attriblist))) - ))) - - ;; if preference was not found, we may use a secondary method to - ;; find a valid attribution - (if (and (not attribution) - (not sc-use-only-preference-p)) - ;; secondary method tries to find a preference in this order - ;; 1. sc-lastchoice - ;; 2. x-attribution - ;; 3. firstname - ;; 4. lastname - ;; 5. initials - ;; 6. first non-empty attribution in alist - (setq attribution - (or (cdr (assoc "sc-lastchoice" sc-attributions)) - (cdr (assoc "x-attribution" sc-attributions)) - (cdr (assoc "firstname" sc-attributions)) - (cdr (assoc "lastname" sc-attributions)) - (cdr (assoc "initials" sc-attributions)) - (cdr (car sc-attributions))))) - - ;; still couldn't find an attribution. we're now limited to using - ;; the default attribution, but we'll force a query when this happens - (if (not attribution) - (setq attribution sc-default-attribution - query-p t)) - - ;; create the attribution prefix - (setq citation (sc-make-citation attribution)) - - ;; run the post selection hook before querying the user - (run-hooks 'sc-attribs-postselect-hook) - - ;; query for confirmation - (if query-p - (let* ((query-alist (mapcar (function (lambda (entry) - (list (cdr entry)))) - sc-attributions)) - (minibuffer-local-completion-map - sc-minibuffer-local-completion-map) - (minibuffer-local-map sc-minibuffer-local-map) - (initial attribution) - (completer-disable t) ; in case completer.el is used - choice) - (setq sc-attrib-or-cite nil) ; nil==attribution, t==citation - (while - (catch 'sc-reconfirm - (string= "" (setq choice - (if sc-attrib-or-cite - (sc-read-string - "Enter citation prefix: " - citation - 'sc-citation-confirmation-history) - (sc-completing-read - "Complete attribution name: " - query-alist nil nil - (cons initial 0) - 'sc-attribution-confirmation-history) - ))))) - (if sc-attrib-or-cite - ;; since the citation was chosen, we have to guess at - ;; the attribution - (setq citation choice - attribution (or (sc-guess-attribution citation) - citation)) - - (setq citation (sc-make-citation choice) - attribution choice)) - )) - - ;; its possible that the user wants to downcase the citation and - ;; attribution - (if sc-downcase-p - (setq citation (downcase citation) - attribution (downcase attribution))) - - ;; set up mail info alist - (let* ((ckey "sc-citation") - (akey "sc-attribution") - (ckeyval (assoc ckey sc-mail-info)) - (akeyval (assoc akey sc-mail-info))) - (if ckeyval - (setcdr ckeyval citation) - (setq sc-mail-info - (append (list (cons ckey citation)) sc-mail-info))) - (if akeyval - (setcdr akeyval attribution) - (setq sc-mail-info - (append (list (cons akey attribution)) sc-mail-info)))) - - ;; set the sc-lastchoice attribution - (let* ((lkey "sc-lastchoice") - (lastchoice (assoc lkey sc-attributions))) - (if lastchoice - (setcdr lastchoice attribution) - (setq sc-attributions - (cons (cons lkey attribution) sc-attributions)))) - )) - - -;; ====================================================================== -;; filladapt hooks for supercite 3.1. you shouldn't need anything -;; extra to make gin-mode understand supercited lines. Even this -;; stuff might not be entirely necessary... - -(defun sc-cite-regexp (&optional root-regexp) - "Return a regexp describing a Supercited line. -The regexp is the concatenation of `sc-citation-leader-regexp', -`sc-citation-root-regexp', `sc-citation-delimiter-regexp', and -`sc-citation-separator-regexp'. If optional ROOT-REGEXP is supplied, -use it instead of `sc-citation-root-regexp'." - (concat sc-citation-leader-regexp - (or root-regexp sc-citation-root-regexp) - sc-citation-delimiter-regexp - sc-citation-separator-regexp)) - -(defun sc-make-citation (attribution) - "Make a non-nested citation from ATTRIBUTION." - (concat sc-citation-leader - attribution - sc-citation-delimiter - sc-citation-separator)) - -(defun sc-setup-filladapt () - "Setup `filladapt-prefix-table' to handle Supercited paragraphs." - (let* ((fa-sc-elt 'filladapt-supercite-included-text) - (elt (rassq fa-sc-elt filladapt-prefix-table))) - (if elt (setcar elt (sc-cite-regexp)) - (message "Filladapt doesn't seem to know about Supercite.") - (beep)))) - - -;; ====================================================================== -;; citing and unciting regions of text - -(defvar sc-fill-begin 1 - "Buffer position to begin filling.") -(defvar sc-fill-line-prefix "" - "Fill prefix of previous line") - -;; filling -(defun sc-fill-if-different (&optional prefix) - "Fill the region bounded by `sc-fill-begin' and point. -Only fill if optional PREFIX is different than `sc-fill-line-prefix'. -If `sc-auto-fill-region-p' is nil, do not fill region. If PREFIX is -not supplied, initialize fill variables. This is useful for a regi -`begin' frame-entry." - (if (not prefix) - (setq sc-fill-line-prefix "" - sc-fill-begin (regi-pos 'bol)) - (if (and sc-auto-fill-region-p - (not (string= prefix sc-fill-line-prefix))) - (let ((fill-prefix sc-fill-line-prefix)) - (if (not (string= fill-prefix "")) - (fill-region sc-fill-begin (regi-pos 'bol))) - (setq sc-fill-line-prefix prefix - sc-fill-begin (regi-pos 'bol)))) - ) - nil) - -(defun sc-cite-coerce-cited-line () - "Coerce a Supercited line to look like our style." - (let* ((attribution (sc-guess-attribution)) - (regexp (sc-cite-regexp attribution)) - (prefix (sc-make-citation attribution))) - (if (and attribution - (looking-at regexp)) - (progn - (delete-region - (match-beginning 0) - (save-excursion - (goto-char (match-end 0)) - (if (bolp) (forward-char -1)) - (point))) - (insert prefix) - (sc-fill-if-different prefix))) - nil)) - -(defun sc-cite-coerce-dumb-citer () - "Coerce a non-nested citation that's been cited with a dumb nesting citer." - (delete-region (match-beginning 1) (match-end 1)) - (beginning-of-line) - (sc-cite-coerce-cited-line)) - -(defun sc-guess-nesting (&optional string) - "Guess the citation nesting on the current line. -If nesting cannot be guessed, nil is returned. Optional STRING if -supplied, is used instead of the line point is on in the current -buffer." - (let ((start 0) - (string (or string (buffer-substring (regi-pos 'bol) (regi-pos 'eol)))) - nesting) - (and - (= start (or (string-match sc-citation-leader-regexp string start) -1)) - (setq start (match-end 0)) - (= start (or (string-match sc-citation-delimiter-regexp string start) -1)) - (setq nesting (sc-submatch 0 string) - start (match-end 0)) - (= start (or (string-match sc-citation-separator-regexp string start) -1)) - nesting))) - -(defun sc-add-citation-level () - "Add a citation level for nested citation style w/ coercion." - (let* ((nesting (sc-guess-nesting)) - (citation (make-string (1+ (length nesting)) - (string-to-char sc-citation-delimiter))) - (prefix (concat sc-citation-leader citation sc-citation-separator))) - (if (looking-at (sc-cite-regexp "")) - (delete-region (match-beginning 0) (match-end 0))) - (insert prefix) - (sc-fill-if-different prefix))) - -(defun sc-cite-line (&optional citation) - "Cite a single line of uncited text. -Optional CITATION overrides any citation automatically selected." - (if sc-fixup-whitespace-p - (fixup-whitespace)) - (let ((prefix (or citation - (cdr (assoc "sc-citation" sc-mail-info)) - sc-default-attribution))) - (insert prefix) - (sc-fill-if-different prefix)) - nil) - -(defun sc-uncite-line () - "Remove citation from current line." - (let ((cited (looking-at (sc-cite-regexp)))) - (if cited - (delete-region (match-beginning 0) (match-end 0)))) - nil) - -(defun sc-recite-line (regexp) - "Remove citation matching REGEXP from current line and recite line." - (let ((cited (looking-at (concat "^" regexp))) - (prefix (cdr (assoc "sc-citation" sc-mail-info)))) - (if cited - (delete-region (match-beginning 0) (match-end 0))) - (insert (or prefix sc-default-attribution)) - (sc-fill-if-different prefix)) - nil) - -;; interactive functions -(defun sc-cite-region (start end &optional confirm-p) - "Cite a region delineated by START and END. -If optional CONFIRM-P is non-nil, the attribution is confirmed before -its use in the citation string. This function first runs -`sc-pre-cite-hook'." - (interactive "r\nP") - (undo-boundary) - (let ((frame (or (sc-scan-info-alist sc-cite-frame-alist) - sc-default-cite-frame)) - (sc-confirm-always-p (if confirm-p t sc-confirm-always-p))) - (run-hooks 'sc-pre-cite-hook) - (if (interactive-p) - (sc-select-attribution)) - (regi-interpret frame start end))) - -(defun sc-uncite-region (start end) - "Uncite a region delineated by START and END. -First runs `sc-pre-uncite-hook'." - (interactive "r") - (undo-boundary) - (let ((frame (or (sc-scan-info-alist sc-uncite-frame-alist) - sc-default-uncite-frame))) - (run-hooks 'sc-pre-uncite-hook) - (regi-interpret frame start end))) - -(defun sc-recite-region (start end) - "Recite a region delineated by START and END. -First runs `sc-pre-recite-hook'." - (interactive "r") - (let ((sc-confirm-always-p t)) - (sc-select-attribution)) - (undo-boundary) - (let ((frame (or (sc-scan-info-alist sc-recite-frame-alist) - sc-default-recite-frame))) - (run-hooks 'sc-pre-recite-hook) - (regi-interpret frame start end))) - - -;; ====================================================================== -;; building headers - -(defun sc-hdr (prefix field &optional sep return-nil-p) - "Returns a concatenation of PREFIX and FIELD. -If FIELD is not a string or is the empty string, the empty string will -be returned. Optional third argument SEP is concatenated on the end if -it is a string. Returns empty string, unless optional RETURN-NIL-P is -non-nil." - (if (and (stringp field) - (not (string= field ""))) - (concat prefix field (or sep "")) - (and (not return-nil-p) ""))) - -(defun sc-whofrom () - "Return the value of (sc-mail-field \"from\") or nil." - (let ((sc-mumble nil)) - (sc-mail-field "from"))) - -(defun sc-no-header () - "Does nothing. Use this instead of nil to get a blank header." - ()) - -(defun sc-no-blank-line-or-header() - "Similar to `sc-no-header' except it removes the preceding blank line." - (if (not (bobp)) - (if (and (eolp) - (progn (forward-line -1) - (or (looking-at - (concat "^" (regexp-quote mail-header-separator) "$")) - (and (eq major-mode 'mh-letter-mode) - (mh-in-header-p))))) - (progn (forward-line) - (let ((kill-lines-magic t)) - (kill-line)))))) - -(defun sc-header-on-said () - "\"On <date>, <from> said:\" unless: -1. the \"from\" field cannot be found, in which case nothing is inserted; -2. the \"date\" field is missing in which case only the from part is printed." - (let ((sc-mumble "") - (whofrom (sc-whofrom))) - (if whofrom - (insert sc-reference-tag-string - (sc-hdr "On " (sc-mail-field "date") ", ") - whofrom " said:\n")))) - -(defun sc-header-inarticle-writes () - "\"In article <message-id>, <from> writes:\" -Treats \"message-id\" and \"from\" fields similar to `sc-header-on-said'." - (let ((sc-mumble "") - (whofrom (sc-mail-field "from"))) - (if whofrom - (insert sc-reference-tag-string - (sc-hdr "In article " (sc-mail-field "message-id") ", ") - whofrom " writes:\n")))) - -(defun sc-header-regarding-adds () - "\"Regarding <subject>; <from> adds:\" -Treats \"subject\" and \"from\" fields similar to `sc-header-on-said'." - (let ((sc-mumble "") - (whofrom (sc-whofrom))) - (if whofrom - (insert sc-reference-tag-string - (sc-hdr "Regarding " (sc-mail-field "subject") "; ") - whofrom " adds:\n")))) - -(defun sc-header-attributed-writes () - "\"<sc-attribution>\" == <sc-author> <address> writes: -Treats these fields in a similar manner to `sc-header-on-said'." - (let ((sc-mumble "") - (whofrom (sc-whofrom))) - (if whofrom - (insert sc-reference-tag-string - (sc-hdr "\"" (sc-mail-field "sc-attribution") "\" == ") - (sc-hdr "" (sc-mail-field "sc-author") " ") - (or (sc-hdr "<" (sc-mail-field "sc-from-address") ">" t) - (sc-hdr "<" (sc-mail-field "sc-reply-address") ">" t) - "") - " writes:\n")))) - -(defun sc-header-author-writes () - "<sc-author> writes:" - (let ((sc-mumble "") - (whofrom (sc-whofrom))) - (if whofrom - (insert sc-reference-tag-string - (sc-hdr "" (sc-mail-field "sc-author")) - " writes:\n")))) - -(defun sc-header-verbose () - "Very verbose, some say gross." - (let ((sc-mumble "") - (whofrom (sc-whofrom)) - (tag sc-reference-tag-string)) - (if whofrom - (insert (sc-hdr (concat tag "On ") (sc-mail-field "date") ",\n") - (or (sc-hdr tag (sc-mail-field "sc-author") "\n" t) - (concat tag whofrom "\n")) - (sc-hdr (concat tag "from the organization of ") - (sc-mail-field "organization") "\n") - (let ((rtag (concat tag "who can be reached at: "))) - (or (sc-hdr rtag (sc-mail-field "sc-from-address") "\n" t) - (sc-hdr rtag (sc-mail-field "sc-reply-address") "\n" t) - "")) - (sc-hdr - (concat tag "(whose comments are cited below with \"") - (sc-mail-field "sc-citation") "\"),\n") - (sc-hdr (concat tag "had this to say in article ") - (sc-mail-field "message-id") "\n") - (sc-hdr (concat tag "in newsgroups ") - (sc-mail-field "newsgroups") "\n") - (sc-hdr (concat tag "concerning the subject of ") - (sc-mail-field "subject") "\n") - (sc-hdr (concat tag "(see ") - (sc-mail-field "references") - " for more details)\n") - )))) - - -;; ====================================================================== -;; header rewrites - -(defconst sc-electric-bufname " *sc-erefs* " - "Supercite electric reference mode's buffer name.") -(defvar sc-eref-style 0 - "Current electric reference style.") - -(defun sc-valid-index-p (index) - "Returns INDEX if it is a valid index into `sc-rewrite-header-list'. -Otherwise returns nil." - ;; a number, and greater than or equal to zero - ;; less than or equal to the last index - (and (natnump index) - (< index (length sc-rewrite-header-list)) - index)) - -(defun sc-eref-insert-selected (&optional nomsg) - "Insert the selected reference header in the current buffer. -Optional NOMSG, if non-nil, inhibits printing messages, unless an -error occurs." - (let ((ref (nth sc-eref-style sc-rewrite-header-list))) - (condition-case err - (progn - (eval ref) - (let ((lines (count-lines (point-min) (point-max)))) - (or nomsg (message "Ref header %d [%d line%s]: %s" - sc-eref-style lines - (if (= lines 1) "" "s") - ref)))) - (void-function - (progn (message - "Symbol's function definition is void: %s (Header %d)" - (car (cdr err)) sc-eref-style) - (beep) - )) - ))) - -(defun sc-electric-mode (&optional arg) - " -Mode for viewing Supercite reference headers. Commands are: -\n\\{sc-electric-mode-map} - -`sc-electric-mode' is not intended to be run interactively, but rather -accessed through Supercite's electric reference feature. See -`sc-insert-reference' for more details. Optional ARG is the initial -header style to use, unless not supplied or invalid, in which case -`sc-preferred-header-style' is used." - - (let ((info sc-mail-info)) - - (setq sc-eref-style - (or (sc-valid-index-p arg) - (sc-valid-index-p sc-preferred-header-style) - 0)) - - (get-buffer-create sc-electric-bufname) - ;; set up buffer and enter command loop - (save-excursion - (save-window-excursion - (pop-to-buffer sc-electric-bufname) - (kill-all-local-variables) - (let ((sc-mail-info info) - (buffer-read-only t) - (mode-name "SC Electric Refs") - (major-mode 'sc-electric-mode)) - (use-local-map sc-electric-mode-map) - (sc-eref-show sc-eref-style) - (run-hooks 'sc-electric-mode-hook) - (recursive-edit) - ))) - - (and sc-eref-style - (sc-eref-insert-selected)) - (kill-buffer sc-electric-bufname) - )) - -;; functions for electric reference mode -(defun sc-eref-show (index) - "Show reference INDEX in `sc-rewrite-header-list'." - (let ((msg "No %ing reference headers in list.") - (last (length sc-rewrite-header-list))) - (setq sc-eref-style - (cond - ((sc-valid-index-p index) index) - ((< index 0) - (if sc-electric-circular-p - (1- last) - (progn (error msg "preced") 0))) - ((>= index last) - (if sc-electric-circular-p - 0 - (progn (error msg "follow") (1- last)))) - )) - (save-excursion - (set-buffer sc-electric-bufname) - (let ((buffer-read-only nil)) - (erase-buffer) - (goto-char (point-min)) - (sc-eref-insert-selected) - ;; now shrink the window to just contain the electric reference - ;; header. - (let ((hdrlines (count-lines (point-min) (point-max))) - (winlines (1- (window-height)))) - (if (/= hdrlines winlines) - (if (> hdrlines winlines) - ;; we have to enlarge the window - (enlarge-window (- hdrlines winlines)) - ;; we have to shrink the window - (shrink-window (- winlines (max hdrlines window-min-height))) - ))) - )))) - -(defun sc-eref-next () - "Display next reference in other buffer." - (interactive) - (sc-eref-show (1+ sc-eref-style))) - -(defun sc-eref-prev () - "Display previous reference in other buffer." - (interactive) - (sc-eref-show (1- sc-eref-style))) - -(defun sc-eref-setn () - "Set reference header selected as preferred." - (interactive) - (setq sc-preferred-header-style sc-eref-style) - (message "Preferred reference style set to header %d." sc-eref-style)) - -(defun sc-eref-goto (refnum) - "Show reference style indexed by REFNUM. -If REFNUM is an invalid index, don't go to that reference and return -nil." - (interactive "NGoto Reference: ") - (if (sc-valid-index-p refnum) - (sc-eref-show refnum) - (error "Invalid reference: %d. (Range: [%d .. %d])" - refnum 0 (1- (length sc-rewrite-header-list))) - )) - -(defun sc-eref-jump () - "Set reference header to preferred header." - (interactive) - (sc-eref-show sc-preferred-header-style)) - -(defun sc-eref-abort () - "Exit from electric reference mode without inserting reference." - (interactive) - (setq sc-eref-style nil) - (exit-recursive-edit)) - -(defun sc-eref-exit () - "Exit from electric reference mode and insert selected reference." - (interactive) - (exit-recursive-edit)) - -(defun sc-insert-reference (arg) - "Insert, at point, a reference header in the body of the reply. -Numeric ARG indicates which header style from `sc-rewrite-header-list' -to use when rewriting the header. No supplied ARG indicates use of -`sc-preferred-header-style'. - -With just `\\[universal-argument]', electric reference insert mode is -entered, regardless of the value of `sc-electric-references-p'. See -`sc-electric-mode' for more information." - (interactive "P") - (if (consp arg) - (sc-electric-mode) - (let ((preference (or (sc-valid-index-p arg) - (sc-valid-index-p sc-preferred-header-style) - sc-preferred-header-style - 0))) - (if sc-electric-references-p - (sc-electric-mode preference) - (sc-eref-insert-selected t) - )))) - - -;; ====================================================================== -;; variable toggling - -(defun sc-raw-mode-toggle () - "Toggle, in one fell swoop, two important SC variables: -`sc-fixup-whitespace-p' and `sc-auto-fill-region-p'" - (interactive) - (setq sc-fixup-whitespace-p (not sc-fixup-whitespace-p) - sc-auto-fill-region-p (not sc-auto-fill-region-p)) - (sc-set-mode-string) - (force-mode-line-update)) - -(defun sc-toggle-var (variable) - "Boolean toggle VARIABLE's value. -VARIABLE must be a bound symbol. Nil values change to t, non-nil -values are changed to nil." - (message "%s changed from %s to %s" - variable (symbol-value variable) - (set-variable variable (not (eval-expression variable)))) - (sc-set-mode-string)) - -(defun sc-set-variable (var) - "Set the Supercite VARIABLE. -This function mimics `set-variable', except that the variable to set -is determined non-interactively. The value is queried for in the -minibuffer exactly the same way that `set-variable' does it. - -You can see the current value of the variable when the minibuffer is -querying you by typing `C-h'. Note that the format is changed -slightly from that used by `set-variable' -- the current value is -printed just after the variable's name instead of at the bottom of the -help window." - (let* ((minibuffer-help-form - '(funcall myhelp)) - (myhelp - (function - (lambda () - (with-output-to-temp-buffer "*Help*" - (prin1 var) - (if (boundp var) - (let ((print-length 20)) - (princ "\t(Current value: ") - (prin1 (symbol-value var)) - (princ ")"))) - (princ "\n\nDocumentation:\n") - (princ (substring (documentation-property - var - 'variable-documentation) - 1)) - (save-excursion - (set-buffer standard-output) - (help-mode)) - nil))))) - (set var (eval-minibuffer (format "Set %s to value: " var)))) - (sc-set-mode-string)) - -(defmacro sc-toggle-symbol (rootname) - (list 'defun (intern (concat "sc-T-" rootname)) '() - (list 'interactive) - (list 'sc-toggle-var - (list 'quote (intern (concat "sc-" rootname "-p")))))) - -(defmacro sc-setvar-symbol (rootname) - (list 'defun (intern (concat "sc-S-" rootname)) '() - (list 'interactive) - (list 'sc-set-variable - (list 'quote (intern (concat "sc-" rootname)))))) - -(sc-toggle-symbol "confirm-always") -(sc-toggle-symbol "downcase") -(sc-toggle-symbol "electric-references") -(sc-toggle-symbol "auto-fill-region") -(sc-toggle-symbol "mail-nuke-blank-lines") -(sc-toggle-symbol "nested-citation") -(sc-toggle-symbol "electric-circular") -(sc-toggle-symbol "use-only-preferences") -(sc-toggle-symbol "fixup-whitespace") - -(sc-setvar-symbol "preferred-attribution-list") -(sc-setvar-symbol "preferred-header-style") -(sc-setvar-symbol "mail-nuke-mail-headers") -(sc-setvar-symbol "mail-header-nuke-list") -(sc-setvar-symbol "cite-region-limit") - -(defun sc-T-describe () - " - -Supercite provides a number of key bindings which simplify the process -of setting or toggling certain variables controlling its operation. - -Note on function names in this list: all functions of the form -`sc-S-<name>' actually call `sc-set-variable' on the corresponding -`sc-<name>' variable. All functions of the form `sc-T-<name>' call -`sc-toggle-var' on the corresponding `sc-<name>-p' variable. - -\\{sc-T-keymap}" - (interactive) - (describe-function 'sc-T-describe)) - -(defun sc-set-mode-string () - "Update the minor mode string to show state of Supercite." - (setq sc-mode-string - (concat " SC" - (if (or sc-auto-fill-region-p - sc-fixup-whitespace-p) - ":" "") - (if sc-auto-fill-region-p "f" "") - (if sc-fixup-whitespace-p "w" "") - ))) - - -;; ====================================================================== -;; published interface to mail and news readers - -;;;###autoload -(defun sc-cite-original () - "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." - (run-hooks 'sc-pre-hook) - - ;; before we do anything, we want to insert the supercite keymap so - ;; we can proceed from here - (and sc-mode-map-prefix - (local-set-key sc-mode-map-prefix sc-mode-map)) - - ;; hack onto the minor mode alist, if it hasn't been done before, - ;; then turn on the minor mode. also, set the minor mode string with - ;; the values of fill and fixup whitespace variables - (if (not (get 'minor-mode-alist 'sc-minor-mode)) - (progn - (put 'minor-mode-alist 'sc-minor-mode 'sc-minor-mode) - (setq minor-mode-alist - (cons '(sc-minor-mode sc-mode-string) minor-mode-alist)) - )) - (setq sc-minor-mode t) - (sc-set-mode-string) - - (undo-boundary) - - ;; grab point and mark since the region is probably not active when - ;; this function gets automatically called. we want point to be a - ;; mark so any deleting before point works properly - (let* ((zmacs-regions nil) ; for Lemacs - (mark-active t) ; for FSFmacs - (point (point-marker)) - (mark (copy-marker (mark-marker)))) - - ;; make sure point comes before mark, not all functions are - ;; interactive "r" - (if (< mark point) - (let ((tmp point)) - (setq point mark - mark tmp))) - - ;; first process mail headers, and populate sc-mail-info - (sc-mail-process-headers point mark) - - ;; now get possible attributions - (sc-attribs-chop-address (or (sc-mail-field "from") - (sc-mail-field "reply") - (sc-mail-field "reply-to") - (sc-mail-field "sender"))) - ;; select the attribution - (sc-select-attribution) - - ;; cite the region, but first check the value of sc-cite-region-limit - (let ((linecnt (count-lines point mark))) - (and sc-cite-region-limit - (if (or (not (numberp sc-cite-region-limit)) - (<= linecnt sc-cite-region-limit)) - (progn - ;; cite the region and insert the header rewrite - (sc-cite-region point mark) - (goto-char point) - (let ((sc-eref-style (or sc-preferred-header-style 0))) - (if sc-electric-references-p - (sc-electric-mode sc-eref-style) - (sc-eref-insert-selected t)))) - (beep) - (message - "Region not cited. %d lines exceeds sc-cite-region-limit: %d" - linecnt sc-cite-region-limit)))) - - ;; finally, free the point-marker - (set-marker point nil) - (set-marker mark nil) - ) - (run-hooks 'sc-post-hook) - ;; post hook could have changed the variables - (sc-set-mode-string)) - - -;; ====================================================================== -;; bug reporting and miscellaneous commands - -(defun sc-open-line (arg) - "Like `open-line', but insert the citation prefix at the front of the line. -With numeric ARG, inserts that many new lines." - (interactive "p") - (save-excursion - (let ((start (point)) - (prefix (or (progn (beginning-of-line) - (if (looking-at (sc-cite-regexp)) - (sc-submatch 0))) - ""))) - (goto-char start) - (open-line arg) - (forward-line 1) - (while (< 0 arg) - (insert prefix) - (forward-line 1) - (setq arg (1- arg)) - )))) - -(defun sc-insert-citation (arg) - "Insert citation string at beginning of current line if not already cited. -With `\\[universal-argument]' insert citation even if line is already -cited." - (interactive "P") - (save-excursion - (beginning-of-line) - (if (or (not (looking-at (sc-cite-regexp))) - (looking-at "^[ \t]*$") - (consp arg)) - (insert (sc-mail-field "sc-citation")) - (error "Line is already cited.")))) - -(defun sc-version (arg) - "Echo the current version of Supercite in the minibuffer. -With \\[universal-argument] (universal-argument), or if run non-interactively, -inserts the version string in the current buffer instead." - (interactive "P") - (let ((verstr (format "Using Supercite.el %s" sc-version))) - (if (or (consp arg) - (not (interactive-p))) - (insert "`sc-version' says: " verstr) - (message verstr)))) - -(defun sc-describe () - " -Supercite is a package which provides a flexible mechanism for citing -email and news replies. Please see the associated texinfo file for -more information." - (interactive) - (describe-function 'sc-describe)) - -(defun sc-submit-bug-report () - "Submit a bug report on Supercite via mail." - (interactive) - (require 'reporter) - (and - (y-or-n-p "Do you want to submit a report on Supercite? ") - (reporter-submit-bug-report - sc-help-address - (concat "Supercite version " sc-version) - (list - 'sc-attrib-selection-list - 'sc-auto-fill-region-p - 'sc-blank-lines-after-headers - 'sc-citation-leader - 'sc-citation-delimiter - 'sc-citation-separator - 'sc-citation-leader-regexp - 'sc-citation-root-regexp - 'sc-citation-nonnested-root-regexp - 'sc-citation-delimiter-regexp - 'sc-citation-separator-regexp - 'sc-cite-region-limit - 'sc-confirm-always-p - 'sc-default-attribution - 'sc-default-author-name - 'sc-downcase-p - 'sc-electric-circular-p - 'sc-electric-references-p - 'sc-fixup-whitespace-p - 'sc-mail-warn-if-non-rfc822-p - 'sc-mumble - 'sc-name-filter-alist - 'sc-nested-citation-p - 'sc-nuke-mail-headers - 'sc-nuke-mail-header-list - 'sc-preferred-attribution-list - 'sc-preferred-header-style - 'sc-reference-tag-string - 'sc-rewrite-header-list - 'sc-titlecue-regexp - 'sc-use-only-preference-p - )))) - - -;; useful stuff -(provide 'supercite) -(run-hooks 'sc-load-hook) - -;;; supercite.el ends here diff --git a/lisp/mail/undigest.el b/lisp/mail/undigest.el deleted file mode 100644 index 3a3319ec1b5..00000000000 --- a/lisp/mail/undigest.el +++ /dev/null @@ -1,184 +0,0 @@ -;;; undigest.el --- digest-cracking support for the RMAIL mail reader - -;; Copyright (C) 1985, 1986, 1994, 1996 Free Software Foundation, Inc. - -;; Maintainer: FSF -;; 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: - -;; See Internet RFC 934 - -;;; Code: - -(require 'rmail) - -;;;###autoload -(defun undigestify-rmail-message () - "Break up a digest message into its constituent messages. -Leaves original message, deleted, before the undigestified messages." - (interactive) - (widen) - (let ((buffer-read-only nil) - (msg-string (buffer-substring (rmail-msgbeg rmail-current-message) - (rmail-msgend rmail-current-message)))) - (goto-char (rmail-msgend rmail-current-message)) - (narrow-to-region (point) (point)) - (insert msg-string) - (narrow-to-region (point-min) (1- (point-max)))) - (let ((error t) - (buffer-read-only nil)) - (unwind-protect - (progn - (save-restriction - (goto-char (point-min)) - (delete-region (point-min) - (progn (search-forward "\n*** EOOH ***\n") - (point))) - (insert "\^_\^L\n0, unseen,,\n*** EOOH ***\n") - (narrow-to-region (point) - (point-max)) - (let* ((fill-prefix "") - (case-fold-search t) - start - (digest-name - (mail-strip-quoted-names - (or (save-restriction - (search-forward "\n\n") - (setq start (point)) - (narrow-to-region (point-min) (point)) - (goto-char (point-max)) - (or (mail-fetch-field "Reply-To") - (mail-fetch-field "To") - (mail-fetch-field "Apparently-To") - (mail-fetch-field "From"))) - (error "Message is not a digest--bad header"))))) - (save-excursion - (goto-char (point-max)) - (skip-chars-backward " \t\n") - (let (found) - ;; compensate for broken un*x digestifiers. Sigh Sigh. - (while (and (> (point) start) (not found)) - (forward-line -1) - (if (looking-at (concat "End of.*Digest.*\n" - (regexp-quote "*********") "*" - "\\(\n------*\\)*")) - (setq found t))) - (if (not found) - (error "Message is not a digest--no end line")))) - (re-search-forward (concat "^" (make-string 55 ?-) "-*\n*")) - (replace-match "\^_\^L\n0, unseen,,\n*** EOOH ***\n") - (save-restriction - (narrow-to-region (point) - (progn (search-forward "\n\n") - (point))) - (if (mail-fetch-field "To") nil - (goto-char (point-min)) - (insert "To: " digest-name "\n"))) - (while (re-search-forward - (concat "\n\n" (make-string 27 ?-) "-*\n*") - nil t) - (replace-match "\n\n\^_\^L\n0, unseen,,\n*** EOOH ***\n") - (save-restriction - (if (looking-at "End ") - (insert "To: " digest-name "\n\n") - (narrow-to-region (point) - (progn (search-forward "\n\n" - nil 'move) - (point)))) - (if (mail-fetch-field "To") - nil - (goto-char (point-min)) - (insert "To: " digest-name "\n"))) - ;; Digestifiers may insert `- ' on lines that start with `-'. - ;; Undo that. - (save-excursion - (goto-char (point-min)) - (if (re-search-forward - "\n\n----------------------------*\n*" - nil t) - (let ((end (point-marker))) - (goto-char (point-min)) - (while (re-search-forward "^- " end t) - (delete-char -2))))) - ))) - (setq error nil) - (message "Message successfully undigestified") - (let ((n rmail-current-message)) - (rmail-forget-messages) - (rmail-show-message n) - (rmail-delete-forward) - (if (rmail-summary-exists) - (rmail-select-summary - (rmail-update-summary))))) - (cond (error - (narrow-to-region (point-min) (1+ (point-max))) - (delete-region (point-min) (point-max)) - (rmail-show-message rmail-current-message)))))) - -;;;###autoload -(defun unforward-rmail-message () - "Extract a forwarded message from the containing message. -This puts the forwarded message into a separate rmail message -following the containing message." - (interactive) - ;; Don't use save-excursion because we don't want to restore point - ;; in the case where we do not switch buffers. - (let ((obuf (current-buffer))) - (unwind-protect - (progn - ;; If we are in a summary buffer, switch to the Rmail buffer. - (if (local-variable-p 'rmail-buffer) - (set-buffer rmail-buffer)) - (narrow-to-region (rmail-msgbeg rmail-current-message) - (rmail-msgend rmail-current-message)) - (goto-char (point-min)) - (let (beg end (buffer-read-only nil) msg-string who-forwarded-it) - (setq who-forwarded-it (mail-fetch-field "From")) - (if (re-search-forward "^----" nil t) - nil - (error "No forwarded message")) - (forward-line 1) - (setq beg (point)) - (if (re-search-forward "^----" nil t) - (setq end (match-beginning 0)) - (error "No terminator for forwarded message")) - (widen) - (setq msg-string (buffer-substring beg end)) - (goto-char (rmail-msgend rmail-current-message)) - (narrow-to-region (point) (point)) - (insert "\^_\^L\n0, unseen,,\n*** EOOH ***\n") - (narrow-to-region (point) (point)) - (insert "Forwarded-by: " who-forwarded-it "\n") - (insert msg-string) - (goto-char (point-min)) - (while (not (eobp)) - (if (looking-at "- ") - (delete-region (point) (+ 2 (point)))) - (forward-line 1)) - (let ((n rmail-current-message)) - (rmail-forget-messages) - (rmail-show-message n) - (if (rmail-summary-exists) - (rmail-select-summary - (rmail-update-summary)))))) - (set-buffer obuf)))) - -;;; undigest.el ends here diff --git a/lisp/mail/unrmail.el b/lisp/mail/unrmail.el deleted file mode 100644 index 05fe04899af..00000000000 --- a/lisp/mail/unrmail.el +++ /dev/null @@ -1,66 +0,0 @@ -;;; unrmail.el --- convert Rmail files to mailbox files. - -;;; Copyright (C) 1992 Free Software Foundation, Inc. - -;; 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. - -;;; Code: - -(defvar command-line-args-left) ;Avoid 'free variable' warning - -;;;###autoload -(defun batch-unrmail () - "Convert Rmail files to system inbox format. -Specify the input Rmail file names as command line arguments. -For each Rmail file, the corresponding output file name -is made by adding `.mail' at the end. -For example, invoke `emacs -batch -f batch-unrmail RMAIL'." - ;; command-line-args-left is what is left of the command line (from startup.el) - (if (not noninteractive) - (error "`batch-unrmail' is to be used only with -batch")) - (let ((error nil)) - (while command-line-args-left - (or (unrmail (car command-line-args-left) - (concat (car command-line-args-left) ".mail")) - (setq error t)) - (setq command-line-args-left (cdr command-line-args-left))) - (message "Done") - (kill-emacs (if error 1 0)))) - -;;;###autoload -(defun unrmail (file to-file) - "Convert Rmail file FILE to system inbox format file TO-FILE." - (interactive "fUnrmail (rmail file): \nFUnrmail into (new mailbox file): ") - (let ((message-count 0) - ;; Prevent rmail from making, or switching to, a summary buffer. - (rmail-display-summary nil) - (rmail-delete-after-output nil)) - (rmail file) - ;; Default the directory of TO-FILE based on where FILE is. - (setq to-file (expand-file-name to-file default-directory)) - (message "Writing messages to %s..." to-file) - (while (< message-count rmail-total-messages) - (rmail-show-message - (setq message-count (1+ message-count))) - (rmail-toggle-header) - (rmail-output to-file 1 t)) - (message "Writing messages to %s...done" to-file))) - -;;; unrmail.el ends here diff --git a/lisp/mail/vms-pmail.el b/lisp/mail/vms-pmail.el deleted file mode 100644 index 3dd2d664e76..00000000000 --- a/lisp/mail/vms-pmail.el +++ /dev/null @@ -1,117 +0,0 @@ -;;; vms-pmail.el --- use Emacs as the editor within VMS mail. - -;; Copyright (C) 1992 Free Software Foundation, Inc. - -;; Author: Roland B Roberts <roberts@nsrl31.nsrl.rochester.edu> -;; Keywords: vms - -;; 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. - -;;; Code: - -;;; -;;; Quick hack to use emacs as mail editor. There are a *bunch* of -;;; changes scattered throughout emacs to make this work, namely: -;;; (1) mod to sysdep.c to allow emacs to attach to a process other -;;; than the one that originally spawned it. -;;; (2) mod to kepteditor.com to define the logical emacs_parent_pid -;;; which is what sysdep.c looks for, and define the logical -;;; emacs_command_args which contains the command line -;;; (3) mod to re-parse command line arguments from emacs_command_args -;;; then execute them as though emacs were just starting up. -;;; -(defun vms-pmail-save-and-exit () - "Save current buffer and exit emacs. -If this emacs cannot be suspended, you will be prompted about modified -buffers other than the mail buffer. BEWARE --- suspending emacs without -saving your mail buffer causes mail to abort the send (potentially useful -since the mail buffer is still here)." - (interactive) - (basic-save-buffer) - (if (vms-system-info "LOGICAL" "DONT_SUSPEND_EMACS") - (progn - (save-some-buffers) - (kill-emacs 1)) - (kill-buffer (current-buffer)) - (suspend-emacs))) - -(defun vms-pmail-abort () - "Mark buffer as unmodified and exit emacs. -When the editor is exited without saving its buffer, VMS mail does not -send a message. If you have other modified buffers you will be -prompted for what to do with them." - (interactive) - (if (not (yes-or-no-p "Really abort mail? ")) - (ding) - (not-modified) - (if (vms-system-info "LOGICAL" "DONT_SUSPEND_EMACS") - (progn - (save-some-buffers) - (kill-emacs 1)) - (kill-buffer (current-buffer)) - (suspend-emacs)))) - -(defun vms-pmail-setup () - "Set up file assuming use by VMS MAIL utility. -The buffer is put into text-mode, auto-save is turned off and the -following bindings are established. - -\\[vms-pmail-save-and-exit] vms-pmail-save-and-exit -\\[vms-pmail-abort] vms-pmail-abort - -All other emacs commands are still available." - (interactive) - (auto-save-mode -1) - (text-mode) - (let ((default (vms-system-info "LOGICAL" "SYS$SCRATCH")) - (directory (file-name-directory (buffer-file-name))) - (filename (file-name-nondirectory (buffer-file-name)))) - (if (string= directory "SYS$SCRATCH:") - (progn - (cd default) - (setq buffer-file-name (concat default filename)))) - (use-local-map (copy-keymap (current-local-map))) - (local-set-key "\C-c\C-c" 'vms-pmail-save-and-exit) - (local-set-key "\C-c\C-g" 'vms-pmail-abort))) - -(defun indicate-mail-reply-text () - "Prepares received mail for re-sending by placing >'s on each line." - (interactive) - (goto-char (point-min)) - (while (not (eobp)) - (insert ">") - (beginning-of-line) - (forward-line 1)) - (set-buffer-modified-p nil) - (goto-char (point-min))) - -(defun insert-signature () - "Moves to the end of the buffer and inserts a \"signature\" file. -First try the file indicated by environment variable MAIL$TRAILER. -If that fails, try the file \"~/.signature\". -If neither file exists, fails quietly." - (interactive) - (end-of-buffer) - (newline) - (if (vms-system-info "LOGICAL" "MAIL$TRAILER") - (if (file-attributes (vms-system-info "LOGICAL" "MAIL$TRAILER")) - (insert-file-contents (vms-system-info "LOGICAL" "MAIL$TRAILER")) - (if (file-attributes "~/.signature") - (insert-file-contents "~/.signature"))))) - -;;; vms-pmail.el ends here |