lisp/mail/mail-utils.el

   1 ;;; mail-utils.el --- utility functions used both by rmail and rnews
   2
   3 ;; Copyright (C) 1985, 2001-2014 Free Software Foundation, Inc.
   4
   5 ;; Maintainer: emacs-devel@gnu.org
   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 (autoload 'rfc822-addresses "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   (when address
 193     (if mail-use-rfc822
 194         (mapconcat 'identity (rfc822-addresses address) ", ")
 195       (let (pos)
 196
 197         ;; Strip comments.
 198         (while (setq pos (string-match
 199                           "[ \t]*(\\([^()\\]\\|\\\\.\\|\\\\\n\\)*)"
 200                           address))
 201           (setq address (replace-match "" nil nil address 0)))
 202
 203         ;; strip surrounding whitespace
 204         (string-match "\\`[ \t\n]*" address)
 205         (setq address (substring address
 206                                  (match-end 0)
 207                                  (string-match "[ \t\n]*\\'" address
 208                                                (match-end 0))))
 209
 210         ;; strip `quoted' names (This is supposed to hack `"Foo Bar" <bar@host>')
 211         (setq pos 0)
 212         (while (setq pos (string-match
 213                           "\\([ \t]?\\)\\([ \t]*\"\\([^\"\\]\\|\\\\.\\|\\\\\n\\)*\"[ \t\n]*\\)"
 214                           address pos))
 215           ;; If the next thing is "@", we have "foo bar"@host.  Leave it.
 216           (if (and (> (length address) (match-end 0))
 217                    (= (aref address (match-end 0)) ?@))
 218               (setq pos (match-end 0))
 219             ;; Otherwise discard the "..." part.
 220             (setq address (replace-match "" nil nil address 2))))
 221         ;; If this address contains <...>, replace it with just
 222         ;; the part between the <...>.
 223         (while (setq pos (string-match "\\(,\\s-*\\|\\`\\)\\([^,]*<\\([^>,:]*\\)>[^,]*\\)\\(\\s-*,\\|\\'\\)"
 224                                        address))
 225           (setq address (replace-match (match-string 3 address)
 226                                        nil 'literal address 2)))
 227         address))))
 228
 229 (defun mail-dont-reply-to (destinations)
 230   "Prune addresses from DESTINATIONS, a list of recipient addresses.
 231 Remove all addresses matching `mail-dont-reply-to-names' from the
 232 comma-separated list, and return the pruned list."
 233   ;; FIXME this (setting a user option the first time a command is used)
 234   ;; is somewhat strange.  Normally one would never set the option,
 235   ;; but instead fall back to the default so long as it was nil.
 236   ;; Or just set the default directly in the defcustom.
 237   (if (null mail-dont-reply-to-names)
 238       (setq mail-dont-reply-to-names
 239             (concat
 240              ;; `rmail-default-dont-reply-to-names' is obsolete.
 241              (if (bound-and-true-p rmail-default-dont-reply-to-names)
 242                  (concat rmail-default-dont-reply-to-names "\\|")
 243                "")
 244              (if (and user-mail-address
 245                       (not (equal user-mail-address user-login-name)))
 246                  ;; Anchor the login name and email address so that we
 247                  ;; don't match substrings: if the login name is
 248                  ;; "foo", we shouldn't match "barfoo@baz.com".
 249                  (concat "\\`"
 250                          (regexp-quote user-mail-address)
 251                          "\\'\\|")
 252                "")
 253              (concat "\\`" (regexp-quote user-login-name) "@"))))
 254   ;; Split up DESTINATIONS and match each element separately.
 255   (let ((start-pos 0) (cur-pos 0)
 256         (case-fold-search t))
 257     (while start-pos
 258       (setq cur-pos (string-match "[,\"]" destinations cur-pos))
 259       (if (and cur-pos (equal (match-string 0 destinations) "\""))
 260           ;; Search for matching quote.
 261           (let ((next-pos (string-match "\"" destinations (1+ cur-pos))))
 262             (if next-pos
 263                 (setq cur-pos (1+ next-pos))
 264               ;; If the open-quote has no close-quote,
 265               ;; delete the open-quote to get something well-defined.
 266               ;; This case is not valid, but it can happen if things
 267               ;; are weird elsewhere.
 268               (setq destinations (concat (substring destinations 0 cur-pos)
 269                                     (substring destinations (1+ cur-pos))))
 270               (setq cur-pos start-pos)))
 271         (let* ((address (substring destinations start-pos cur-pos))
 272                (naked-address (mail-strip-quoted-names address)))
 273           (if (string-match mail-dont-reply-to-names naked-address)
 274               (setq destinations (concat (substring destinations 0 start-pos)
 275                                     (and cur-pos (substring destinations
 276                                                             (1+ cur-pos))))
 277                     cur-pos start-pos)
 278             (setq cur-pos (and cur-pos (1+ cur-pos))
 279                   start-pos cur-pos))))))
 280   ;; get rid of any trailing commas
 281   (let ((pos (string-match "[ ,\t\n]*\\'" destinations)))
 282     (if pos
 283         (setq destinations (substring destinations 0 pos))))
 284   ;; remove leading spaces. they bother me.
 285   (if (string-match "\\(\\s \\|,\\)*" destinations)
 286       (substring destinations (match-end 0))
 287     destinations))
 288
 289 ;; Legacy name
 290 (define-obsolete-function-alias 'rmail-dont-reply-to 'mail-dont-reply-to "24.1")
 291
 292 \f
 293 ;;;###autoload
 294 (defun mail-fetch-field (field-name &optional last all list)
 295   "Return the value of the header field whose type is FIELD-NAME.
 296 If second arg LAST is non-nil, use the last field of type FIELD-NAME.
 297 If third arg ALL is non-nil, concatenate all such fields with commas between.
 298 If 4th arg LIST is non-nil, return a list of all such fields.
 299 The buffer should be narrowed to just the header, else false
 300 matches may be returned from the message body."
 301   (save-excursion
 302     (goto-char (point-min))
 303     (let ((case-fold-search t)
 304           (name (concat "^" (regexp-quote field-name) "[ \t]*:[ \t]*")))
 305       (if (or all list)
 306           (let ((value (if all "")))
 307             (while (re-search-forward name nil t)
 308               (let ((opoint (point)))
 309                 (while (progn (forward-line 1)
 310                               (looking-at "[ \t]")))
 311                 ;; Back up over newline, then trailing spaces or tabs
 312                 (forward-char -1)
 313                 (skip-chars-backward " \t" opoint)
 314                 (if list
 315                     (setq value (cons (buffer-substring-no-properties
 316                                        opoint (point))
 317                                       value))
 318                   (setq value (concat value
 319                                       (if (string= value "") "" ", ")
 320                                       (buffer-substring-no-properties
 321                                        opoint (point)))))))
 322             (if list
 323                 value
 324               (and (not (string= value "")) value)))
 325         (if (re-search-forward name nil t)
 326             (progn
 327               (if last (while (re-search-forward name nil t)))
 328               (let ((opoint (point)))
 329                 (while (progn (forward-line 1)
 330                               (looking-at "[ \t]")))
 331                 ;; Back up over newline, then trailing spaces or tabs
 332                 (forward-char -1)
 333                 (skip-chars-backward " \t" opoint)
 334                 (buffer-substring-no-properties opoint (point)))))))))
 335 \f
 336 ;; Parse a list of tokens separated by commas.
 337 ;; It runs from point to the end of the visible part of the buffer.
 338 ;; Whitespace before or after tokens is ignored,
 339 ;; but whitespace within tokens is kept.
 340 (defun mail-parse-comma-list ()
 341   (let (accumulated
 342         beg)
 343     (skip-chars-forward " \t\n")
 344     (while (not (eobp))
 345       (setq beg (point))
 346       (skip-chars-forward "^,")
 347       (skip-chars-backward " \t\n")
 348       (setq accumulated
 349             (cons (buffer-substring-no-properties beg (point))
 350                   accumulated))
 351       (skip-chars-forward "^,")
 352       (skip-chars-forward ", \t\n"))
 353     accumulated))
 354
 355 (defun mail-comma-list-regexp (labels)
 356   (let (pos)
 357     (setq pos (or (string-match "[^ \t]" labels) 0))
 358     ;; Remove leading and trailing whitespace.
 359     (setq labels (substring labels pos (string-match "[ \t]*$" labels pos)))
 360     ;; Change each comma to \|, and flush surrounding whitespace.
 361     (while (setq pos (string-match "[ \t]*,[ \t]*" labels))
 362       (setq labels
 363             (concat (substring labels 0 pos)
 364                     "\\|"
 365                     (substring labels (match-end 0))))))
 366   labels)
 367 \f
 368 (defun mail-rfc822-time-zone (time)
 369   (let* ((sec (or (car (current-time-zone time)) 0))
 370          (absmin (/ (abs sec) 60)))
 371     (format "%c%02d%02d" (if (< sec 0) ?- ?+) (/ absmin 60) (% absmin 60))))
 372
 373 (defun mail-rfc822-date ()
 374   (let* ((time (current-time))
 375          (s (current-time-string time)))
 376     (string-match "[^ ]+ +\\([^ ]+\\) +\\([^ ]+\\) \\([^ ]+\\) \\([^ ]+\\)" s)
 377     (concat (substring s (match-beginning 2) (match-end 2)) " "
 378             (substring s (match-beginning 1) (match-end 1)) " "
 379             (substring s (match-beginning 4) (match-end 4)) " "
 380             (substring s (match-beginning 3) (match-end 3)) " "
 381             (mail-rfc822-time-zone time))))
 382
 383 (defun mail-mbox-from ()
 384   "Return an mbox \"From \" line for the current message.
 385 The buffer should be narrowed to just the header."
 386   (let* ((from (mail-strip-quoted-names (or (mail-fetch-field "from")
 387                                             (mail-fetch-field "really-from")
 388                                             (mail-fetch-field "sender")
 389                                             (mail-fetch-field "return-path")
 390                                             "unknown")))
 391          (date (mail-fetch-field "date"))
 392          ;; A From: header can contain multiple addresses, a "From "
 393          ;; line must contain only one.  (Bug#7760)
 394          ;; See eg RFC 5322, 3.6.2. Originator Fields.
 395          (end (string-match "[ \t]*[,\n]" from)))
 396     (format "From %s %s\n" (if end
 397                                (substring from 0 end)
 398                              from)
 399             (or (and date
 400                      (ignore-errors
 401                       (current-time-string (date-to-time date))))
 402                 (current-time-string)))))
 403
 404 (provide 'mail-utils)
 405
 406 ;;; mail-utils.el ends here