Mercurial > emacs

comparison lisp/mail/undigest.el @ 48868:3395df62dc04

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Now supports MIME too.
author Francesco Potortì <pot@gnu.org>
date Mon, 16 Dec 2002 16:22:41 +0000
parents 770c9bc95b39
children 0d1bd8730873
comparison
equal deleted inserted replaced
48867:1bd259d860a2 48868:3395df62dc04
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 Free Software Foundation, Inc. 3 ;; Copyright (C) 1985, 1986, 1994, 1996, 2002
4 ;; Free Software Foundation, Inc.
4 5
5 ;; Maintainer: FSF 6 ;; Maintainer: FSF
6 ;; Keywords: mail 7 ;; Keywords: mail
7 8
8 ;; This file is part of GNU Emacs. 9 ;; This file is part of GNU Emacs.
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA. 24 ;; Boston, MA 02111-1307, USA.
24 25
25 ;;; Commentary: 26 ;;; Commentary:
26 27
27 ;; See Internet RFC 934 28 ;; See Internet RFC 934 and RFC 1153
28 29
29 ;;; Code: 30 ;;; Code:
30 31
31 (require 'rmail) 32 (require 'rmail)
32 33
33 (defcustom rmail-digest-end-regexps 34 (defconst rmail-digest-methods
34 (list "End of.*Digest.*\n" "End of.*\n") 35 '(rmail-digest-parse-mime
35 "*Regexps matching the end of a digest message." 36 rmail-digest-parse-rfc1153strict
36 :group 'rmail 37 rmail-digest-parse-rfc1153sloppy
37 :type '(repeat regexp)) 38 rmail-digest-parse-rfc934)
39 "List of digest parsing functions, in preference order.
40
41 The functions operate on the current narrowing, and take no argument. A
42 function returns nil if it cannot parse the digest. If it can, it
43 returns a list of cons pairs containing the start and end positions of
44 each undigestified message as markers.")
45
46 (defconst rmail-digest-mail-separator
47 "\^_\^L\n0, unseen,,\n*** EOOH ***\n"
48 "String substituted to the digest separator to create separate messages.")
49
50
51
52 (defun rmail-digest-parse-mime ()
53 (goto-char (point-min))
54 (when (let ((head-end (progn (search-forward "\n\n" nil t) (point))))
55 (goto-char (point-min))
56 (and head-end
57 (re-search-forward
58 (concat
59 "^Content-type: multipart/digest;"
60 "\\s-* boundary=\"?\\([^\";\n]+\\)[\";\n]") head-end t)
61 (search-forward (match-string 1) nil t)))
62 ;; Ok, prolog separator found
63 (let ((start (make-marker))
64 (end (make-marker))
65 (separator (concat "\n--" (match-string 0) "\n\n"))
66 result)
67 (while (search-forward separator nil t)
68 (move-marker start (match-beginning 0))
69 (move-marker end (match-end 0))
70 (add-to-list 'result (cons (copy-marker start) (copy-marker end t))))
71 ;; Return the list of marker pairs
72 (nreverse result))))
73
74 (defun rmail-digest-parse-rfc1153strict ()
75 "Parse following strictly the method defined in RFC 1153.
76 See rmail-digest-methods."
77 (rmail-digest-rfc1153
78 "^-\\{70\\}\n\n"
79 "^\n-\\{30\\}\n\n"
80 "^\n-\\{30\\}\n\nEnd of .* Digest.*\n\\*\\{15,\\}\n+\'"))
81
82 (defun rmail-digest-parse-rfc1153sloppy ()
83 "Parse using the method defined in RFC 1153, allowing for some sloppiness.
84 See rmail-digest-methods."
85 (rmail-digest-rfc1153
86 "^-\\{55,\\}\n\n"
87 "^\n-\\{27,\\}\n\n"
88 "^\n-\\{27,\\}\n\nEnd of"))
89
90 (defun rmail-digest-rfc1153 (prolog-sep message-sep trailer-sep)
91 (goto-char (point-min))
92 (when (re-search-forward prolog-sep nil t)
93 ;; Ok, prolog separator found
94 (let ((start (make-marker))
95 (end (make-marker))
96 separator result)
97 (move-marker start (match-beginning 0))
98 (move-marker end (match-end 0))
99 (setq result (cons (copy-marker start) (copy-marker end t)))
100 (when (re-search-forward message-sep nil t)
101 ;; Ok, at least one message separator found
102 (setq separator (match-string 0))
103 (when (re-search-forward trailer-sep nil t)
104 ;; Wonderful, we found a trailer, too. Now, go on splitting
105 ;; the digest into separate rmail messages
106 (goto-char (cdar result))
107 (while (search-forward separator nil t)
108 (move-marker start (match-beginning 0))
109 (move-marker end (match-end 0))
110 (add-to-list 'result
111 (cons (copy-marker start) (copy-marker end t))))
112 ;; Undo masking of separators inside digestified messages
113 (goto-char (point-min))
114 (while (search-forward
115 (replace-regexp-in-string "\n-" "\n " separator) nil t)
116 (replace-match separator))
117 ;; Return the list of marker pairs
118 (nreverse result))))))
119
120 (defun rmail-digest-parse-rfc934 ()
121 (goto-char (point-min))
122 (when (re-search-forward "^\n?-[^ ].*\n\n?" nil t)
123 ;; Message separator found
124 (let ((start (make-marker))
125 (end (make-marker))
126 (separator (match-string 0))
127 result)
128 (goto-char (point-min))
129 (while (search-forward separator nil t)
130 (move-marker start (match-beginning 0))
131 (move-marker end (match-end 0))
132 (add-to-list 'result (cons (copy-marker start) (copy-marker end t))))
133 ;; Undo masking of separators inside digestified messages
134 (goto-char (point-min))
135 (while (search-forward "\n- -" nil t)
136 (replace-match "\n-"))
137 ;; Return the list of marker pairs
138 (nreverse result))))
139
140
38 141
39 ;;;###autoload 142 ;;;###autoload
40 (defun undigestify-rmail-message () 143 (defun undigestify-rmail-message ()
41 "Break up a digest message into its constituent messages. 144 "Break up a digest message into its constituent messages.
42 Leaves original message, deleted, before the undigestified messages." 145 Leaves original message, deleted, before the undigestified messages."
43 (interactive) 146 (interactive)
44 (with-current-buffer rmail-buffer 147 (with-current-buffer rmail-buffer
45 (widen) 148 (widen)
46 (let ((buffer-read-only nil)
47 (msg-string (buffer-substring (rmail-msgbeg rmail-current-message)
48 (rmail-msgend rmail-current-message))))
49 (goto-char (rmail-msgend rmail-current-message))
50 (narrow-to-region (point) (point))
51 (insert msg-string)
52 (narrow-to-region (point-min) (1- (point-max))))
53 (let ((error t) 149 (let ((error t)
54 (buffer-read-only nil)) 150 (buffer-read-only nil))
151 (goto-char (rmail-msgend rmail-current-message))
152 (let ((msg-copy (buffer-substring (rmail-msgbeg rmail-current-message)
153 (rmail-msgend rmail-current-message))))
154 (narrow-to-region (point) (point))
155 (insert msg-copy))
156 (narrow-to-region (point-min) (1- (point-max)))
55 (unwind-protect 157 (unwind-protect
56 (progn 158 (progn
57 (save-restriction 159 (save-restriction
58 (goto-char (point-min)) 160 (goto-char (point-min))
59 (delete-region (point-min) 161 (delete-region (point-min)
60 (progn (search-forward "\n*** EOOH ***\n") 162 (progn (search-forward "\n*** EOOH ***\n" nil t)
61 (point))) 163 (point)))
62 (insert "\^_\^L\n0, unseen,,\n*** EOOH ***\n") 164 (insert "\n" rmail-digest-mail-separator)
63 (narrow-to-region (point) 165 (narrow-to-region (point)
64 (point-max)) 166 (point-max))
65 (let* ((fill-prefix "") 167 (let ((fill-prefix "")
66 (case-fold-search t) 168 (case-fold-search t)
67 start 169 digest-name type start end separator fun-list sep-list)
68 (digest-name 170 (setq digest-name (mail-strip-quoted-names
69 (mail-strip-quoted-names 171 (save-restriction
70 (or (save-restriction 172 (search-forward "\n\n" nil 'move)
71 (search-forward "\n\n") 173 (setq start (point))
72 (setq start (point)) 174 (narrow-to-region (point-min) start)
73 (narrow-to-region (point-min) (point)) 175 (or (mail-fetch-field "Reply-To")
74 (goto-char (point-max)) 176 (mail-fetch-field "To")
75 (or (mail-fetch-field "Reply-To") 177 (mail-fetch-field "Apparently-To")
76 (mail-fetch-field "To") 178 (mail-fetch-field "From")))))
77 (mail-fetch-field "Apparently-To") 179 (unless digest-name
78 (mail-fetch-field "From"))) 180 (error "Message is not a digest--bad header"))
79 (error "Message is not a digest--bad header"))))) 181
80 (save-excursion 182 (setq fun-list rmail-digest-methods)
81 (let (found 183 (while (and fun-list
82 (regexps rmail-digest-end-regexps)) 184 (null (setq sep-list (funcall (car fun-list)))))
83 (while (and regexps (not found)) 185 (setq fun-list (cdr fun-list)))
84 (goto-char (point-max)) 186 (unless sep-list
85 ;; compensate for broken un*x digestifiers. Sigh Sigh. 187 (error "Message is not a digest--no messages found"))
86 (setq found (re-search-backward 188
87 (concat "^\\(?:" (car regexps) "\\)") 189 ;;; Split the digest into separate rmail messages
88 start t)) 190 (while sep-list
89 (setq regexps (cdr regexps))) 191 (let ((start (caar sep-list))
90 (unless found 192 (end (cdar sep-list)))
91 (error "Message is not a digest--no end line")))) 193 (delete-region start end)
92 (re-search-forward (concat "^" (make-string 55 ?-) "-*\n*")) 194 (goto-char start)
93 (replace-match "\^_\^L\n0, unseen,,\n*** EOOH ***\n") 195 (insert rmail-digest-mail-separator)
94 (save-restriction 196 (search-forward "\n\n" (caar (cdr sep-list)) 'move)
95 (narrow-to-region (point) 197 (save-restriction
96 (progn (search-forward "\n\n") 198 (narrow-to-region end (point))
97 (point))) 199 (unless (mail-fetch-field "To")
98 (if (mail-fetch-field "To") nil 200 (goto-char start)
99 (goto-char (point-min)) 201 (insert "To: " digest-name "\n")))
100 (insert "To: " digest-name "\n"))) 202 (set-marker start nil)
101 (while (re-search-forward 203 (set-marker end nil))
102 (concat "\n\n" (make-string 27 ?-) "-*\n*") 204 (setq sep-list (cdr sep-list)))))
103 nil t) 205
104 (replace-match "\n\n\^_\^L\n0, unseen,,\n*** EOOH ***\n")
105 (save-restriction
106 (if (looking-at "End ")
107 (insert "To: " digest-name "\n\n")
108 (narrow-to-region (point)
109 (progn (search-forward "\n\n"
110 nil 'move)
111 (point))))
112 (if (mail-fetch-field "To")
113 nil
114 (goto-char (point-min))
115 (insert "To: " digest-name "\n")))
116 ;; Digestifiers may insert `- ' on lines that start with `-'.
117 ;; Undo that.
118 (save-excursion
119 (goto-char (point-min))
120 (if (re-search-forward
121 "\n\n----------------------------*\n*"
122 nil t)
123 (let ((end (point-marker)))
124 (goto-char (point-min))
125 (while (re-search-forward "^- " end t)
126 (delete-char -2)))))
127 )))
128 (setq error nil) 206 (setq error nil)
129 (message "Message successfully undigestified") 207 (message "Message successfully undigestified")
130 (let ((n rmail-current-message)) 208 (let ((n rmail-current-message))
131 (rmail-forget-messages) 209 (rmail-forget-messages)
132 (rmail-show-message n) 210 (rmail-show-message n)