/[emacs]/emacs/lisp/mail/undigest.el
ViewVC logotype

Diff of /emacs/lisp/mail/undigest.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.23 by rms, Fri Jan 21 03:43:45 2000 UTC revision 1.23.18.1 by miles, Fri Apr 4 06:20:27 2003 UTC
# Line 1  Line 1 
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
# Line 24  Line 25 
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 ()
# Line 47  Leaves original message, deleted, before Line 152  Leaves original message, deleted, before
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))
# Line 144  Leaves original message, deleted, before Line 222  Leaves original message, deleted, before
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.
# Line 152  This puts the forwarded message into a s Line 230  This puts the forwarded message into a s
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    

Legend:
Removed from v.1.23  
changed lines
  Added in v.1.23.18.1

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26