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