lisp/mail/undigest.el

   1 ;;; undigest.el --- digest-cracking support for the RMAIL mail reader
   2
   3 ;; Copyright (C) 1985, 1986, 1994, 1996, 2001, 2002, 2003, 2004,
   4 ;;   2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
   5
   6 ;; Maintainer: FSF
   7 ;; Keywords: mail
   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 ;; See Internet RFC 934 and RFC 1153
  27 ;; Also limited support for MIME digest encapsulation
  28
  29 ;;; Code:
  30
  31 (require 'rmail)
  32
  33 (defconst rmail-mail-separator
  34   "\^_\^L\n0, unseen,,\n*** EOOH ***\n"
  35   "String for separating messages in an rmail file.")
  36
  37 (defcustom rmail-forward-separator-regex
  38   "^----.*\\([Ff]orwarded\\|[Oo]riginal\\).*[Mm]essage"
  39   "*Regexp to match the string that introduces forwarded messages.
  40 This is not a header, but a string contained in the body of the message.
  41 You may need to customize it for local needs."
  42   :type 'regexp
  43   :group 'rmail-headers)
  44
  45 \f
  46 (defconst rmail-digest-methods
  47   '(rmail-digest-parse-mime
  48     rmail-digest-parse-rfc1153strict
  49     rmail-digest-parse-rfc1153sloppy
  50     rmail-digest-parse-rfc934)
  51   "List of digest parsing functions, first tried first.
  52
  53 These functions operate on the current narrowing, and take no argument.
  54 A function returns nil if it cannot parse the digest.  If it can, it
  55 returns a list of cons pairs containing the start and end positions of
  56 each undigestified message as markers.")
  57
  58 (defun rmail-digest-parse-mime ()
  59   (goto-char (point-min))
  60   (when (let ((head-end (progn (search-forward "\n\n" nil t) (point))))
  61           (goto-char (point-min))
  62           (and head-end
  63                (re-search-forward
  64                 (concat
  65                  "^Content-type: multipart/digest;"
  66                  "\\s-* boundary=\"?\\([^\";\n]+\\)[\";\n]") head-end t)
  67                (search-forward (match-string 1) nil t)))
  68     ;; Ok, prolog separator found
  69     (let ((start (make-marker))
  70           (end (make-marker))
  71           (separator (concat "\n--" (match-string 0) "\n\n"))
  72           result)
  73       (while (search-forward separator nil t)
  74         (move-marker start (match-beginning 0))
  75         (move-marker end (match-end 0))
  76         (add-to-list 'result (cons (copy-marker start) (copy-marker end t))))
  77       ;; Return the list of marker pairs
  78       (nreverse result))))
  79
  80 (defun rmail-digest-parse-rfc1153strict ()
  81   "Parse following strictly the method defined in RFC 1153.
  82 See rmail-digest-methods."
  83  (rmail-digest-rfc1153
  84   "^-\\{70\\}\n\n"
  85   "^\n-\\{30\\}\n\n"
  86   "^\n-\\{30\\}\n\nEnd of .* Digest.*\n\\*\\{15,\\}\n+\'"))
  87
  88 (defun rmail-digest-parse-rfc1153sloppy ()
  89   "Parse using the method defined in RFC 1153, allowing for some sloppiness.
  90 See rmail-digest-methods."
  91  (rmail-digest-rfc1153
  92   "^-\\{55,\\}\n\n"
  93   "^\n-\\{27,\\}\n\n"
  94   ;; GNU Mailman knowingly (see comment at line 353 of ToDigest.py in
  95   ;; Mailman source) produces non-conformant rfc 1153 digests, in that
  96   ;; the trailer contains a "digest footer" like this:
  97   ;; _______________________________________________
  98   ;; <one or more lines of list blurb>
  99   ;;
 100   ;; End of Foo Digest...
 101   ;; **************************************
 102   "^\nEnd of"))
 103
 104 (defun rmail-digest-rfc1153 (prolog-sep message-sep trailer-sep)
 105   (goto-char (point-min))
 106   (when (re-search-forward prolog-sep nil t)
 107     ;; Ok, prolog separator found
 108     (let ((start (make-marker))
 109           (end (make-marker))
 110           separator result)
 111       (move-marker start (match-beginning 0))
 112       (move-marker end (match-end 0))
 113       (setq result (list (cons (copy-marker start) (copy-marker end t))))
 114       (when (re-search-forward message-sep nil t)
 115         ;; Ok, at least one message separator found
 116         (setq separator (match-string 0))
 117         (when (re-search-forward trailer-sep nil t)
 118           ;; Wonderful, we found a trailer, too.  Now, go on splitting
 119           ;; the digest into separate rmail messages
 120           (goto-char (cdar result))
 121           (while (search-forward separator nil t)
 122             (move-marker start (match-beginning 0))
 123             (move-marker end (match-end 0))
 124             (add-to-list 'result
 125                          (cons (copy-marker start) (copy-marker end t))))
 126           ;; Undo masking of separators inside digestified messages
 127           (goto-char (point-min))
 128           (while (search-forward
 129                   (replace-regexp-in-string "\n-" "\n " separator) nil t)
 130             (replace-match separator))
 131           ;; Return the list of marker pairs
 132           (nreverse result))))))
 133
 134 (defun rmail-digest-parse-rfc934 ()
 135   (goto-char (point-min))
 136   (when (re-search-forward "^\n?-[^ ].*\n\n?" nil t)
 137     ;; Message separator found
 138     (let ((start (make-marker))
 139           (end (make-marker))
 140           (separator (match-string 0))
 141           result)
 142       (goto-char (point-min))
 143       (while (search-forward separator nil t)
 144         (move-marker start (match-beginning 0))
 145         (move-marker end (match-end 0))
 146         (add-to-list 'result (cons (copy-marker start) (copy-marker end t))))
 147       ;; Undo masking of separators inside digestified messages
 148       (goto-char (point-min))
 149       (while (search-forward "\n- -" nil t)
 150         (replace-match "\n-"))
 151       ;; Return the list of marker pairs
 152       (nreverse result))))
 153
 154 (declare-function rmail-update-summary "rmailsum" (&rest ignore))
 155
 156 ;;;###autoload
 157 (defun undigestify-rmail-message ()
 158   "Break up a digest message into its constituent messages.
 159 Leaves original message, deleted, before the undigestified messages."
 160   (interactive)
 161   (with-current-buffer rmail-buffer
 162     (widen)
 163     (let ((error t)
 164           (buffer-read-only nil))
 165       (goto-char (rmail-msgend rmail-current-message))
 166       (let ((msg-copy (buffer-substring (rmail-msgbeg rmail-current-message)
 167                                         (rmail-msgend rmail-current-message))))
 168         (narrow-to-region (point) (point))
 169         (insert msg-copy))
 170       (narrow-to-region (point-min) (1- (point-max)))
 171       (unwind-protect
 172           (progn
 173             (save-restriction
 174               (goto-char (point-min))
 175               (delete-region (point-min)
 176                              (progn (search-forward "\n*** EOOH ***\n" nil t)
 177                                     (point)))
 178               (insert "\n" rmail-mail-separator)
 179               (narrow-to-region (point)
 180                                 (point-max))
 181               (let ((fill-prefix "")
 182                     (case-fold-search t)
 183                     digest-name type start end separator fun-list sep-list)
 184                 (setq digest-name (mail-strip-quoted-names
 185                                    (save-restriction
 186                                      (search-forward "\n\n" nil 'move)
 187                                      (setq start (point))
 188                                      (narrow-to-region (point-min) start)
 189                                      (or (mail-fetch-field "Reply-To")
 190                                          (mail-fetch-field "To")
 191                                          (mail-fetch-field "Apparently-To")
 192                                          (mail-fetch-field "From")))))
 193                 (unless digest-name
 194                   (error "Message is not a digest--bad header"))
 195
 196                 (setq fun-list rmail-digest-methods)
 197                 (while (and fun-list
 198                             (null (setq sep-list (funcall (car fun-list)))))
 199                   (setq fun-list (cdr fun-list)))
 200                 (unless sep-list
 201                   (error "Message is not a digest--no messages found"))
 202
 203                 ;;; Split the digest into separate rmail messages
 204                 (while sep-list
 205                   (let ((start (caar sep-list))
 206                         (end (cdar sep-list)))
 207                     (delete-region start end)
 208                     (goto-char start)
 209                     (insert rmail-mail-separator)
 210                     (search-forward "\n\n" (caar (cdr sep-list)) 'move)
 211                     (save-restriction
 212                       (narrow-to-region end (point))
 213                       (unless (mail-fetch-field "To")
 214                         (goto-char start)
 215                         (insert "To: " digest-name "\n")))
 216                     (set-marker start nil)
 217                     (set-marker end nil))
 218                   (setq sep-list (cdr sep-list)))))
 219
 220             (setq error nil)
 221             (message "Message successfully undigestified")
 222             (let ((n rmail-current-message))
 223               (rmail-forget-messages)
 224               (rmail-show-message n)
 225               (rmail-delete-forward)
 226               (if (rmail-summary-exists)
 227                   (rmail-select-summary
 228                    (rmail-update-summary)))))
 229         (cond (error
 230                (narrow-to-region (point-min) (1+ (point-max)))
 231                (delete-region (point-min) (point-max))
 232                (rmail-show-message rmail-current-message)))))))
 233 \f
 234 ;;;###autoload
 235 (defun unforward-rmail-message ()
 236   "Extract a forwarded message from the containing message.
 237 This puts the forwarded message into a separate rmail message
 238 following the containing message."
 239   (interactive)
 240   ;; If we are in a summary buffer, switch to the Rmail buffer.
 241   (unwind-protect
 242       (with-current-buffer rmail-buffer
 243         (goto-char (point-min))
 244         (narrow-to-region (point)
 245                           (save-excursion (search-forward "\n\n") (point)))
 246         (let ((buffer-read-only nil)
 247               (old-fwd-from (mail-fetch-field "Forwarded-From" nil nil t))
 248               (old-fwd-date (mail-fetch-field "Forwarded-Date" nil nil t))
 249               (fwd-from (mail-fetch-field "From"))
 250               (fwd-date (mail-fetch-field "Date"))
 251               beg end prefix forward-msg)
 252           (narrow-to-region (rmail-msgbeg rmail-current-message)
 253                             (rmail-msgend rmail-current-message))
 254           (goto-char (point-min))
 255           (cond ((re-search-forward rmail-forward-separator-regex nil t)
 256                  (forward-line 1)
 257                  (skip-chars-forward "\n")
 258                  (setq beg (point))
 259                  (setq end (if (re-search-forward "^----.*[^- \t\n]" nil t)
 260                                (match-beginning 0) (point-max)))
 261                  (setq forward-msg
 262                        (replace-regexp-in-string
 263                         "^- -" "-" (buffer-substring beg end))))
 264                 ((and (re-search-forward "^\\(> ?\\)[a-zA-Z-]+: .*\n" nil t)
 265                       (setq beg (match-beginning 0))
 266                       (setq prefix (match-string-no-properties 1))
 267                       (goto-char beg)
 268                       (looking-at (concat "\\(" prefix ".+\n\\)*"
 269                                           prefix "Date: ."))
 270                       (looking-at (concat "\\(" prefix ".+\n\\)*"
 271                                           prefix "From: .+\n"
 272                                           "\\(" prefix ".+\n\\)*"
 273                                           "\\(> ?\\)?\n" prefix)))
 274                  (re-search-forward "^[^>\n]" nil 'move)
 275                  (backward-char)
 276                  (skip-chars-backward " \t\n")
 277                  (forward-line 1)
 278                  (setq end (point))
 279                  (setq forward-msg
 280                        (replace-regexp-in-string
 281                         (if (string= prefix ">") "^>" "> ?")
 282                         "" (buffer-substring beg end))))
 283                 (t
 284                  (error "No forwarded message found")))
 285           (widen)
 286           (goto-char (rmail-msgend rmail-current-message))
 287           (narrow-to-region (point) (point))
 288           (insert rmail-mail-separator)
 289           (narrow-to-region (point) (point))
 290           (while old-fwd-from
 291             (insert "Forwarded-From: " (car old-fwd-from) "\n")
 292             (insert "Forwarded-Date: " (car old-fwd-date) "\n")
 293             (setq old-fwd-from (cdr old-fwd-from))
 294             (setq old-fwd-date (cdr old-fwd-date)))
 295           (insert "Forwarded-From: " fwd-from "\n")
 296           (insert "Forwarded-Date: " fwd-date "\n")
 297           (insert forward-msg)
 298           (save-restriction
 299             (goto-char (point-min))
 300             (re-search-forward "\n$" nil 'move)
 301             (narrow-to-region (point-min) (point))
 302             (goto-char (point-min))
 303             (while (not (eobp))
 304               (unless (looking-at "^[a-zA-Z-]+: ")
 305                 (insert "\t"))
 306               (forward-line)))
 307           (goto-char (point-min))))
 308     (let ((n rmail-current-message))
 309       (rmail-forget-messages)
 310       (rmail-show-message n))
 311     (if (rmail-summary-exists)
 312         (rmail-select-summary
 313          (rmail-update-summary)))))
 314
 315
 316 (provide 'undigest)
 317
 318 ;; arch-tag: 3a28b9fb-c1f5-43ef-9278-285f3e4b874d
 319 ;;; undigest.el ends here