X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/0273f794adc2bfec888b506ee0328f3bc7eb0ad3..34dc21db6e57ebbad81a196002fcd3cc557f096e:/lisp/mail/mail-utils.el diff --git a/lisp/mail/mail-utils.el b/lisp/mail/mail-utils.el index a8d845146f..78696d6ca1 100644 --- a/lisp/mail/mail-utils.el +++ b/lisp/mail/mail-utils.el @@ -1,9 +1,8 @@ ;;; mail-utils.el --- utility functions used both by rmail and rnews -;; Copyright (C) 1985, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, -;; 2009, 2010 Free Software Foundation, Inc. +;; Copyright (C) 1985, 2001-2014 Free Software Foundation, Inc. -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Keywords: mail, news ;; This file is part of GNU Emacs. @@ -36,6 +35,17 @@ often correct parser." :type 'boolean :group 'mail) +;;;###autoload +(defcustom mail-dont-reply-to-names nil + "Regexp specifying addresses to prune from a reply message. +If this is nil, it is set the first time you compose a reply, to +a value which excludes your own email address. + +Matching addresses are excluded from the CC field in replies, and +also the To field, unless this would leave an empty To field." + :type '(choice regexp (const :tag "Your Name" nil)) + :group 'mail) + ;; Returns t if file FILE is an Rmail file. ;;;###autoload (defun mail-file-babyl-p (file) @@ -53,12 +63,16 @@ from START (inclusive) to END (exclusive)." ;;;###autoload (defun mail-quote-printable (string &optional wrapper) - "Convert a string to the \"quoted printable\" Q encoding. + "Convert a string to the \"quoted printable\" Q encoding if necessary. +If the string contains only ASCII characters and no troublesome ones, +we return it unconverted. + If the optional argument WRAPPER is non-nil, we add the wrapper characters =?ISO-8859-1?Q?....?=." (let ((i 0) (result "")) (save-match-data - (while (string-match "[?=\"\200-\377]" string i) + (while (or (string-match "[?=\"]" string i) + (string-match "[^\000-\177]" string i)) (setq result (concat result (substring string i (match-beginning 0)) (upcase (format "=%02x" @@ -169,102 +183,74 @@ as Rmail does." (error "Malformed MIME quoted-printable message")))) (not failed)))))) -(eval-when-compile (require 'rfc822)) +(autoload 'rfc822-addresses "rfc822") (defun mail-strip-quoted-names (address) "Delete comments and quoted strings in an address list ADDRESS. Also delete leading/trailing whitespace and replace FOO with just BAR. Return a modified address list." - (if (null address) - nil + (when address (if mail-use-rfc822 - (progn (require 'rfc822) - (mapconcat 'identity (rfc822-addresses address) ", ")) + (mapconcat 'identity (rfc822-addresses address) ", ") (let (pos) - ;; Detect nested comments. - (if (string-match "[ \t]*(\\([^)\\]\\|\\\\.\\|\\\\\n\\)*(" address) - ;; Strip nested comments. - (with-current-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 (replace-match "" nil nil address 0)))) - - ;; strip surrounding whitespace - (string-match "\\`[ \t\n]*" address) - (setq address (substring address - (match-end 0) - (string-match "[ \t\n]*\\'" address - (match-end 0)))) - - ;; strip `quoted' names (This is supposed to hack `"Foo Bar" ') - (setq pos 0) - (while (setq pos (string-match + ;; Strip comments. + (while (setq pos (string-match + "[ \t]*(\\([^()\\]\\|\\\\.\\|\\\\\n\\)*)" + address)) + (setq address (replace-match "" nil nil address 0))) + + ;; strip surrounding whitespace + (string-match "\\`[ \t\n]*" address) + (setq address (substring address + (match-end 0) + (string-match "[ \t\n]*\\'" address + (match-end 0)))) + + ;; strip `quoted' names (This is supposed to hack `"Foo Bar" ') + (setq pos 0) + (while (setq pos (string-match "\\([ \t]?\\)\\([ \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)) - ;; Otherwise discard the "..." part. - (setq address (replace-match "" nil nil address 2)))) - ;; If this address contains <...>, replace it with just - ;; the part between the <...>. - (while (setq pos (string-match "\\(,\\s-*\\|\\`\\)\\([^,]*<\\([^>,:]*\\)>[^,]*\\)\\(\\s-*,\\|\\'\\)" - address)) - (setq address (replace-match (match-string 3 address) - nil 'literal address 2))) - address)))) - -;;; The following piece of ugliness is legacy code. The name was an -;;; unfortunate choice --- a flagrant violation of the Emacs Lisp -;;; coding conventions. `mail-dont-reply-to' would have been -;;; infinitely better. Also, `rmail-dont-reply-to-names' might have -;;; been better named `mail-dont-reply-to-names' and sourced from this -;;; file instead of in rmail.el. Yuck. -pmr -(defun rmail-dont-reply-to (destinations) + ;; 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)) + ;; Otherwise discard the "..." part. + (setq address (replace-match "" nil nil address 2)))) + ;; If this address contains <...>, replace it with just + ;; the part between the <...>. + (while (setq pos (string-match "\\(,\\s-*\\|\\`\\)\\([^,]*<\\([^>,:]*\\)>[^,]*\\)\\(\\s-*,\\|\\'\\)" + address)) + (setq address (replace-match (match-string 3 address) + nil 'literal address 2))) + address)))) + +(defun mail-dont-reply-to (destinations) "Prune addresses from DESTINATIONS, a list of recipient addresses. -All addresses matching `rmail-dont-reply-to-names' are removed from -the comma-separated list. The pruned list is returned." +Remove all addresses matching `mail-dont-reply-to-names' from the +comma-separated list, and return the pruned list." ;; FIXME this (setting a user option the first time a command is used) ;; is somewhat strange. Normally one would never set the option, ;; but instead fall back to the default so long as it was nil. ;; Or just set the default directly in the defcustom. - (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 "\\|") - "") - (if (and user-mail-address - (not (equal user-mail-address user-login-name))) - ;; Anchor the login name and email address so - ;; that we don't match substrings: if the - ;; login name is "foo", we shouldn't match - ;; "barfoo@baz.com". - (concat "\\`" - (regexp-quote user-mail-address) - "\\'\\|") - "") - (concat "\\`" (regexp-quote user-login-name) "@")))) + (if (null mail-dont-reply-to-names) + (setq mail-dont-reply-to-names + (concat + ;; `rmail-default-dont-reply-to-names' is obsolete. + (if (bound-and-true-p rmail-default-dont-reply-to-names) + (concat rmail-default-dont-reply-to-names "\\|") + "") + (if (and user-mail-address + (not (equal user-mail-address user-login-name))) + ;; Anchor the login name and email address so that we + ;; don't match substrings: if the login name is + ;; "foo", we shouldn't match "barfoo@baz.com". + (concat "\\`" + (regexp-quote user-mail-address) + "\\'\\|") + "") + (concat "\\`" (regexp-quote user-login-name) "@")))) ;; Split up DESTINATIONS and match each element separately. (let ((start-pos 0) (cur-pos 0) (case-fold-search t)) @@ -284,7 +270,7 @@ the comma-separated list. The pruned list is returned." (setq cur-pos start-pos))) (let* ((address (substring destinations start-pos cur-pos)) (naked-address (mail-strip-quoted-names address))) - (if (string-match rmail-dont-reply-to-names naked-address) + (if (string-match mail-dont-reply-to-names naked-address) (setq destinations (concat (substring destinations 0 start-pos) (and cur-pos (substring destinations (1+ cur-pos)))) @@ -300,6 +286,9 @@ the comma-separated list. The pruned list is returned." (substring destinations (match-end 0)) destinations)) +;; Legacy name +(define-obsolete-function-alias 'rmail-dont-reply-to 'mail-dont-reply-to "24.1") + ;;;###autoload (defun mail-fetch-field (field-name &optional last all list) @@ -394,13 +383,19 @@ matches may be returned from the message body." (defun mail-mbox-from () "Return an mbox \"From \" line for the current message. The buffer should be narrowed to just the header." - (let ((from (or (mail-fetch-field "from") - (mail-fetch-field "really-from") - (mail-fetch-field "sender") - (mail-fetch-field "return-path") - "unknown")) - (date (mail-fetch-field "date"))) - (format "From %s %s\n" (mail-strip-quoted-names from) + (let* ((from (mail-strip-quoted-names (or (mail-fetch-field "from") + (mail-fetch-field "really-from") + (mail-fetch-field "sender") + (mail-fetch-field "return-path") + "unknown"))) + (date (mail-fetch-field "date")) + ;; A From: header can contain multiple addresses, a "From " + ;; line must contain only one. (Bug#7760) + ;; See eg RFC 5322, 3.6.2. Originator Fields. + (end (string-match "[ \t]*[,\n]" from))) + (format "From %s %s\n" (if end + (substring from 0 end) + from) (or (and date (ignore-errors (current-time-string (date-to-time date))))