Mercurial > emacs
comparison lisp/mail/undigest.el @ 101827:ec4427ac212e
(rmail-mail-separator): Delete.
(undigestify-rmail-message, unforward-rmail-message): Update for mbox Rmail.
author | Glenn Morris <rgm@gnu.org> |
---|---|
date | Fri, 06 Feb 2009 03:58:20 +0000 |
parents | a9dc0e7c3f2b |
children | 6a35503cf20b |
comparison
equal
deleted
inserted
replaced
101826:8eb4b5dc9511 | 101827:ec4427ac212e |
---|---|
1 ;;; undigest.el --- digest-cracking support for the RMAIL mail reader | 1 ;;; undigest.el --- digest-cracking support for the RMAIL mail reader |
2 | 2 |
3 ;; Copyright (C) 1985, 1986, 1994, 1996, 2001, 2002, 2003, 2004, | 3 ;; Copyright (C) 1985, 1986, 1994, 1996, 2001, 2002, 2003, 2004, 2005, |
4 ;; 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. | 4 ;; 2006, 2007, 2008, 2009 Free Software Foundation, Inc. |
5 | 5 |
6 ;; Maintainer: FSF | 6 ;; Maintainer: FSF |
7 ;; Keywords: mail | 7 ;; Keywords: mail |
8 | 8 |
9 ;; This file is part of GNU Emacs. | 9 ;; This file is part of GNU Emacs. |
21 ;; You should have received a copy of the GNU General Public License | 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/>. | 22 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
23 | 23 |
24 ;;; Commentary: | 24 ;;; Commentary: |
25 | 25 |
26 ;; See Internet RFC 934 and RFC 1153 | 26 ;; See Internet RFC 934 and RFC 1153. |
27 ;; Also limited support for MIME digest encapsulation | 27 ;; Also limited support for MIME digest encapsulation. |
28 | 28 |
29 ;;; Code: | 29 ;;; Code: |
30 | 30 |
31 (require 'rmail) | 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 | 32 |
37 (defcustom rmail-forward-separator-regex | 33 (defcustom rmail-forward-separator-regex |
38 "^----.*\\([Ff]orwarded\\|[Oo]riginal\\).*[Mm]essage" | 34 "^----.*\\([Ff]orwarded\\|[Oo]riginal\\).*[Mm]essage" |
39 "*Regexp to match the string that introduces forwarded messages. | 35 "*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. | 36 This is not a header, but a string contained in the body of the message. |
57 | 53 |
58 (defun rmail-digest-parse-mime () | 54 (defun rmail-digest-parse-mime () |
59 (goto-char (point-min)) | 55 (goto-char (point-min)) |
60 (when (let ((head-end (progn (search-forward "\n\n" nil t) (point)))) | 56 (when (let ((head-end (progn (search-forward "\n\n" nil t) (point)))) |
61 (goto-char (point-min)) | 57 (goto-char (point-min)) |
62 (and head-end | 58 (and head-end ; FIXME always true |
63 (re-search-forward | 59 (re-search-forward |
64 (concat | 60 (concat |
65 "^Content-type: multipart/digest;" | 61 "^Content-type: multipart/digest;" |
66 "\\s-* boundary=\"?\\([^\";\n]+\\)[\";\n]") head-end t) | 62 "\\s-* boundary=\"?\\([^\";\n]+\\)[\";\n]") head-end t) |
67 (search-forward (match-string 1) nil t))) | 63 (search-forward (match-string 1) nil t))) |
156 ;;;###autoload | 152 ;;;###autoload |
157 (defun undigestify-rmail-message () | 153 (defun undigestify-rmail-message () |
158 "Break up a digest message into its constituent messages. | 154 "Break up a digest message into its constituent messages. |
159 Leaves original message, deleted, before the undigestified messages." | 155 Leaves original message, deleted, before the undigestified messages." |
160 (interactive) | 156 (interactive) |
161 (with-current-buffer rmail-buffer | 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)) | |
162 (widen) | 163 (widen) |
163 (let ((error t) | 164 (let ((error t) |
164 (buffer-read-only nil)) | 165 (buffer-read-only nil)) |
165 (goto-char (rmail-msgend rmail-current-message)) | 166 (goto-char msgend) |
166 (let ((msg-copy (buffer-substring (rmail-msgbeg rmail-current-message) | 167 (let ((msg-copy (buffer-substring-no-properties msgbeg msgend))) |
167 (rmail-msgend rmail-current-message)))) | |
168 (narrow-to-region (point) (point)) | 168 (narrow-to-region (point) (point)) |
169 (insert msg-copy)) | 169 (insert "\n" msg-copy)) |
170 (narrow-to-region (point-min) (1- (point-max))) | 170 (goto-char (point-min)) |
171 (unwind-protect | 171 (unwind-protect |
172 (progn | 172 (progn |
173 (save-restriction | 173 (let ((fill-prefix "") |
174 (goto-char (point-min)) | 174 (case-fold-search t) |
175 (delete-region (point-min) | 175 digest-name fun-list sep-list start end) |
176 (progn (search-forward "\n*** EOOH ***\n" nil t) | 176 (setq digest-name (mail-strip-quoted-names |
177 (point))) | 177 (save-restriction |
178 (insert "\n" rmail-mail-separator) | 178 (search-forward "\n\n" nil 'move) |
179 (narrow-to-region (point) | 179 (narrow-to-region (point-min) (point)) |
180 (point-max)) | 180 (or (mail-fetch-field "Reply-To") |
181 (let ((fill-prefix "") | 181 (mail-fetch-field "To") |
182 (case-fold-search t) | 182 (mail-fetch-field "Apparently-To") |
183 digest-name type start end separator fun-list sep-list) | 183 (mail-fetch-field "From"))))) |
184 (setq digest-name (mail-strip-quoted-names | 184 (unless digest-name |
185 (save-restriction | 185 (error "Message is not a digest--bad header")) |
186 (search-forward "\n\n" nil 'move) | 186 (setq fun-list rmail-digest-methods) |
187 (setq start (point)) | 187 (while (and fun-list |
188 (narrow-to-region (point-min) start) | 188 (null (setq sep-list (funcall (car fun-list))))) |
189 (or (mail-fetch-field "Reply-To") | 189 (setq fun-list (cdr fun-list))) |
190 (mail-fetch-field "To") | 190 (unless sep-list |
191 (mail-fetch-field "Apparently-To") | 191 (error "Message is not a digest--no messages found")) |
192 (mail-fetch-field "From"))))) | 192 ;; Split the digest into separate rmail messages. |
193 (unless digest-name | 193 (while sep-list |
194 (error "Message is not a digest--bad header")) | 194 (setq start (caar sep-list) |
195 | 195 end (cdar sep-list)) |
196 (setq fun-list rmail-digest-methods) | 196 (delete-region start end) |
197 (while (and fun-list | 197 (goto-char start) |
198 (null (setq sep-list (funcall (car fun-list))))) | 198 (search-forward "\n\n" (caar (cdr sep-list)) 'move) |
199 (setq fun-list (cdr fun-list))) | 199 (save-restriction |
200 (unless sep-list | 200 (narrow-to-region end (point)) |
201 (error "Message is not a digest--no messages found")) | 201 (goto-char (point-min)) |
202 | 202 (insert "\nFrom rmail@localhost " (current-time-string) "\n") |
203 ;;; Split the digest into separate rmail messages | 203 (save-excursion |
204 (while sep-list | 204 (forward-line -1) |
205 (let ((start (caar sep-list)) | 205 (rmail-add-mbox-headers)) |
206 (end (cdar sep-list))) | 206 (unless (mail-fetch-field "To") |
207 (delete-region start end) | 207 (insert "To: " digest-name "\n"))) |
208 (goto-char start) | 208 (set-marker start nil) |
209 (insert rmail-mail-separator) | 209 (set-marker end nil) |
210 (search-forward "\n\n" (caar (cdr sep-list)) 'move) | 210 (setq sep-list (cdr sep-list)))) |
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) | 211 (setq error nil) |
221 (message "Message successfully undigestified") | 212 (message "Message successfully undigestified") |
222 (let ((n rmail-current-message)) | 213 (set-buffer buff) |
223 (rmail-forget-messages) | 214 (rmail-swap-buffers-maybe) |
224 (rmail-show-message n) | 215 (goto-char (point-max)) |
225 (rmail-delete-forward) | 216 (rmail-set-message-counters) |
226 (if (rmail-summary-exists) | 217 (set-buffer-modified-p t) |
227 (rmail-select-summary | 218 (rmail-show-message current) |
228 (rmail-update-summary))))) | 219 (rmail-delete-forward) |
229 (cond (error | 220 (if (rmail-summary-exists) |
230 (narrow-to-region (point-min) (1+ (point-max))) | 221 (rmail-select-summary (rmail-update-summary)))) |
231 (delete-region (point-min) (point-max)) | 222 (when error |
232 (rmail-show-message rmail-current-message))))))) | 223 (delete-region (point-min) (point-max)) |
224 (set-buffer buff) | |
225 (rmail-show-message current)))))) | |
233 | 226 |
234 ;;;###autoload | 227 ;;;###autoload |
235 (defun unforward-rmail-message () | 228 (defun unforward-rmail-message () |
236 "Extract a forwarded message from the containing message. | 229 "Extract a forwarded message from the containing message. |
237 This puts the forwarded message into a separate rmail message | 230 This puts the forwarded message into a separate rmail message |
238 following the containing message." | 231 following the containing message." |
239 (interactive) | 232 (interactive) |
240 ;; If we are in a summary buffer, switch to the Rmail buffer. | 233 (set-buffer rmail-buffer) |
241 (unwind-protect | 234 (let ((buff (current-buffer)) |
242 (with-current-buffer rmail-buffer | 235 (current rmail-current-message) |
243 (goto-char (point-min)) | 236 (beg (rmail-msgbeg rmail-current-message)) |
244 (narrow-to-region (point) | 237 (msgend (rmail-msgend rmail-current-message)) |
245 (save-excursion (search-forward "\n\n") (point))) | 238 (error t)) |
246 (let ((buffer-read-only nil) | 239 (unwind-protect |
247 (old-fwd-from (mail-fetch-field "Forwarded-From" nil nil t)) | 240 (progn |
248 (old-fwd-date (mail-fetch-field "Forwarded-Date" nil nil t)) | 241 (if (rmail-buffers-swapped-p) (set-buffer rmail-view-buffer)) |
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) | 242 (widen) |
286 (goto-char (rmail-msgend rmail-current-message)) | 243 (goto-char beg) |
287 (narrow-to-region (point) (point)) | 244 (search-forward "\n\n" msgend) |
288 (insert rmail-mail-separator) | 245 (narrow-to-region beg (point)) |
289 (narrow-to-region (point) (point)) | 246 (let ((old-fwd-from (mail-fetch-field "Forwarded-From" nil nil t)) |
290 (while old-fwd-from | 247 (old-fwd-date (mail-fetch-field "Forwarded-Date" nil nil t)) |
291 (insert "Forwarded-From: " (car old-fwd-from) "\n") | 248 (fwd-from (mail-fetch-field "From")) |
292 (insert "Forwarded-Date: " (car old-fwd-date) "\n") | 249 (fwd-date (mail-fetch-field "Date")) |
293 (setq old-fwd-from (cdr old-fwd-from)) | 250 (buffer-read-only nil) |
294 (setq old-fwd-date (cdr old-fwd-date))) | 251 prefix forward-msg end) |
295 (insert "Forwarded-From: " fwd-from "\n") | 252 (widen) |
296 (insert "Forwarded-Date: " fwd-date "\n") | 253 (narrow-to-region beg msgend) |
297 (insert forward-msg) | 254 (cond ((re-search-forward rmail-forward-separator-regex nil t) |
298 (save-restriction | 255 (forward-line 1) |
299 (goto-char (point-min)) | 256 (skip-chars-forward "\n") |
300 (re-search-forward "\n$" nil 'move) | 257 (setq beg (point)) |
301 (narrow-to-region (point-min) (point)) | 258 (setq end (if (re-search-forward "^----.*[^- \t\n]" nil t) |
259 (match-beginning 0) (point-max))) | |
260 (setq forward-msg | |
261 (replace-regexp-in-string | |
262 "^- -" "-" (buffer-substring beg end)))) | |
263 ((and (re-search-forward "^\\(> ?\\)[a-zA-Z-]+: .*\n" nil t) | |
264 (setq beg (match-beginning 0)) | |
265 (setq prefix (match-string-no-properties 1)) | |
266 (goto-char beg) | |
267 (looking-at (concat "\\(" prefix ".+\n\\)*" | |
268 prefix "Date: .")) | |
269 (looking-at (concat "\\(" prefix ".+\n\\)*" | |
270 prefix "From: .+\n" | |
271 "\\(" prefix ".+\n\\)*" | |
272 "\\(> ?\\)?\n" prefix))) | |
273 (re-search-forward "^[^>\n]" nil 'move) | |
274 (backward-char) | |
275 (skip-chars-backward " \t\n") | |
276 (forward-line 1) | |
277 (setq end (point)) | |
278 (setq forward-msg | |
279 (replace-regexp-in-string | |
280 (if (string= prefix ">") "^>" "> ?") | |
281 "" (buffer-substring beg end)))) | |
282 (t | |
283 (error "No forwarded message found"))) | |
284 (widen) | |
285 (goto-char msgend) | |
286 ;; Insert a fake From line. | |
287 ;; FIXME we could construct one using the From and Date headers | |
288 ;; of the forwarded message - is it worth it? | |
289 (insert "\n\nFrom rmail@localhost " (current-time-string) "\n") | |
290 (setq beg (point)) ; start of header | |
291 (while old-fwd-from | |
292 (insert "Forwarded-From: " (car old-fwd-from) "\n") | |
293 (insert "Forwarded-Date: " (car old-fwd-date) "\n") | |
294 (setq old-fwd-from (cdr old-fwd-from)) | |
295 (setq old-fwd-date (cdr old-fwd-date))) | |
296 (insert "Forwarded-From: " fwd-from "\n") | |
297 (insert "Forwarded-Date: " fwd-date "\n") | |
298 (insert forward-msg "\n") | |
299 (goto-char beg) | |
300 (re-search-forward "\n$" nil 'move) ; end of header | |
301 (narrow-to-region beg (point)) | |
302 (goto-char (point-min)) | 302 (goto-char (point-min)) |
303 (while (not (eobp)) | 303 (while (not (eobp)) |
304 (unless (looking-at "^[a-zA-Z-]+: ") | 304 (unless (looking-at "^[a-zA-Z-]+: ") |
305 (insert "\t")) | 305 (insert "\t")) |
306 (forward-line))) | 306 (forward-line)) |
307 (goto-char (point-min)))) | 307 (widen) |
308 (let ((n rmail-current-message)) | 308 (goto-char beg) |
309 (rmail-forget-messages) | 309 (forward-line -1) |
310 (rmail-show-message n)) | 310 (rmail-add-mbox-headers)) ; marks as unseen |
311 (if (rmail-summary-exists) | 311 (setq error nil) |
312 (rmail-select-summary | 312 (set-buffer buff) |
313 (rmail-update-summary))))) | 313 (rmail-swap-buffers-maybe) |
314 | 314 (goto-char (point-max)) |
315 (rmail-set-message-counters) | |
316 (set-buffer-modified-p t) | |
317 (rmail-show-message current) | |
318 (if (rmail-summary-exists) | |
319 (rmail-select-summary (rmail-update-summary)))) | |
320 (when error | |
321 (set-buffer buff) | |
322 (rmail-show-message current))))) | |
315 | 323 |
316 (provide 'undigest) | 324 (provide 'undigest) |
317 | 325 |
318 ;; arch-tag: 3a28b9fb-c1f5-43ef-9278-285f3e4b874d | 326 ;; arch-tag: 3a28b9fb-c1f5-43ef-9278-285f3e4b874d |
319 ;;; undigest.el ends here | 327 ;;; undigest.el ends here |