;;; mail-utils.el --- utility functions used both by rmail and rnews
-;; Copyright (C) 1985, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 2001-2012 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: mail, news
;;; Code:
-;;; We require lisp-mode to make sure that lisp-mode-syntax-table has
-;;; been initialized.
-(require 'lisp-mode)
-
;;;###autoload
-(defcustom mail-use-rfc822 nil "\
-*If non-nil, use a full, hairy RFC822 parser on mail addresses.
+(defcustom 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."
: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)
- (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))))
+ "Return non-nil if FILE is a Babyl file."
+ (with-temp-buffer
+ (insert-file-contents file nil 0 100)
+ (looking-at "BABYL OPTIONS:")))
(defun mail-string-delete (string start end)
"Returns a string containing all of STRING except the part
"?=")
(concat result (substring string i))))))
+;;;###autoload
+(defun mail-quote-printable-region (beg end &optional wrapper)
+ "Convert the region to the \"quoted printable\" Q encoding.
+If the optional argument WRAPPER is non-nil,
+we add the wrapper characters =?ISO-8859-1?Q?....?=."
+ (interactive "r\nP")
+ (save-match-data
+ (save-excursion
+ (goto-char beg)
+ (save-restriction
+ (narrow-to-region beg end)
+ (while (re-search-forward "[?=\"\200-\377]" nil t)
+ (replace-match (upcase (format "=%02x" (preceding-char)))
+ t t))
+ (when wrapper
+ (goto-char beg)
+ (insert "=?ISO-8859-1?Q?")
+ (goto-char end)
+ (insert "?="))))))
+
(defun mail-unquote-printable-hexdigit (char)
(setq char (upcase char))
(if (>= char ?A)
(setq i (match-end 0)))
(apply 'concat (nreverse (cons (substring string i) strings))))))
+;; FIXME Gnus for some reason has `quoted-printable-decode-region' in qp.el.
;;;###autoload
(defun mail-unquote-printable-region (beg end &optional wrapper noerror
unibyte)
"Undo the \"quoted printable\" encoding in buffer from BEG to END.
If the optional argument WRAPPER is non-nil,
we expect to find and remove the wrapper characters =?ISO-8859-1?Q?....?=.
-If NOERROR is non-nil, return t if successful.
+On encountering malformed quoted-printable text, exits with an error,
+unless NOERROR is non-nil, in which case it continues, and returns nil
+when finished. Returns non-nil on successful completion.
If UNIBYTE is non-nil, insert converted characters as unibyte.
That is useful if you are going to character code decoding afterward,
as Rmail does."
+ ;; FIXME: `unibyte' should always be non-nil, and the iso-latin-1
+ ;; specific handling should be removed (or moved elsewhere and generalized).
(interactive "r\nP")
(let (failed)
(save-match-data
(if unibyte
(progn
(replace-match "")
- ;; insert-char will insert this as unibyte,
- (insert-char char 1))
+ ;; insert-byte will insert this as a
+ ;; corresponding eight-bit character.
+ (insert-byte char 1))
(replace-match (make-string 1 char) t t))))
(noerror
(setq failed t))
(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" <bar@host>')
- (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" <bar@host>')
+ (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."
- (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) "@"))))
+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 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))
(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))))
(substring destinations (match-end 0))
destinations))
+;; Legacy name
+(define-obsolete-function-alias 'rmail-dont-reply-to 'mail-dont-reply-to "24.1")
+
\f
;;;###autoload
(defun mail-fetch-field (field-name &optional last all list)
"Return the value of the header field whose type is FIELD-NAME.
-The buffer is expected to be narrowed to just the header of the message.
If second arg LAST is non-nil, use the last field of type FIELD-NAME.
If third arg ALL is non-nil, concatenate all such fields with commas between.
-If 4th arg LIST is non-nil, return a list of all such fields."
+If 4th arg LIST is non-nil, return a list of all such fields.
+The buffer should be narrowed to just the header, else false
+matches may be returned from the message body."
(save-excursion
(goto-char (point-min))
(let ((case-fold-search t)
(substring s (match-beginning 3) (match-end 3)) " "
(mail-rfc822-time-zone time))))
+(defun mail-mbox-from ()
+ "Return an mbox \"From \" line for the current message.
+The buffer should be narrowed to just the header."
+ (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))))
+ (current-time-string)))))
+
(provide 'mail-utils)
-;; arch-tag: b24aec2f-fd65-4ceb-9e39-3cc2827036fd
;;; mail-utils.el ends here
HCoop / bpt / emacs.git / blobdiff