lisp/mail/mail-utils.el

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