lisp/mail/mail-utils.el

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