lisp/mail/mail-utils.el

   1 ;;; mail-utils.el --- utility functions used both by rmail and rnews
   2
   3 ;; Copyright (C) 1985, 2001-2012  Free Software Foundation, Inc.
   4
   5 ;; Maintainer: FSF
   6 ;; Keywords: mail, news
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; Utility functions for mail and netnews handling.  These handle fine
  26 ;; points of header parsing.
  27
  28 ;;; Code:
  29
  30 ;;;###autoload
  31 (defcustom mail-use-rfc822 nil
  32   "If non-nil, use a full, hairy RFC822 parser on mail addresses.
  33 Otherwise, (the default) use a smaller, somewhat faster, and
  34 often correct parser."
  35   :type 'boolean
  36   :group 'mail)
  37
  38 ;;;###autoload
  39 (defcustom mail-dont-reply-to-names nil
  40   "Regexp specifying addresses to prune from a reply message.
  41 If this is nil, it is set the first time you compose a reply, to
  42 a value which excludes your own email address.
  43
  44 Matching addresses are excluded from the CC field in replies, and
  45 also the To field, unless this would leave an empty To field."
  46   :type '(choice regexp (const :tag "Your Name" nil))
  47   :group 'mail)
  48
  49 ;; Returns t if file FILE is an Rmail file.
  50 ;;;###autoload
  51 (defun mail-file-babyl-p (file)
  52   "Return non-nil if FILE is a Babyl file."
  53   (with-temp-buffer
  54     (insert-file-contents file nil 0 100)
  55     (looking-at "BABYL OPTIONS:")))
  56
  57 (defun mail-string-delete (string start end)
  58   "Returns a string containing all of STRING except the part
  59 from START (inclusive) to END (exclusive)."
  60   (if (null end) (substring string 0 start)
  61     (concat (substring string 0 start)
  62             (substring string end nil))))
  63
  64 ;;;###autoload
  65 (defun mail-quote-printable (string &optional wrapper)
  66   "Convert a string to the \"quoted printable\" Q encoding if necessary.
  67 If the string contains only ASCII characters and no troublesome ones,
  68 we return it unconverted.
  69
  70 If the optional argument WRAPPER is non-nil,
  71 we add the wrapper characters =?ISO-8859-1?Q?....?=."
  72   (let ((i 0) (result ""))
  73     (save-match-data
  74       (while (or (string-match "[?=\"]" string i)
  75                  (string-match "[^\000-\177]" string i))
  76         (setq result
  77               (concat result (substring string i (match-beginning 0))
  78                       (upcase (format "=%02x"
  79                                       (aref string (match-beginning 0))))))
  80         (setq i (match-end 0)))
  81       (if wrapper
  82           (concat "=?ISO-8859-1?Q?"
  83                   result (substring string i)
  84                   "?=")
  85         (concat result (substring string i))))))
  86
  87 ;;;###autoload
  88 (defun mail-quote-printable-region (beg end &optional wrapper)
  89   "Convert the region to the \"quoted printable\" Q encoding.
  90 If the optional argument WRAPPER is non-nil,
  91 we add the wrapper characters =?ISO-8859-1?Q?....?=."
  92   (interactive "r\nP")
  93   (save-match-data
  94     (save-excursion
  95       (goto-char beg)
  96       (save-restriction
  97         (narrow-to-region beg end)
  98         (while (re-search-forward "[?=\"\200-\377]" nil t)
  99           (replace-match (upcase (format "=%02x" (preceding-char)))
 100                          t t))
 101         (when wrapper
 102           (goto-char beg)
 103           (insert "=?ISO-8859-1?Q?")
 104           (goto-char end)
 105           (insert "?="))))))
 106
 107 (defun mail-unquote-printable-hexdigit (char)
 108   (setq char (upcase char))
 109   (if (>= char ?A)
 110       (+ (- char ?A) 10)
 111     (- char ?0)))
 112
 113 ;;;###autoload
 114 (defun mail-unquote-printable (string &optional wrapper)
 115   "Undo the \"quoted printable\" encoding.
 116 If the optional argument WRAPPER is non-nil,
 117 we expect to find and remove the wrapper characters =?ISO-8859-1?Q?....?=."
 118   (save-match-data
 119     (and wrapper
 120          (string-match "\\`=\\?ISO-8859-1\\?Q\\?\\([^?]*\\)\\?" string)
 121          (setq string (match-string 1 string)))
 122     (let ((i 0) strings)
 123       (while (string-match "=\\(..\\|\n\\)" string i)
 124         (setq strings (cons (substring string i (match-beginning 0)) strings))
 125         (unless (= (aref string (match-beginning 1)) ?\n)
 126           (setq strings
 127                 (cons (make-string 1
 128                                    (+ (* 16 (mail-unquote-printable-hexdigit
 129                                              (aref string (match-beginning 1))))
 130                                       (mail-unquote-printable-hexdigit
 131                                        (aref string (1+ (match-beginning 1))))))
 132                       strings)))
 133         (setq i (match-end 0)))
 134       (apply 'concat (nreverse (cons (substring string i) strings))))))
 135
 136 ;; FIXME Gnus for some reason has `quoted-printable-decode-region' in qp.el.
 137 ;;;###autoload
 138 (defun mail-unquote-printable-region (beg end &optional wrapper noerror
 139                                           unibyte)
 140   "Undo the \"quoted printable\" encoding in buffer from BEG to END.
 141 If the optional argument WRAPPER is non-nil,
 142 we expect to find and remove the wrapper characters =?ISO-8859-1?Q?....?=.
 143 On encountering malformed quoted-printable text, exits with an error,
 144 unless NOERROR is non-nil, in which case it continues, and returns nil
 145 when finished.  Returns non-nil on successful completion.
 146 If UNIBYTE is non-nil, insert converted characters as unibyte.
 147 That is useful if you are going to character code decoding afterward,
 148 as Rmail does."
 149   ;; FIXME: `unibyte' should always be non-nil, and the iso-latin-1
 150   ;; specific handling should be removed (or moved elsewhere and generalized).
 151   (interactive "r\nP")
 152   (let (failed)
 153     (save-match-data
 154       (save-excursion
 155         (save-restriction
 156           (narrow-to-region beg end)
 157           (goto-char (point-min))
 158           (when (and wrapper
 159                      (looking-at "\\`=\\?ISO-8859-1\\?Q\\?\\([^?]*\\)\\?"))
 160             (delete-region (match-end 1) end)
 161             (delete-region (point) (match-beginning 1)))
 162           (while (re-search-forward "=\\(\\([0-9A-F][0-9A-F]\\)\\|[=\n]\\|..\\)" nil t)
 163             (goto-char (match-end 0))
 164             (cond ((= (char-after (match-beginning 1)) ?\n)
 165                    (replace-match ""))
 166                   ((= (char-after (match-beginning 1)) ?=)
 167                    (replace-match "="))
 168                   ((match-beginning 2)
 169                    (let ((char (+ (* 16 (mail-unquote-printable-hexdigit
 170                                          (char-after (match-beginning 2))))
 171                                   (mail-unquote-printable-hexdigit
 172                                    (char-after (1+ (match-beginning 2)))))))
 173                      (if unibyte
 174                          (progn
 175                            (replace-match "")
 176                            ;; insert-byte will insert this as a
 177                            ;; corresponding eight-bit character.
 178                            (insert-byte char 1))
 179                        (replace-match (make-string 1 char) t t))))
 180                   (noerror
 181                    (setq failed t))
 182                   (t
 183                    (error "Malformed MIME quoted-printable message"))))
 184           (not failed))))))
 185
 186 (eval-when-compile (require 'rfc822))
 187
 188 (defun mail-strip-quoted-names (address)
 189   "Delete comments and quoted strings in an address list ADDRESS.
 190 Also delete leading/trailing whitespace and replace FOO <BAR> with just BAR.
 191 Return a modified address list."
 192   (if (null address)
 193       nil
 194     (if mail-use-rfc822
 195         (progn (require 'rfc822)
 196                (mapconcat 'identity (rfc822-addresses address) ", "))
 197       (let (pos)
 198
 199         ;; Strip comments.
 200         (while (setq pos (string-match
 201                           "[ \t]*(\\([^()\\]\\|\\\\.\\|\\\\\n\\)*)"
 202                           address))
 203           (setq address (replace-match "" nil nil address 0)))
 204
 205         ;; strip surrounding whitespace
 206         (string-match "\\`[ \t\n]*" address)
 207         (setq address (substring address
 208                                  (match-end 0)
 209                                  (string-match "[ \t\n]*\\'" address
 210                                                (match-end 0))))
 211
 212         ;; strip `quoted' names (This is supposed to hack `"Foo Bar" <bar@host>')
 213         (setq pos 0)
 214         (while (setq pos (string-match
 215                           "\\([ \t]?\\)\\([ \t]*\"\\([^\"\\]\\|\\\\.\\|\\\\\n\\)*\"[ \t\n]*\\)"
 216                           address pos))
 217           ;; If the next thing is "@", we have "foo bar"@host.  Leave it.
 218           (if (and (> (length address) (match-end 0))
 219                    (= (aref address (match-end 0)) ?@))
 220               (setq pos (match-end 0))
 221             ;; Otherwise discard the "..." part.
 222             (setq address (replace-match "" nil nil address 2))))
 223         ;; If this address contains <...>, replace it with just
 224         ;; the part between the <...>.
 225         (while (setq pos (string-match "\\(,\\s-*\\|\\`\\)\\([^,]*<\\([^>,:]*\\)>[^,]*\\)\\(\\s-*,\\|\\'\\)"
 226                                        address))
 227           (setq address (replace-match (match-string 3 address)
 228                                        nil 'literal address 2)))
 229         address))))
 230
 231 (defun mail-dont-reply-to (destinations)
 232   "Prune addresses from DESTINATIONS, a list of recipient addresses.
 233 Remove all addresses matching `mail-dont-reply-to-names' from the
 234 comma-separated list, and return the pruned list."
 235   ;; FIXME this (setting a user option the first time a command is used)
 236   ;; is somewhat strange.  Normally one would never set the option,
 237   ;; but instead fall back to the default so long as it was nil.
 238   ;; Or just set the default directly in the defcustom.
 239   (if (null mail-dont-reply-to-names)
 240       (setq mail-dont-reply-to-names
 241             (concat
 242              ;; `rmail-default-dont-reply-to-names' is obsolete.
 243              (if (bound-and-true-p rmail-default-dont-reply-to-names)
 244                  (concat rmail-default-dont-reply-to-names "\\|")
 245                "")
 246              (if (and user-mail-address
 247                       (not (equal user-mail-address user-login-name)))
 248                  ;; Anchor the login name and email address so that we
 249                  ;; don't match substrings: if the login name is
 250                  ;; "foo", we shouldn't match "barfoo@baz.com".
 251                  (concat "\\`"
 252                          (regexp-quote user-mail-address)
 253                          "\\'\\|")
 254                "")
 255              (concat "\\`" (regexp-quote user-login-name) "@"))))
 256   ;; Split up DESTINATIONS and match each element separately.
 257   (let ((start-pos 0) (cur-pos 0)
 258         (case-fold-search t))
 259     (while start-pos
 260       (setq cur-pos (string-match "[,\"]" destinations cur-pos))
 261       (if (and cur-pos (equal (match-string 0 destinations) "\""))
 262           ;; Search for matching quote.
 263           (let ((next-pos (string-match "\"" destinations (1+ cur-pos))))
 264             (if next-pos
 265                 (setq cur-pos (1+ next-pos))
 266               ;; If the open-quote has no close-quote,
 267               ;; delete the open-quote to get something well-defined.
 268               ;; This case is not valid, but it can happen if things
 269               ;; are weird elsewhere.
 270               (setq destinations (concat (substring destinations 0 cur-pos)
 271                                     (substring destinations (1+ cur-pos))))
 272               (setq cur-pos start-pos)))
 273         (let* ((address (substring destinations start-pos cur-pos))
 274                (naked-address (mail-strip-quoted-names address)))
 275           (if (string-match mail-dont-reply-to-names naked-address)
 276               (setq destinations (concat (substring destinations 0 start-pos)
 277                                     (and cur-pos (substring destinations
 278                                                             (1+ cur-pos))))
 279                     cur-pos start-pos)
 280             (setq cur-pos (and cur-pos (1+ cur-pos))
 281                   start-pos cur-pos))))))
 282   ;; get rid of any trailing commas
 283   (let ((pos (string-match "[ ,\t\n]*\\'" destinations)))
 284     (if pos
 285         (setq destinations (substring destinations 0 pos))))
 286   ;; remove leading spaces. they bother me.
 287   (if (string-match "\\(\\s \\|,\\)*" destinations)
 288       (substring destinations (match-end 0))
 289     destinations))
 290
 291 ;; Legacy name
 292 (define-obsolete-function-alias 'rmail-dont-reply-to 'mail-dont-reply-to "24.1")
 293
 294 \f
 295 ;;;###autoload
 296 (defun mail-fetch-field (field-name &optional last all list)
 297   "Return the value of the header field whose type is FIELD-NAME.
 298 If second arg LAST is non-nil, use the last field of type FIELD-NAME.
 299 If third arg ALL is non-nil, concatenate all such fields with commas between.
 300 If 4th arg LIST is non-nil, return a list of all such fields.
 301 The buffer should be narrowed to just the header, else false
 302 matches may be returned from the message body."
 303   (save-excursion
 304     (goto-char (point-min))
 305     (let ((case-fold-search t)
 306           (name (concat "^" (regexp-quote field-name) "[ \t]*:[ \t]*")))
 307       (if (or all list)
 308           (let ((value (if all "")))
 309             (while (re-search-forward name nil t)
 310               (let ((opoint (point)))
 311                 (while (progn (forward-line 1)
 312                               (looking-at "[ \t]")))
 313                 ;; Back up over newline, then trailing spaces or tabs
 314                 (forward-char -1)
 315                 (skip-chars-backward " \t" opoint)
 316                 (if list
 317                     (setq value (cons (buffer-substring-no-properties
 318                                        opoint (point))
 319                                       value))
 320                   (setq value (concat value
 321                                       (if (string= value "") "" ", ")
 322                                       (buffer-substring-no-properties
 323                                        opoint (point)))))))
 324             (if list
 325                 value
 326               (and (not (string= value "")) value)))
 327         (if (re-search-forward name nil t)
 328             (progn
 329               (if last (while (re-search-forward name nil t)))
 330               (let ((opoint (point)))
 331                 (while (progn (forward-line 1)
 332                               (looking-at "[ \t]")))
 333                 ;; Back up over newline, then trailing spaces or tabs
 334                 (forward-char -1)
 335                 (skip-chars-backward " \t" opoint)
 336                 (buffer-substring-no-properties opoint (point)))))))))
 337 \f
 338 ;; Parse a list of tokens separated by commas.
 339 ;; It runs from point to the end of the visible part of the buffer.
 340 ;; Whitespace before or after tokens is ignored,
 341 ;; but whitespace within tokens is kept.
 342 (defun mail-parse-comma-list ()
 343   (let (accumulated
 344         beg)
 345     (skip-chars-forward " \t\n")
 346     (while (not (eobp))
 347       (setq beg (point))
 348       (skip-chars-forward "^,")
 349       (skip-chars-backward " \t\n")
 350       (setq accumulated
 351             (cons (buffer-substring-no-properties beg (point))
 352                   accumulated))
 353       (skip-chars-forward "^,")
 354       (skip-chars-forward ", \t\n"))
 355     accumulated))
 356
 357 (defun mail-comma-list-regexp (labels)
 358   (let (pos)
 359     (setq pos (or (string-match "[^ \t]" labels) 0))
 360     ;; Remove leading and trailing whitespace.
 361     (setq labels (substring labels pos (string-match "[ \t]*$" labels pos)))
 362     ;; Change each comma to \|, and flush surrounding whitespace.
 363     (while (setq pos (string-match "[ \t]*,[ \t]*" labels))
 364       (setq labels
 365             (concat (substring labels 0 pos)
 366                     "\\|"
 367                     (substring labels (match-end 0))))))
 368   labels)
 369 \f
 370 (defun mail-rfc822-time-zone (time)
 371   (let* ((sec (or (car (current-time-zone time)) 0))
 372          (absmin (/ (abs sec) 60)))
 373     (format "%c%02d%02d" (if (< sec 0) ?- ?+) (/ absmin 60) (% absmin 60))))
 374
 375 (defun mail-rfc822-date ()
 376   (let* ((time (current-time))
 377          (s (current-time-string time)))
 378     (string-match "[^ ]+ +\\([^ ]+\\) +\\([^ ]+\\) \\([^ ]+\\) \\([^ ]+\\)" s)
 379     (concat (substring s (match-beginning 2) (match-end 2)) " "
 380             (substring s (match-beginning 1) (match-end 1)) " "
 381             (substring s (match-beginning 4) (match-end 4)) " "
 382             (substring s (match-beginning 3) (match-end 3)) " "
 383             (mail-rfc822-time-zone time))))
 384
 385 (defun mail-mbox-from ()
 386   "Return an mbox \"From \" line for the current message.
 387 The buffer should be narrowed to just the header."
 388   (let* ((from (mail-strip-quoted-names (or (mail-fetch-field "from")
 389                                             (mail-fetch-field "really-from")
 390                                             (mail-fetch-field "sender")
 391                                             (mail-fetch-field "return-path")
 392                                             "unknown")))
 393          (date (mail-fetch-field "date"))
 394          ;; A From: header can contain multiple addresses, a "From "
 395          ;; line must contain only one.  (Bug#7760)
 396          ;; See eg RFC 5322, 3.6.2. Originator Fields.
 397          (end (string-match "[ \t]*[,\n]" from)))
 398     (format "From %s %s\n" (if end
 399                                (substring from 0 end)
 400                              from)
 401             (or (and date
 402                      (ignore-errors
 403                       (current-time-string (date-to-time date))))
 404                 (current-time-string)))))
 405
 406 (provide 'mail-utils)
 407
 408 ;;; mail-utils.el ends here