1 |
;;; undigest.el --- digest-cracking support for the RMAIL mail reader |
;;; undigest.el --- digest-cracking support for the RMAIL mail reader |
2 |
|
|
3 |
;; Copyright (C) 1985, 1986, 1994, 1996 Free Software Foundation, Inc. |
;; Copyright (C) 1985, 1986, 1994, 1996, 2002 |
4 |
|
;; Free Software Foundation, Inc. |
5 |
|
|
6 |
;; Maintainer: FSF |
;; Maintainer: FSF |
7 |
;; Keywords: mail |
;; Keywords: mail |
25 |
|
|
26 |
;;; Commentary: |
;;; Commentary: |
27 |
|
|
28 |
;; See Internet RFC 934 |
;; See Internet RFC 934 and RFC 1153 |
29 |
|
;; Also limited support for MIME digest encapsulation |
30 |
|
|
31 |
;;; Code: |
;;; Code: |
32 |
|
|
33 |
(require 'rmail) |
(require 'rmail) |
34 |
|
|
35 |
(defcustom rmail-digest-end-regexps |
(defconst rmail-mail-separator |
36 |
(list (concat "End of.*Digest.*\n" |
"\^_\^L\n0, unseen,,\n*** EOOH ***\n" |
37 |
(regexp-quote "*********") "*" |
"String for separating messages in an rmail file.") |
38 |
"\\(\n------*\\)*") |
|
39 |
(concat "End of.*\n" |
(defcustom rmail-forward-separator-regex |
40 |
(regexp-quote "*") "*")) |
"^----.*\\([Ff]orwarded\\|[Oo]riginal\\).*[Mm]essage" |
41 |
"*Regexps matching the end of a digest message." |
"*Regexp to match the string that introduces forwarded messages. |
42 |
:group 'rmail |
This is not a header, but a string contained in the body of the message. |
43 |
:type '(repeat regexp)) |
You may need to customise it for local needs." |
44 |
|
:type 'regexp |
45 |
|
:group 'rmail-headers) |
46 |
|
|
47 |
|
|
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 |
;;;###autoload |
149 |
(defun undigestify-rmail-message () |
(defun undigestify-rmail-message () |
152 |
(interactive) |
(interactive) |
153 |
(with-current-buffer rmail-buffer |
(with-current-buffer rmail-buffer |
154 |
(widen) |
(widen) |
|
(let ((buffer-read-only nil) |
|
|
(msg-string (buffer-substring (rmail-msgbeg rmail-current-message) |
|
|
(rmail-msgend rmail-current-message)))) |
|
|
(goto-char (rmail-msgend rmail-current-message)) |
|
|
(narrow-to-region (point) (point)) |
|
|
(insert msg-string) |
|
|
(narrow-to-region (point-min) (1- (point-max)))) |
|
155 |
(let ((error t) |
(let ((error t) |
156 |
(buffer-read-only nil)) |
(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 |
(unwind-protect |
164 |
(progn |
(progn |
165 |
(save-restriction |
(save-restriction |
166 |
(goto-char (point-min)) |
(goto-char (point-min)) |
167 |
(delete-region (point-min) |
(delete-region (point-min) |
168 |
(progn (search-forward "\n*** EOOH ***\n") |
(progn (search-forward "\n*** EOOH ***\n" nil t) |
169 |
(point))) |
(point))) |
170 |
(insert "\^_\^L\n0, unseen,,\n*** EOOH ***\n") |
(insert "\n" rmail-mail-separator) |
171 |
(narrow-to-region (point) |
(narrow-to-region (point) |
172 |
(point-max)) |
(point-max)) |
173 |
(let* ((fill-prefix "") |
(let ((fill-prefix "") |
174 |
(case-fold-search t) |
(case-fold-search t) |
175 |
start |
digest-name type start end separator fun-list sep-list) |
176 |
(digest-name |
(setq digest-name (mail-strip-quoted-names |
177 |
(mail-strip-quoted-names |
(save-restriction |
178 |
(or (save-restriction |
(search-forward "\n\n" nil 'move) |
179 |
(search-forward "\n\n") |
(setq start (point)) |
180 |
(setq start (point)) |
(narrow-to-region (point-min) start) |
181 |
(narrow-to-region (point-min) (point)) |
(or (mail-fetch-field "Reply-To") |
182 |
(goto-char (point-max)) |
(mail-fetch-field "To") |
183 |
(or (mail-fetch-field "Reply-To") |
(mail-fetch-field "Apparently-To") |
184 |
(mail-fetch-field "To") |
(mail-fetch-field "From"))))) |
185 |
(mail-fetch-field "Apparently-To") |
(unless digest-name |
186 |
(mail-fetch-field "From"))) |
(error "Message is not a digest--bad header")) |
187 |
(error "Message is not a digest--bad header"))))) |
|
188 |
(save-excursion |
(setq fun-list rmail-digest-methods) |
189 |
(let (found |
(while (and fun-list |
190 |
(regexps rmail-digest-end-regexps)) |
(null (setq sep-list (funcall (car fun-list))))) |
191 |
(while (and regexps (not found)) |
(setq fun-list (cdr fun-list))) |
192 |
(goto-char (point-max)) |
(unless sep-list |
193 |
(skip-chars-backward " \t\n") |
(error "Message is not a digest--no messages found")) |
194 |
;; compensate for broken un*x digestifiers. Sigh Sigh. |
|
195 |
(while (and (> (point) start) (not found)) |
;;; Split the digest into separate rmail messages |
196 |
(forward-line -1) |
(while sep-list |
197 |
(if (looking-at (car regexps)) |
(let ((start (caar sep-list)) |
198 |
(setq found t)) |
(end (cdar sep-list))) |
199 |
(setq regexps (cdr regexps)))) |
(delete-region start end) |
200 |
(unless found |
(goto-char start) |
201 |
(error "Message is not a digest--no end line")))) |
(insert rmail-mail-separator) |
202 |
(re-search-forward (concat "^" (make-string 55 ?-) "-*\n*")) |
(search-forward "\n\n" (caar (cdr sep-list)) 'move) |
203 |
(replace-match "\^_\^L\n0, unseen,,\n*** EOOH ***\n") |
(save-restriction |
204 |
(save-restriction |
(narrow-to-region end (point)) |
205 |
(narrow-to-region (point) |
(unless (mail-fetch-field "To") |
206 |
(progn (search-forward "\n\n") |
(goto-char start) |
207 |
(point))) |
(insert "To: " digest-name "\n"))) |
208 |
(if (mail-fetch-field "To") nil |
(set-marker start nil) |
209 |
(goto-char (point-min)) |
(set-marker end nil)) |
210 |
(insert "To: " digest-name "\n"))) |
(setq sep-list (cdr sep-list))))) |
211 |
(while (re-search-forward |
|
|
(concat "\n\n" (make-string 27 ?-) "-*\n*") |
|
|
nil t) |
|
|
(replace-match "\n\n\^_\^L\n0, unseen,,\n*** EOOH ***\n") |
|
|
(save-restriction |
|
|
(if (looking-at "End ") |
|
|
(insert "To: " digest-name "\n\n") |
|
|
(narrow-to-region (point) |
|
|
(progn (search-forward "\n\n" |
|
|
nil 'move) |
|
|
(point)))) |
|
|
(if (mail-fetch-field "To") |
|
|
nil |
|
|
(goto-char (point-min)) |
|
|
(insert "To: " digest-name "\n"))) |
|
|
;; Digestifiers may insert `- ' on lines that start with `-'. |
|
|
;; Undo that. |
|
|
(save-excursion |
|
|
(goto-char (point-min)) |
|
|
(if (re-search-forward |
|
|
"\n\n----------------------------*\n*" |
|
|
nil t) |
|
|
(let ((end (point-marker))) |
|
|
(goto-char (point-min)) |
|
|
(while (re-search-forward "^- " end t) |
|
|
(delete-char -2))))) |
|
|
))) |
|
212 |
(setq error nil) |
(setq error nil) |
213 |
(message "Message successfully undigestified") |
(message "Message successfully undigestified") |
214 |
(let ((n rmail-current-message)) |
(let ((n rmail-current-message)) |
222 |
(narrow-to-region (point-min) (1+ (point-max))) |
(narrow-to-region (point-min) (1+ (point-max))) |
223 |
(delete-region (point-min) (point-max)) |
(delete-region (point-min) (point-max)) |
224 |
(rmail-show-message rmail-current-message))))))) |
(rmail-show-message rmail-current-message))))))) |
225 |
|
|
226 |
;;;###autoload |
;;;###autoload |
227 |
(defun unforward-rmail-message () |
(defun unforward-rmail-message () |
228 |
"Extract a forwarded message from the containing message. |
"Extract a forwarded message from the containing message. |
230 |
following the containing message." |
following the containing message." |
231 |
(interactive) |
(interactive) |
232 |
;; If we are in a summary buffer, switch to the Rmail buffer. |
;; If we are in a summary buffer, switch to the Rmail buffer. |
233 |
(with-current-buffer rmail-buffer |
(unwind-protect |
234 |
(narrow-to-region (rmail-msgbeg rmail-current-message) |
(with-current-buffer rmail-buffer |
235 |
(rmail-msgend rmail-current-message)) |
(goto-char (point-min)) |
236 |
(goto-char (point-min)) |
(narrow-to-region (point) |
237 |
(let (beg end (buffer-read-only nil) msg-string who-forwarded-it) |
(save-excursion (search-forward "\n\n") (point))) |
238 |
(setq who-forwarded-it (mail-fetch-field "From")) |
(let ((buffer-read-only nil) |
239 |
(if (re-search-forward "^----" nil t) |
(old-fwd-from (mail-fetch-field "Forwarded-From" nil nil t)) |
240 |
nil |
(old-fwd-date (mail-fetch-field "Forwarded-Date" nil nil t)) |
241 |
(error "No forwarded message")) |
(fwd-from (mail-fetch-field "From")) |
242 |
(forward-line 1) |
(fwd-date (mail-fetch-field "Date")) |
243 |
(setq beg (point)) |
beg end prefix forward-msg) |
244 |
(if (re-search-forward "^----" nil t) |
(narrow-to-region (rmail-msgbeg rmail-current-message) |
245 |
(setq end (match-beginning 0)) |
(rmail-msgend rmail-current-message)) |
246 |
(error "No terminator for forwarded message")) |
(goto-char (point-min)) |
247 |
(widen) |
(cond ((re-search-forward rmail-forward-separator-regex nil t) |
248 |
(setq msg-string (buffer-substring beg end)) |
(forward-line 1) |
249 |
(goto-char (rmail-msgend rmail-current-message)) |
(skip-chars-forward "\n") |
250 |
(narrow-to-region (point) (point)) |
(setq beg (point)) |
251 |
(insert "\^_\^L\n0, unseen,,\n*** EOOH ***\n") |
(setq end (if (re-search-forward "^----.*[^- \t\n]" nil t) |
252 |
(narrow-to-region (point) (point)) |
(match-beginning 0) (point-max))) |
253 |
(insert "Forwarded-by: " who-forwarded-it "\n") |
(setq forward-msg |
254 |
(insert msg-string) |
(replace-regexp-in-string |
255 |
(goto-char (point-min)) |
"^- -" "-" (buffer-substring beg end)))) |
256 |
(while (not (eobp)) |
((and (re-search-forward "^\\(> ?\\)[a-zA-Z-]+: .*\n" nil t) |
257 |
(if (looking-at "- ") |
(setq beg (match-beginning 0)) |
258 |
(delete-region (point) (+ 2 (point)))) |
(setq prefix (match-string-no-properties 1)) |
259 |
(forward-line 1)) |
(goto-char beg) |
260 |
(let ((n rmail-current-message)) |
(looking-at (concat "\\(" prefix ".+\n\\)*" |
261 |
(rmail-forget-messages) |
prefix "Date: .")) |
262 |
(rmail-show-message n) |
(looking-at (concat "\\(" prefix ".+\n\\)*" |
263 |
(if (rmail-summary-exists) |
prefix "From: .+\n" |
264 |
(rmail-select-summary |
"\\(" prefix ".+\n\\)*" |
265 |
(rmail-update-summary))))))) |
"\\(> ?\\)?\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) |
(provide 'undigest) |
309 |
|
|