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