lisp/mail/mail-utils.el

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