Commit | Line | Data |
---|---|---|
d501f516 ER |
1 | ;;; undigest.el --- digest-cracking support for the RMAIL mail reader |
2 | ||
ba318903 | 3 | ;; Copyright (C) 1985-1986, 1994, 1996, 2001-2014 Free Software |
ab422c4d | 4 | ;; Foundation, Inc. |
58142744 | 5 | |
34dc21db | 6 | ;; Maintainer: emacs-devel@gnu.org |
d7b4d18f | 7 | ;; Keywords: mail |
e5167999 | 8 | |
0d20f9a0 JB |
9 | ;; This file is part of GNU Emacs. |
10 | ||
b1fc2b50 | 11 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
0d20f9a0 | 12 | ;; it under the terms of the GNU General Public License as published by |
b1fc2b50 GM |
13 | ;; the Free Software Foundation, either version 3 of the License, or |
14 | ;; (at your option) any later version. | |
0d20f9a0 JB |
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 | |
b1fc2b50 | 22 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
0d20f9a0 | 23 | |
e5167999 ER |
24 | ;;; Commentary: |
25 | ||
7a613b67 GM |
26 | ;; See Internet RFC 934 and RFC 1153. |
27 | ;; Also limited support for MIME digest encapsulation. | |
e5167999 ER |
28 | |
29 | ;;; Code: | |
0d20f9a0 | 30 | |
4fe9b563 KH |
31 | (require 'rmail) |
32 | ||
a34804da FP |
33 | (defcustom rmail-forward-separator-regex |
34 | "^----.*\\([Ff]orwarded\\|[Oo]riginal\\).*[Mm]essage" | |
fb7ada5f | 35 | "Regexp to match the string that introduces forwarded messages. |
a34804da | 36 | This is not a header, but a string contained in the body of the message. |
1acb4c26 | 37 | You may need to customize it for local needs." |
a34804da FP |
38 | :type 'regexp |
39 | :group 'rmail-headers) | |
40 | ||
47687ab8 | 41 | \f |
3af9d2cf FP |
42 | (defconst rmail-digest-methods |
43 | '(rmail-digest-parse-mime | |
44 | rmail-digest-parse-rfc1153strict | |
45 | rmail-digest-parse-rfc1153sloppy | |
46 | rmail-digest-parse-rfc934) | |
47687ab8 | 47 | "List of digest parsing functions, first tried first. |
3af9d2cf | 48 | |
47687ab8 FP |
49 | These functions operate on the current narrowing, and take no argument. |
50 | A function returns nil if it cannot parse the digest. If it can, it | |
3af9d2cf FP |
51 | returns a list of cons pairs containing the start and end positions of |
52 | each undigestified message as markers.") | |
53 | ||
3af9d2cf FP |
54 | (defun rmail-digest-parse-mime () |
55 | (goto-char (point-min)) | |
56 | (when (let ((head-end (progn (search-forward "\n\n" nil t) (point)))) | |
57 | (goto-char (point-min)) | |
7a613b67 | 58 | (and head-end ; FIXME always true |
3af9d2cf FP |
59 | (re-search-forward |
60 | (concat | |
61 | "^Content-type: multipart/digest;" | |
62 | "\\s-* boundary=\"?\\([^\";\n]+\\)[\";\n]") head-end t) | |
63 | (search-forward (match-string 1) nil t))) | |
64 | ;; Ok, prolog separator found | |
65 | (let ((start (make-marker)) | |
66 | (end (make-marker)) | |
67 | (separator (concat "\n--" (match-string 0) "\n\n")) | |
68 | result) | |
69 | (while (search-forward separator nil t) | |
70 | (move-marker start (match-beginning 0)) | |
71 | (move-marker end (match-end 0)) | |
72 | (add-to-list 'result (cons (copy-marker start) (copy-marker end t)))) | |
73 | ;; Return the list of marker pairs | |
74 | (nreverse result)))) | |
75 | ||
76 | (defun rmail-digest-parse-rfc1153strict () | |
77 | "Parse following strictly the method defined in RFC 1153. | |
78 | See rmail-digest-methods." | |
79 | (rmail-digest-rfc1153 | |
80 | "^-\\{70\\}\n\n" | |
81 | "^\n-\\{30\\}\n\n" | |
82 | "^\n-\\{30\\}\n\nEnd of .* Digest.*\n\\*\\{15,\\}\n+\'")) | |
83 | ||
84 | (defun rmail-digest-parse-rfc1153sloppy () | |
85 | "Parse using the method defined in RFC 1153, allowing for some sloppiness. | |
86 | See rmail-digest-methods." | |
87 | (rmail-digest-rfc1153 | |
88 | "^-\\{55,\\}\n\n" | |
89 | "^\n-\\{27,\\}\n\n" | |
980d5def GM |
90 | ;; GNU Mailman knowingly (see comment at line 353 of ToDigest.py in |
91 | ;; Mailman source) produces non-conformant rfc 1153 digests, in that | |
92 | ;; the trailer contains a "digest footer" like this: | |
93 | ;; _______________________________________________ | |
94 | ;; <one or more lines of list blurb> | |
95 | ;; | |
96 | ;; End of Foo Digest... | |
97 | ;; ************************************** | |
98 | "^\nEnd of")) | |
3af9d2cf FP |
99 | |
100 | (defun rmail-digest-rfc1153 (prolog-sep message-sep trailer-sep) | |
101 | (goto-char (point-min)) | |
102 | (when (re-search-forward prolog-sep nil t) | |
103 | ;; Ok, prolog separator found | |
104 | (let ((start (make-marker)) | |
105 | (end (make-marker)) | |
106 | separator result) | |
107 | (move-marker start (match-beginning 0)) | |
108 | (move-marker end (match-end 0)) | |
980d5def | 109 | (setq result (list (cons (copy-marker start) (copy-marker end t)))) |
3af9d2cf FP |
110 | (when (re-search-forward message-sep nil t) |
111 | ;; Ok, at least one message separator found | |
112 | (setq separator (match-string 0)) | |
113 | (when (re-search-forward trailer-sep nil t) | |
114 | ;; Wonderful, we found a trailer, too. Now, go on splitting | |
115 | ;; the digest into separate rmail messages | |
116 | (goto-char (cdar result)) | |
117 | (while (search-forward separator nil t) | |
118 | (move-marker start (match-beginning 0)) | |
119 | (move-marker end (match-end 0)) | |
120 | (add-to-list 'result | |
121 | (cons (copy-marker start) (copy-marker end t)))) | |
122 | ;; Undo masking of separators inside digestified messages | |
123 | (goto-char (point-min)) | |
124 | (while (search-forward | |
125 | (replace-regexp-in-string "\n-" "\n " separator) nil t) | |
126 | (replace-match separator)) | |
127 | ;; Return the list of marker pairs | |
128 | (nreverse result)))))) | |
129 | ||
130 | (defun rmail-digest-parse-rfc934 () | |
131 | (goto-char (point-min)) | |
132 | (when (re-search-forward "^\n?-[^ ].*\n\n?" nil t) | |
133 | ;; Message separator found | |
134 | (let ((start (make-marker)) | |
135 | (end (make-marker)) | |
136 | (separator (match-string 0)) | |
137 | result) | |
138 | (goto-char (point-min)) | |
139 | (while (search-forward separator nil t) | |
140 | (move-marker start (match-beginning 0)) | |
141 | (move-marker end (match-end 0)) | |
142 | (add-to-list 'result (cons (copy-marker start) (copy-marker end t)))) | |
143 | ;; Undo masking of separators inside digestified messages | |
144 | (goto-char (point-min)) | |
145 | (while (search-forward "\n- -" nil t) | |
146 | (replace-match "\n-")) | |
147 | ;; Return the list of marker pairs | |
148 | (nreverse result)))) | |
149 | ||
2b54af74 DN |
150 | (declare-function rmail-update-summary "rmailsum" (&rest ignore)) |
151 | ||
372a91d7 | 152 | ;;;###autoload |
0d20f9a0 JB |
153 | (defun undigestify-rmail-message () |
154 | "Break up a digest message into its constituent messages. | |
155 | Leaves original message, deleted, before the undigestified messages." | |
156 | (interactive) | |
7a613b67 GM |
157 | (set-buffer rmail-buffer) |
158 | (let ((buff (current-buffer)) | |
159 | (current rmail-current-message) | |
160 | (msgbeg (rmail-msgbeg rmail-current-message)) | |
161 | (msgend (rmail-msgend rmail-current-message))) | |
162 | (if (rmail-buffers-swapped-p) (set-buffer rmail-view-buffer)) | |
add0c454 | 163 | (widen) |
add0c454 RS |
164 | (let ((error t) |
165 | (buffer-read-only nil)) | |
7a613b67 GM |
166 | (goto-char msgend) |
167 | (let ((msg-copy (buffer-substring-no-properties msgbeg msgend))) | |
3af9d2cf | 168 | (narrow-to-region (point) (point)) |
7a613b67 GM |
169 | (insert "\n" msg-copy)) |
170 | (goto-char (point-min)) | |
add0c454 RS |
171 | (unwind-protect |
172 | (progn | |
7a613b67 GM |
173 | (let ((fill-prefix "") |
174 | (case-fold-search t) | |
175 | digest-name fun-list sep-list start end) | |
176 | (setq digest-name (mail-strip-quoted-names | |
177 | (save-restriction | |
178 | (search-forward "\n\n" nil 'move) | |
179 | (narrow-to-region (point-min) (point)) | |
180 | (or (mail-fetch-field "Reply-To") | |
181 | (mail-fetch-field "To") | |
182 | (mail-fetch-field "Apparently-To") | |
183 | (mail-fetch-field "From"))))) | |
184 | (unless digest-name | |
185 | (error "Message is not a digest--bad header")) | |
186 | (setq fun-list rmail-digest-methods) | |
187 | (while (and fun-list | |
188 | (null (setq sep-list (funcall (car fun-list))))) | |
189 | (setq fun-list (cdr fun-list))) | |
190 | (unless sep-list | |
191 | (error "Message is not a digest--no messages found")) | |
192 | ;; Split the digest into separate rmail messages. | |
193 | (while sep-list | |
194 | (setq start (caar sep-list) | |
195 | end (cdar sep-list)) | |
196 | (delete-region start end) | |
197 | (goto-char start) | |
198 | (search-forward "\n\n" (caar (cdr sep-list)) 'move) | |
199 | (save-restriction | |
200 | (narrow-to-region end (point)) | |
201 | (goto-char (point-min)) | |
202 | (insert "\nFrom rmail@localhost " (current-time-string) "\n") | |
203 | (save-excursion | |
204 | (forward-line -1) | |
205 | (rmail-add-mbox-headers)) | |
206 | (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)))) | |
add0c454 RS |
211 | (setq error nil) |
212 | (message "Message successfully undigestified") | |
7a613b67 GM |
213 | (set-buffer buff) |
214 | (rmail-swap-buffers-maybe) | |
215 | (goto-char (point-max)) | |
35426db4 | 216 | ;; FIXME use rmail-count-new-messages. |
7a613b67 GM |
217 | (rmail-set-message-counters) |
218 | (set-buffer-modified-p t) | |
219 | (rmail-show-message current) | |
220 | (rmail-delete-forward) | |
221 | (if (rmail-summary-exists) | |
222 | (rmail-select-summary (rmail-update-summary)))) | |
223 | (when error | |
224 | (delete-region (point-min) (point-max)) | |
225 | (set-buffer buff) | |
226 | (rmail-show-message current)))))) | |
47687ab8 | 227 | \f |
372a91d7 | 228 | ;;;###autoload |
9f606031 KH |
229 | (defun unforward-rmail-message () |
230 | "Extract a forwarded message from the containing message. | |
b474519e GM |
231 | This puts the forwarded message into a separate rmail message following |
232 | the containing message. This command is only useful when messages are | |
233 | forwarded with `rmail-enable-mime-composing' set to nil." | |
9f606031 | 234 | (interactive) |
7a613b67 GM |
235 | (set-buffer rmail-buffer) |
236 | (let ((buff (current-buffer)) | |
237 | (current rmail-current-message) | |
238 | (beg (rmail-msgbeg rmail-current-message)) | |
239 | (msgend (rmail-msgend rmail-current-message)) | |
240 | (error t)) | |
241 | (unwind-protect | |
242 | (progn | |
243 | (if (rmail-buffers-swapped-p) (set-buffer rmail-view-buffer)) | |
47687ab8 | 244 | (widen) |
7a613b67 GM |
245 | (goto-char beg) |
246 | (search-forward "\n\n" msgend) | |
247 | (narrow-to-region beg (point)) | |
248 | (let ((old-fwd-from (mail-fetch-field "Forwarded-From" nil nil t)) | |
249 | (old-fwd-date (mail-fetch-field "Forwarded-Date" nil nil t)) | |
250 | (fwd-from (mail-fetch-field "From")) | |
251 | (fwd-date (mail-fetch-field "Date")) | |
252 | (buffer-read-only nil) | |
253 | prefix forward-msg end) | |
254 | (widen) | |
255 | (narrow-to-region beg msgend) | |
256 | (cond ((re-search-forward rmail-forward-separator-regex nil t) | |
257 | (forward-line 1) | |
258 | (skip-chars-forward "\n") | |
259 | (setq beg (point)) | |
260 | (setq end (if (re-search-forward "^----.*[^- \t\n]" nil t) | |
261 | (match-beginning 0) (point-max))) | |
262 | (setq forward-msg | |
263 | (replace-regexp-in-string | |
264 | "^- -" "-" (buffer-substring beg end)))) | |
265 | ((and (re-search-forward "^\\(> ?\\)[a-zA-Z-]+: .*\n" nil t) | |
266 | (setq beg (match-beginning 0)) | |
267 | (setq prefix (match-string-no-properties 1)) | |
268 | (goto-char beg) | |
269 | (looking-at (concat "\\(" prefix ".+\n\\)*" | |
270 | prefix "Date: .")) | |
271 | (looking-at (concat "\\(" prefix ".+\n\\)*" | |
272 | prefix "From: .+\n" | |
273 | "\\(" prefix ".+\n\\)*" | |
274 | "\\(> ?\\)?\n" prefix))) | |
275 | (re-search-forward "^[^>\n]" nil 'move) | |
276 | (backward-char) | |
277 | (skip-chars-backward " \t\n") | |
278 | (forward-line 1) | |
279 | (setq end (point)) | |
280 | (setq forward-msg | |
281 | (replace-regexp-in-string | |
282 | (if (string= prefix ">") "^>" "> ?") | |
283 | "" (buffer-substring beg end)))) | |
284 | (t | |
285 | (error "No forwarded message found"))) | |
286 | (widen) | |
287 | (goto-char msgend) | |
288 | ;; Insert a fake From line. | |
289 | ;; FIXME we could construct one using the From and Date headers | |
290 | ;; of the forwarded message - is it worth it? | |
291 | (insert "\n\nFrom rmail@localhost " (current-time-string) "\n") | |
292 | (setq beg (point)) ; start of header | |
293 | (while old-fwd-from | |
294 | (insert "Forwarded-From: " (car old-fwd-from) "\n") | |
295 | (insert "Forwarded-Date: " (car old-fwd-date) "\n") | |
296 | (setq old-fwd-from (cdr old-fwd-from)) | |
297 | (setq old-fwd-date (cdr old-fwd-date))) | |
298 | (insert "Forwarded-From: " fwd-from "\n") | |
299 | (insert "Forwarded-Date: " fwd-date "\n") | |
300 | (insert forward-msg "\n") | |
301 | (goto-char beg) | |
302 | (re-search-forward "\n$" nil 'move) ; end of header | |
303 | (narrow-to-region beg (point)) | |
47687ab8 FP |
304 | (goto-char (point-min)) |
305 | (while (not (eobp)) | |
306 | (unless (looking-at "^[a-zA-Z-]+: ") | |
307 | (insert "\t")) | |
7a613b67 GM |
308 | (forward-line)) |
309 | (widen) | |
310 | (goto-char beg) | |
311 | (forward-line -1) | |
312 | (rmail-add-mbox-headers)) ; marks as unseen | |
313 | (setq error nil) | |
314 | (set-buffer buff) | |
315 | (rmail-swap-buffers-maybe) | |
316 | (goto-char (point-max)) | |
35426db4 | 317 | ;; FIXME use rmail-count-new-messages. |
7a613b67 GM |
318 | (rmail-set-message-counters) |
319 | (set-buffer-modified-p t) | |
320 | (rmail-show-message current) | |
321 | (if (rmail-summary-exists) | |
322 | (rmail-select-summary (rmail-update-summary)))) | |
323 | (when error | |
324 | (set-buffer buff) | |
325 | (rmail-show-message current))))) | |
9f606031 | 326 | |
896546cd RS |
327 | (provide 'undigest) |
328 | ||
35426db4 GM |
329 | ;; Local Variables: |
330 | ;; generated-autoload-file: "rmail.el" | |
331 | ;; End: | |
332 | ||
d501f516 | 333 | ;;; undigest.el ends here |