1 ;;; undigest.el --- digest-cracking support for the RMAIL mail reader
3 ;; Copyright (C) 1985, 1986, 1994, 1996, 2002
4 ;; Free Software Foundation, Inc.
9 ;; This file is part of GNU Emacs.
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)
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.
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.
28 ;; See Internet RFC 934 and RFC 1153
29 ;; Also limited support for MIME digest encapsulation
35 (defconst rmail-mail-separator
36 "\^_\^L\n0, unseen,,\n*** EOOH ***\n"
37 "String for separating messages in an rmail file.")
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."
45 :group
'rmail-headers
)
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.
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.")
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))
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))
73 (separator (concat "\n--" (match-string 0) "\n\n"))
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
82 (defun rmail-digest-parse-rfc1153strict ()
83 "Parse following strictly the method defined in RFC 1153.
84 See rmail-digest-methods."
88 "^\n-\\{30\\}\n\nEnd of .* Digest.*\n\\*\\{15,\\}\n+\'"))
90 (defun rmail-digest-parse-rfc1153sloppy ()
91 "Parse using the method defined in RFC 1153, allowing for some sloppiness.
92 See rmail-digest-methods."
96 "^\n-\\{27,\\}\n\nEnd of"))
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))
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))
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
))))))
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))
134 (separator (match-string 0))
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
149 (defun undigestify-rmail-message ()
150 "Break up a digest message into its constituent messages.
151 Leaves original message, deleted, before the undigestified messages."
153 (with-current-buffer rmail-buffer
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))
162 (narrow-to-region (point-min) (1- (point-max)))
166 (goto-char (point-min))
167 (delete-region (point-min)
168 (progn (search-forward "\n*** EOOH ***\n" nil t
)
170 (insert "\n" rmail-mail-separator
)
171 (narrow-to-region (point)
173 (let ((fill-prefix "")
175 digest-name type start end separator fun-list sep-list
)
176 (setq digest-name
(mail-strip-quoted-names
178 (search-forward "\n\n" nil
'move
)
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")))))
186 (error "Message is not a digest--bad header"))
188 (setq fun-list rmail-digest-methods
)
190 (null (setq sep-list
(funcall (car fun-list
)))))
191 (setq fun-list
(cdr fun-list
)))
193 (error "Message is not a digest--no messages found"))
195 ;;; Split the digest into separate rmail messages
197 (let ((start (caar sep-list
))
198 (end (cdar sep-list
)))
199 (delete-region start end
)
201 (insert rmail-mail-separator
)
202 (search-forward "\n\n" (caar (cdr sep-list
)) 'move
)
204 (narrow-to-region end
(point))
205 (unless (mail-fetch-field "To")
207 (insert "To: " digest-name
"\n")))
208 (set-marker start nil
)
209 (set-marker end nil
))
210 (setq sep-list
(cdr sep-list
)))))
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)))))
222 (narrow-to-region (point-min) (1+ (point-max)))
223 (delete-region (point-min) (point-max))
224 (rmail-show-message rmail-current-message
)))))))
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."
232 ;; If we are in a summary buffer, switch to the Rmail buffer.
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
)
249 (skip-chars-forward "\n")
251 (setq end
(if (re-search-forward "^----.*[^- \t\n]" nil t
)
252 (match-beginning 0) (point-max)))
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))
260 (looking-at (concat "\\(" prefix
".+\n\\)*"
262 (looking-at (concat "\\(" prefix
".+\n\\)*"
264 "\\(" prefix
".+\n\\)*"
265 "\\(> ?\\)?\n" prefix
)))
266 (re-search-forward "^[^>\n]" nil
'move
)
268 (skip-chars-backward " \t\n")
272 (replace-regexp-in-string
273 (if (string= prefix
">") "^>" "> ?")
274 "" (buffer-substring beg end
))))
276 (error "No forwarded message found")))
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))
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")
291 (goto-char (point-min))
292 (re-search-forward "\n$" nil
'move
)
293 (narrow-to-region (point-min) (point))
294 (goto-char (point-min))
296 (unless (looking-at "^[a-zA-Z-]+: ")
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)))))
310 ;;; arch-tag: 3a28b9fb-c1f5-43ef-9278-285f3e4b874d
311 ;;; undigest.el ends here