|
0
|
1 ;;; Message encapsulation
|
|
98
|
2 ;;; Copyright (C) 1989, 1990, 1993, 1994, 1997 Kyle E. Jones
|
|
0
|
3 ;;;
|
|
|
4 ;;; This program is free software; you can redistribute it and/or modify
|
|
|
5 ;;; it under the terms of the GNU General Public License as published by
|
|
|
6 ;;; the Free Software Foundation; either version 1, or (at your option)
|
|
|
7 ;;; any later version.
|
|
|
8 ;;;
|
|
|
9 ;;; This program is distributed in the hope that it will be useful,
|
|
|
10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
12 ;;; GNU General Public License for more details.
|
|
|
13 ;;;
|
|
|
14 ;;; You should have received a copy of the GNU General Public License
|
|
|
15 ;;; along with this program; if not, write to the Free Software
|
|
|
16 ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
|
17
|
|
|
18 (provide 'vm-digest)
|
|
|
19
|
|
|
20 (defun vm-no-frills-encapsulate-message (m keep-list discard-regexp)
|
|
|
21 "Encapsulate a message M for forwarding, simply.
|
|
|
22 No message encapsulation standard is used. The message is
|
|
|
23 inserted at point in the current buffer, surrounded by two dashed
|
|
|
24 start/end separator lines. Point is not moved.
|
|
|
25
|
|
|
26 M should be a message struct for a real message, not a virtual message.
|
|
|
27 This is the message that will be encapsulated.
|
|
|
28 KEEP-LIST should be a list of regexps matching headers to keep.
|
|
|
29 DISCARD-REGEXP should be a regexp that matches headers to be discarded.
|
|
|
30 KEEP-LIST and DISCARD-REGEXP are used to order and trim the headers
|
|
|
31 to be forwarded. See the docs for vm-reorder-message-headers
|
|
|
32 to find out how KEEP-LIST and DISCARD-REGEXP are used."
|
|
|
33 (let ((target-buffer (current-buffer))
|
|
|
34 source-buffer)
|
|
|
35 (save-restriction
|
|
|
36 ;; narrow to a zero length region to avoid interacting
|
|
|
37 ;; with anything that might have already been inserted
|
|
|
38 ;; into the buffer.
|
|
|
39 (narrow-to-region (point) (point))
|
|
|
40 (insert "------- start of forwarded message -------\n")
|
|
|
41 (setq source-buffer (vm-buffer-of m))
|
|
|
42 (save-excursion
|
|
|
43 (set-buffer source-buffer)
|
|
|
44 (save-restriction
|
|
|
45 (widen)
|
|
|
46 (save-excursion
|
|
|
47 (set-buffer target-buffer)
|
|
|
48 (let ((beg (point)))
|
|
|
49 (insert-buffer-substring source-buffer (vm-headers-of m)
|
|
|
50 (vm-text-end-of m))
|
|
|
51 (goto-char beg)
|
|
|
52 (vm-reorder-message-headers nil nil "\\(X-VM-\\|Status:\\)")
|
|
|
53 (vm-reorder-message-headers nil keep-list discard-regexp)))))
|
|
|
54 (goto-char (point-max))
|
|
|
55 (insert "------- end of forwarded message -------\n"))))
|
|
|
56
|
|
98
|
57 (defun vm-mime-encapsulate-messages (message-list keep-list discard-regexp)
|
|
|
58 "Encapsulate the messages in MESSAGE-LIST as per the MIME spec.
|
|
|
59 The resulting digest is inserted at point in the current buffer.
|
|
|
60 Point is not moved.
|
|
|
61
|
|
|
62 MESSAGE-LIST should be a list of message structs (real or virtual).
|
|
|
63 These are the messages that will be encapsulated.
|
|
|
64 KEEP-LIST should be a list of regexps matching headers to keep.
|
|
|
65 DISCARD-REGEXP should be a regexp that matches headers to be discarded.
|
|
|
66 KEEP-LIST and DISCARD-REGEXP are used to order and trim the headers
|
|
|
67 to be forwarded. See the docs for vm-reorder-message-headers
|
|
|
68 to find out how KEEP-LIST and DISCARD-REGEXP are used.
|
|
|
69
|
|
|
70 Returns the multipart boundary parameter (string) that should be used
|
|
|
71 in the Content-Type header."
|
|
|
72 (if message-list
|
|
|
73 (let ((target-buffer (current-buffer))
|
|
|
74 (boundary-positions nil)
|
|
|
75 (mlist message-list)
|
|
|
76 (mime-keep-list (append keep-list vm-mime-header-list))
|
|
|
77 boundary source-buffer m start n beg)
|
|
|
78 (save-restriction
|
|
|
79 ;; narrow to a zero length region to avoid interacting
|
|
|
80 ;; with anything that might have already been inserted
|
|
|
81 ;; into the buffer.
|
|
|
82 (narrow-to-region (point) (point))
|
|
|
83 (setq start (point))
|
|
|
84 (while mlist
|
|
|
85 (setq boundary-positions (cons (point-marker) boundary-positions))
|
|
|
86 (setq m (vm-real-message-of (car mlist))
|
|
|
87 source-buffer (vm-buffer-of m))
|
|
|
88 (setq beg (point))
|
|
|
89 (vm-insert-region-from-buffer source-buffer (vm-headers-of m)
|
|
|
90 (vm-text-end-of m))
|
|
|
91 (goto-char beg)
|
|
|
92 (vm-reorder-message-headers nil nil "\\(X-VM-\\|Status:\\)")
|
|
|
93 (vm-reorder-message-headers
|
|
|
94 nil (if (vm-mime-plain-message-p m)
|
|
|
95 keep-list
|
|
|
96 mime-keep-list)
|
|
|
97 discard-regexp)
|
|
|
98 (goto-char (point-max))
|
|
|
99 (setq mlist (cdr mlist)))
|
|
|
100 (goto-char start)
|
|
|
101 (setq boundary (vm-mime-make-multipart-boundary))
|
|
|
102 (while (re-search-forward (concat "^--"
|
|
|
103 (regexp-quote boundary)
|
|
|
104 "\\(--\\)?$")
|
|
|
105 nil t)
|
|
|
106 (setq boundary (vm-mime-make-multipart-boundary))
|
|
|
107 (goto-char start))
|
|
|
108 (goto-char (point-max))
|
|
|
109 (insert "\n--" boundary "--\n")
|
|
|
110 (while boundary-positions
|
|
|
111 (goto-char (car boundary-positions))
|
|
|
112 (insert "\n--" boundary "\n\n")
|
|
|
113 (setq boundary-positions (cdr boundary-positions)))
|
|
|
114 (goto-char start)
|
|
|
115 (setq n (length message-list))
|
|
|
116 (insert (format "This is a %s%sMIME encapsulation.\n"
|
|
|
117 (if (cdr message-list)
|
|
|
118 "digest, "
|
|
|
119 "forwarded message, ")
|
|
|
120 (if (cdr message-list)
|
|
|
121 (format "%d messages, " n)
|
|
|
122 "")))
|
|
|
123 (goto-char start))
|
|
|
124 boundary )))
|
|
|
125
|
|
|
126 (defun vm-mime-burst-message (m)
|
|
|
127 "Burst messages from the digest message M.
|
|
|
128 M should be a message struct for a real message.
|
|
|
129 MIME encoding is expected. The message content type
|
|
|
130 must be either message/* or multipart/digest."
|
|
|
131 (let ((ident-header nil)
|
|
|
132 (layout (vm-mm-layout m)))
|
|
|
133 (if vm-digest-identifier-header-format
|
|
|
134 (setq ident-header (vm-sprintf 'vm-digest-identifier-header-format m)))
|
|
|
135 (vm-mime-burst-layout layout ident-header)))
|
|
|
136
|
|
|
137 (defun vm-mime-burst-layout (layout ident-header)
|
|
|
138 (let ((work-buffer nil)
|
|
|
139 (folder-buffer (current-buffer))
|
|
|
140 start part-list
|
|
|
141 (folder-type vm-folder-type))
|
|
|
142 (unwind-protect
|
|
|
143 (vm-save-restriction
|
|
|
144 (save-excursion
|
|
|
145 (widen)
|
|
|
146 (setq work-buffer (generate-new-buffer "*vm-work*"))
|
|
|
147 (buffer-disable-undo work-buffer)
|
|
|
148 (set-buffer work-buffer)
|
|
|
149 (cond ((not (vectorp layout))
|
|
|
150 (error "Not a MIME message"))
|
|
|
151 ((vm-mime-types-match "message"
|
|
|
152 (car (vm-mm-layout-type layout)))
|
|
|
153 (insert (vm-leading-message-separator folder-type))
|
|
|
154 (and ident-header (insert ident-header))
|
|
|
155 (setq start (point))
|
|
|
156 (vm-mime-insert-mime-body layout)
|
|
|
157 (vm-munge-message-separators folder-type start (point))
|
|
|
158 (insert (vm-trailing-message-separator folder-type)))
|
|
|
159 ((vm-mime-types-match "multipart/digest"
|
|
|
160 (car (vm-mm-layout-type layout)))
|
|
|
161 (setq part-list (vm-mm-layout-parts layout))
|
|
|
162 (while part-list
|
|
|
163 ;; Maybe we should verify that each part is
|
|
|
164 ;; of type message/rfc822 in here. But it
|
|
|
165 ;; seems more useful to just copy whatever
|
|
|
166 ;; the contents are and let teh user see the
|
|
|
167 ;; goop, whatever type it really is.
|
|
|
168 (insert (vm-leading-message-separator folder-type))
|
|
|
169 (and ident-header (insert ident-header))
|
|
|
170 (setq start (point))
|
|
|
171 (vm-mime-insert-mime-body (car part-list))
|
|
|
172 (vm-munge-message-separators folder-type start (point))
|
|
|
173 (insert (vm-trailing-message-separator folder-type))
|
|
|
174 (setq part-list (cdr part-list))))
|
|
|
175 (t (error
|
|
|
176 "MIME type is not multipart/digest or message/rfc822")))
|
|
|
177 ;; do header conversions.
|
|
|
178 (let ((vm-folder-type folder-type))
|
|
|
179 (goto-char (point-min))
|
|
|
180 (while (vm-find-leading-message-separator)
|
|
|
181 (vm-skip-past-leading-message-separator)
|
|
|
182 (vm-convert-folder-type-headers folder-type folder-type)
|
|
|
183 (vm-find-trailing-message-separator)
|
|
|
184 (vm-skip-past-trailing-message-separator)))
|
|
|
185 ;; now insert the messages into the folder buffer
|
|
|
186 (cond ((not (zerop (buffer-size)))
|
|
|
187 (set-buffer folder-buffer)
|
|
|
188 (let ((old-buffer-modified-p (buffer-modified-p))
|
|
|
189 (buffer-read-only nil)
|
|
|
190 (inhibit-quit t))
|
|
|
191 (goto-char (point-max))
|
|
|
192 (insert-buffer-substring work-buffer)
|
|
|
193 (set-buffer-modified-p old-buffer-modified-p)
|
|
|
194 ;; return non-nil so caller knows we found some messages
|
|
|
195 t ))
|
|
|
196 ;; return nil so the caller knows we didn't find anything
|
|
|
197 (t nil))))
|
|
|
198 (and work-buffer (kill-buffer work-buffer)))))
|
|
|
199
|
|
0
|
200 (defun vm-rfc934-char-stuff-region (start end)
|
|
|
201 "Quote RFC 934 message separators between START and END.
|
|
|
202 START and END are buffer positions in the current buffer.
|
|
|
203 Lines beginning with `-' in the region have `- ' prepended to them."
|
|
|
204 (setq end (vm-marker end))
|
|
|
205 (save-excursion
|
|
|
206 (goto-char start)
|
|
|
207 (while (and (< (point) end) (re-search-forward "^-" end t))
|
|
|
208 (replace-match "- -" t t)))
|
|
|
209 (set-marker end nil))
|
|
|
210
|
|
|
211 (defun vm-rfc934-char-unstuff-region (start end)
|
|
|
212 "Unquote lines in between START and END as per RFC 934.
|
|
|
213 START and END are buffer positions in the current buffer.
|
|
|
214 Lines beginning with `- ' in the region have that string stripped
|
|
|
215 from them."
|
|
|
216 (setq end (vm-marker end))
|
|
|
217 (save-excursion
|
|
|
218 (goto-char start)
|
|
|
219 (while (and (< (point) end) (re-search-forward "^- " end t))
|
|
|
220 (replace-match "" t t)
|
|
|
221 (forward-char)))
|
|
|
222 (set-marker end nil))
|
|
|
223
|
|
|
224 (defun vm-rfc934-encapsulate-messages (message-list keep-list discard-regexp)
|
|
|
225 "Encapsulate the messages in MESSAGE-LIST as per RFC 934.
|
|
|
226 The resulting digest is inserted at point in the current buffer.
|
|
|
227 Point is not moved.
|
|
|
228
|
|
|
229 MESSAGE-LIST should be a list of message structs (real or virtual).
|
|
|
230 These are the messages that will be encapsulated.
|
|
|
231 KEEP-LIST should be a list of regexps matching headers to keep.
|
|
|
232 DISCARD-REGEXP should be a regexp that matches headers to be discarded.
|
|
|
233 KEEP-LIST and DISCARD-REGEXP are used to order and trim the headers
|
|
|
234 to be forwarded. See the docs for vm-reorder-message-headers
|
|
|
235 to find out how KEEP-LIST and DISCARD-REGEXP are used."
|
|
|
236 (if message-list
|
|
|
237 (let ((target-buffer (current-buffer))
|
|
98
|
238 (mime-keep-list (append keep-list vm-mime-header-list))
|
|
0
|
239 (mlist message-list)
|
|
|
240 source-buffer m start n)
|
|
|
241 (save-restriction
|
|
|
242 ;; narrow to a zero length region to avoid interacting
|
|
|
243 ;; with anything that might have already been inserted
|
|
|
244 ;; into the buffer.
|
|
|
245 (narrow-to-region (point) (point))
|
|
|
246 (setq start (point))
|
|
|
247 (while mlist
|
|
|
248 (insert "---------------\n")
|
|
|
249 (setq m (vm-real-message-of (car mlist))
|
|
|
250 source-buffer (vm-buffer-of m))
|
|
|
251 (save-excursion
|
|
|
252 (set-buffer source-buffer)
|
|
|
253 (save-restriction
|
|
|
254 (widen)
|
|
|
255 (save-excursion
|
|
|
256 (set-buffer target-buffer)
|
|
|
257 (let ((beg (point)))
|
|
|
258 (insert-buffer-substring source-buffer (vm-headers-of m)
|
|
|
259 (vm-text-end-of m))
|
|
|
260 (goto-char beg)
|
|
|
261 (vm-reorder-message-headers nil nil
|
|
|
262 "\\(X-VM-\\|Status:\\)")
|
|
98
|
263 (vm-reorder-message-headers
|
|
|
264 nil (if (vm-mime-plain-message-p m)
|
|
|
265 keep-list
|
|
|
266 mime-keep-list)
|
|
|
267 discard-regexp)
|
|
0
|
268 (vm-rfc934-char-stuff-region beg (point-max))))))
|
|
|
269 (goto-char (point-max))
|
|
|
270 (insert "---------------")
|
|
|
271 (setq mlist (cdr mlist)))
|
|
|
272 (delete-region (point) (progn (beginning-of-line) (point)))
|
|
|
273 (insert "------- end -------\n")
|
|
|
274 (goto-char start)
|
|
|
275 (delete-region (point) (progn (forward-line 1) (point)))
|
|
|
276 (setq n (length message-list))
|
|
|
277 (insert (format "------- start of %s%s(RFC 934 encapsulation) -------\n"
|
|
|
278 (if (cdr message-list)
|
|
|
279 "digest "
|
|
|
280 "forwarded message ")
|
|
|
281 (if (cdr message-list)
|
|
|
282 (format "(%d messages) " n)
|
|
|
283 "")))
|
|
|
284 (goto-char start)))))
|
|
|
285
|
|
|
286 (defun vm-rfc1153-char-stuff-region (start end)
|
|
|
287 "Quote RFC 1153 message separators between START and END.
|
|
|
288 START and END are buffer positions in the current buffer.
|
|
|
289 Lines consisting only of 30 hyphens have the first hyphen
|
|
|
290 converted to a space."
|
|
|
291 (setq end (vm-marker end))
|
|
|
292 (save-excursion
|
|
|
293 (goto-char start)
|
|
|
294 (while (and (< (point) end)
|
|
|
295 (re-search-forward "^------------------------------$" end t))
|
|
|
296 (replace-match " -----------------------------" t t)))
|
|
|
297 (set-marker end nil))
|
|
|
298
|
|
|
299 (defun vm-rfc1153-char-unstuff-region (start end)
|
|
|
300 "Unquote lines in between START and END as per RFC 1153.
|
|
|
301 START and END are buffer positions in the current buffer.
|
|
|
302 Lines consisting only of a space following by 29 hyphens have the space
|
|
|
303 converted to a hyphen."
|
|
|
304 (setq end (vm-marker end))
|
|
|
305 (save-excursion
|
|
|
306 (goto-char start)
|
|
|
307 (while (and (< (point) end)
|
|
|
308 (re-search-forward "^ -----------------------------$" end t))
|
|
|
309 (replace-match "------------------------------" t t)))
|
|
|
310 (set-marker end nil))
|
|
|
311
|
|
|
312 (defun vm-rfc1153-encapsulate-messages (message-list keep-list discard-regexp)
|
|
|
313 "Encapsulate the messages in MESSAGE-LIST as per RFC 1153.
|
|
|
314 The resulting digest is inserted at point in the current buffer.
|
|
|
315 Point is not moved.
|
|
|
316
|
|
|
317 MESSAGE-LIST should be a list of message structs (real or virtual).
|
|
|
318 These are the messages that will be encapsulated.
|
|
|
319 KEEP-LIST should be a list of regexps matching headers to keep.
|
|
|
320 DISCARD-REGEXP should be a regexp that matches headers to be discarded.
|
|
|
321 KEEP-LIST and DISCARD-REGEXP are used to order and trim the headers
|
|
|
322 to be forwarded. See the docs for vm-reorder-message-headers
|
|
|
323 to find out how KEEP-LIST and DISCARD-REGEXP are used."
|
|
|
324 (if message-list
|
|
|
325 (let ((target-buffer (current-buffer))
|
|
98
|
326 (mime-keep-list (append keep-list vm-mime-header-list))
|
|
0
|
327 (mlist message-list)
|
|
|
328 source-buffer m start)
|
|
|
329 (save-restriction
|
|
|
330 ;; narrow to a zero length region to avoid interacting
|
|
|
331 ;; with anything that might have already been inserted
|
|
|
332 ;; into the buffer.
|
|
|
333 (narrow-to-region (point) (point))
|
|
|
334 (setq start (point))
|
|
|
335 (while mlist
|
|
|
336 (insert "---------------\n\n")
|
|
|
337 (setq m (vm-real-message-of (car mlist))
|
|
|
338 source-buffer (vm-buffer-of m))
|
|
|
339 (save-excursion
|
|
|
340 (set-buffer source-buffer)
|
|
|
341 (save-restriction
|
|
|
342 (widen)
|
|
|
343 (save-excursion
|
|
|
344 (set-buffer target-buffer)
|
|
|
345 (let ((beg (point)))
|
|
|
346 (insert-buffer-substring source-buffer (vm-headers-of m)
|
|
|
347 (vm-text-end-of m))
|
|
|
348 (goto-char beg)
|
|
|
349 (vm-reorder-message-headers nil nil
|
|
|
350 "\\(X-VM-\\|Status:\\)")
|
|
98
|
351 (vm-reorder-message-headers
|
|
|
352 nil (if (vm-mime-plain-message-p m)
|
|
|
353 keep-list
|
|
|
354 mime-keep-list)
|
|
|
355 discard-regexp)
|
|
0
|
356 (vm-rfc1153-char-stuff-region beg (point-max))))))
|
|
|
357 (goto-char (point-max))
|
|
|
358 (insert "\n---------------")
|
|
|
359 (setq mlist (cdr mlist)))
|
|
|
360 (insert "---------------\n\nEnd of this Digest\n******************\n")
|
|
|
361 (goto-char start)
|
|
|
362 (delete-region (point) (progn (forward-line 1) (point)))
|
|
|
363 (insert (format "This is an RFC 1153 digest.\n(%d message%s)\n----------------------------------------------------------------------\n" (length message-list) (if (cdr message-list) "s" "")))
|
|
|
364 (goto-char start)))))
|
|
|
365
|
|
|
366 (defun vm-rfc1153-or-rfc934-burst-message (m rfc1153)
|
|
|
367 "Burst messages from the digest message M.
|
|
|
368 M should be a message struct for a real message.
|
|
|
369 If RFC1153 is non-nil, assume the digest is of the form specified by
|
|
|
370 RFC 1153. Otherwise assume RFC 934 digests."
|
|
|
371 (let ((work-buffer nil)
|
|
|
372 (match t)
|
|
|
373 (prev-sep nil)
|
|
|
374 (ident-header nil)
|
|
|
375 after-prev-sep prologue-separator-regexp separator-regexp
|
|
|
376 (folder-type vm-folder-type))
|
|
|
377 (if vm-digest-identifier-header-format
|
|
|
378 (setq ident-header (vm-sprintf 'vm-digest-identifier-header-format m)))
|
|
|
379 (if rfc1153
|
|
|
380 (setq prologue-separator-regexp "^----------------------------------------------------------------------\n"
|
|
|
381 separator-regexp "^------------------------------\n")
|
|
70
|
382 (setq prologue-separator-regexp "^-[^ ].*\n"
|
|
|
383 separator-regexp "^-[^ ].*\n"))
|
|
98
|
384 (vm-save-restriction
|
|
|
385 (save-excursion
|
|
0
|
386 (widen)
|
|
|
387 (unwind-protect
|
|
|
388 (catch 'done
|
|
|
389 (setq work-buffer (generate-new-buffer "*vm-work*"))
|
|
98
|
390 (buffer-disable-undo work-buffer)
|
|
0
|
391 (set-buffer work-buffer)
|
|
|
392 (insert-buffer-substring (vm-buffer-of m)
|
|
|
393 (vm-text-of m)
|
|
|
394 (vm-text-end-of m))
|
|
|
395 (goto-char (point-min))
|
|
|
396 (if (not (re-search-forward prologue-separator-regexp nil t))
|
|
|
397 (throw 'done nil))
|
|
|
398 ;; think of this as a do-while loop.
|
|
|
399 (while match
|
|
|
400 (cond ((null prev-sep)
|
|
|
401 ;; from (point-min) to end of match
|
|
|
402 ;; is the digest prologue, devour it and
|
|
|
403 ;; carry on.
|
|
|
404 (delete-region (point-min) (match-end 0)))
|
|
|
405 (t
|
|
|
406 ;; munge previous messages message separators
|
|
|
407 (let ((md (match-data)))
|
|
|
408 (unwind-protect
|
|
|
409 (vm-munge-message-separators
|
|
|
410 folder-type
|
|
|
411 after-prev-sep
|
|
|
412 (match-beginning 0))
|
|
70
|
413 (store-match-data md)))
|
|
|
414 ;; eat preceding newlines
|
|
|
415 (while (= (preceding-char) ?\n)
|
|
|
416 (delete-char -1))
|
|
|
417 ;; put one back
|
|
|
418 (insert ?\n)))
|
|
100
|
419 ;; there should be at least one valid header at
|
|
|
420 ;; the beginning of an encapsulated message. If
|
|
|
421 ;; there isn't a valid header, then assume that
|
|
|
422 ;; the digest was packed improperly and that this
|
|
|
423 ;; isn't a real boundary.
|
|
|
424 (if (not
|
|
|
425 (save-excursion
|
|
|
426 (save-match-data
|
|
|
427 (skip-chars-forward "\n")
|
|
|
428 (and (vm-match-header)
|
|
|
429 (or (vm-digest-get-header-contents "From")
|
|
|
430 (not (re-search-forward separator-regexp
|
|
|
431 nil t)))))))
|
|
|
432 (setq prev-sep (point)
|
|
|
433 after-prev-sep (point))
|
|
|
434 ;; insert a trailing message separator
|
|
|
435 ;; delete the digest separator
|
|
|
436 ;; insert the leading separator
|
|
|
437 (if prev-sep
|
|
|
438 (progn
|
|
|
439 (delete-region (match-beginning 0) (match-end 0))
|
|
|
440 (insert (vm-trailing-message-separator folder-type))))
|
|
|
441 (setq prev-sep (point))
|
|
|
442 (insert (vm-leading-message-separator folder-type))
|
|
|
443 (setq after-prev-sep (point))
|
|
|
444 ;; eat trailing newlines
|
|
|
445 (while (= (following-char) ?\n)
|
|
|
446 (delete-char 1))
|
|
|
447 (insert ident-header))
|
|
0
|
448 ;; try to match message separator and repeat.
|
|
|
449 (setq match (re-search-forward separator-regexp nil t)))
|
|
|
450 ;; from the last separator to eof is the digest epilogue.
|
|
|
451 ;; discard it.
|
|
|
452 (delete-region (or prev-sep (point-min)) (point-max))
|
|
|
453 ;; Undo the quoting of the embedded message
|
|
|
454 ;; separators. This must be done before header
|
|
|
455 ;; conversions, else the Content-Length offsets might be
|
|
|
456 ;; rendered invalid by buffer size changes.
|
|
|
457 (if rfc1153
|
|
|
458 (vm-rfc1153-char-unstuff-region (point-min) (point-max))
|
|
|
459 (vm-rfc934-char-unstuff-region (point-min) (point-max)))
|
|
|
460 ;; do header conversions.
|
|
|
461 (let ((vm-folder-type folder-type))
|
|
|
462 (goto-char (point-min))
|
|
|
463 (while (vm-find-leading-message-separator)
|
|
|
464 (vm-skip-past-leading-message-separator)
|
|
|
465 (vm-convert-folder-type-headers folder-type folder-type)
|
|
|
466 (vm-find-trailing-message-separator)
|
|
|
467 (vm-skip-past-trailing-message-separator)))
|
|
|
468 ;; now insert the messages into the folder buffer
|
|
|
469 (cond ((not (zerop (buffer-size)))
|
|
|
470 (set-buffer (vm-buffer-of m))
|
|
|
471 (let ((old-buffer-modified-p (buffer-modified-p))
|
|
|
472 (buffer-read-only nil)
|
|
|
473 (inhibit-quit t))
|
|
|
474 (goto-char (point-max))
|
|
|
475 (insert-buffer-substring work-buffer)
|
|
|
476 (set-buffer-modified-p old-buffer-modified-p)
|
|
|
477 ;; return non-nil so caller knows we found some messages
|
|
|
478 t ))
|
|
|
479 ;; return nil so the caller knows we didn't find anything
|
|
|
480 (t nil)))
|
|
|
481 (and work-buffer (kill-buffer work-buffer)))))))
|
|
|
482
|
|
|
483 (defun vm-rfc934-burst-message (m)
|
|
|
484 "Burst messages from the RFC 934 digest message M.
|
|
|
485 M should be a message struct for a real message."
|
|
|
486 (vm-rfc1153-or-rfc934-burst-message m nil))
|
|
|
487
|
|
|
488 (defun vm-rfc1153-burst-message (m)
|
|
|
489 "Burst messages from the RFC 1153 digest message M.
|
|
|
490 M should be a message struct for a real message."
|
|
|
491 (vm-rfc1153-or-rfc934-burst-message m t))
|
|
|
492
|
|
|
493 (defun vm-burst-digest (&optional digest-type)
|
|
|
494 "Burst the current message (a digest) into its individual messages.
|
|
|
495 The digest's messages are assimilated into the folder as new mail
|
|
|
496 would be.
|
|
|
497
|
|
|
498 Optional argument DIGEST-TYPE is a string that tells VM what kind
|
|
|
499 of digest the current message is. If it is not given the value
|
|
|
500 defaults to the value of vm-digest-burst-type. When called
|
|
|
501 interactively DIGEST-TYPE will be read from the minibuffer.
|
|
|
502
|
|
|
503 If invoked on marked messages (via vm-next-command-uses-marks),
|
|
|
504 all marked messages will be burst."
|
|
|
505 (interactive
|
|
|
506 (list
|
|
|
507 (let ((type nil)
|
|
|
508 (this-command this-command)
|
|
|
509 (last-command last-command))
|
|
|
510 (setq type (completing-read (format "Digest type: (default %s) "
|
|
|
511 vm-digest-burst-type)
|
|
|
512 (append vm-digest-type-alist
|
|
|
513 (list '("guess")))
|
|
|
514 'identity nil))
|
|
|
515 (if (string= type "")
|
|
|
516 vm-digest-burst-type
|
|
|
517 type ))))
|
|
|
518 (or digest-type (setq digest-type vm-digest-burst-type))
|
|
|
519 (vm-follow-summary-cursor)
|
|
|
520 (vm-select-folder-buffer)
|
|
|
521 (vm-check-for-killed-summary)
|
|
|
522 (vm-error-if-folder-empty)
|
|
|
523 (let ((start-buffer (current-buffer)) m totals-blurb
|
|
|
524 (mlist (vm-select-marked-or-prefixed-messages 1)))
|
|
|
525 (while mlist
|
|
|
526 (if (vm-virtual-message-p (car mlist))
|
|
|
527 (progn
|
|
|
528 (setq m (vm-real-message-of (car mlist)))
|
|
|
529 (set-buffer (vm-buffer-of m)))
|
|
|
530 (setq m (car mlist)))
|
|
|
531 (vm-error-if-folder-read-only)
|
|
|
532 (if (equal digest-type "guess")
|
|
|
533 (progn
|
|
|
534 (setq digest-type (vm-guess-digest-type m))
|
|
|
535 (if (null digest-type)
|
|
|
536 (error "Couldn't guess digest type."))))
|
|
70
|
537 (vm-unsaved-message "Bursting %s digest..." digest-type)
|
|
0
|
538 (cond
|
|
98
|
539 ((cond ((equal digest-type "mime")
|
|
|
540 (vm-mime-burst-message m))
|
|
|
541 ((equal digest-type "rfc934")
|
|
0
|
542 (vm-rfc934-burst-message m))
|
|
|
543 ((equal digest-type "rfc1153")
|
|
|
544 (vm-rfc1153-burst-message m))
|
|
|
545 (t (error "Unknown digest type: %s" digest-type)))
|
|
|
546 (message "Bursting %s digest... done" digest-type)
|
|
|
547 (vm-clear-modification-flag-undos)
|
|
|
548 (vm-set-buffer-modified-p t)
|
|
|
549 (vm-increment vm-modification-counter)
|
|
|
550 (and vm-delete-after-bursting
|
|
|
551 ;; if start folder was virtual, we're now in the wrong
|
|
|
552 ;; buffer. switch back.
|
|
|
553 (save-excursion
|
|
|
554 (set-buffer start-buffer)
|
|
98
|
555 ;; don't move message pointer when deleting the message
|
|
|
556 (let ((vm-move-after-deleting nil))
|
|
|
557 (vm-delete-message 1))))
|
|
|
558 (vm-assimilate-new-messages t nil (vm-labels-of (car mlist)))
|
|
0
|
559 ;; do this now so if we error later in another iteration
|
|
|
560 ;; of the loop the summary and mode line will be correct.
|
|
|
561 (vm-update-summary-and-mode-line)))
|
|
|
562 (setq mlist (cdr mlist)))
|
|
|
563 ;; collect this data NOW, before the non-previewers read a
|
|
|
564 ;; message, alter the new message count and confuse
|
|
|
565 ;; themselves.
|
|
|
566 (setq totals-blurb (vm-emit-totals-blurb))
|
|
|
567 (vm-display nil nil '(vm-burst-digest
|
|
98
|
568 vm-burst-mime-digest
|
|
0
|
569 vm-burst-rfc934-digest
|
|
76
|
570 vm-burst-rfc1153-digest)
|
|
0
|
571 (list this-command))
|
|
|
572 (if (vm-thoughtfully-select-message)
|
|
|
573 (vm-preview-current-message)
|
|
|
574 (vm-update-summary-and-mode-line))
|
|
|
575 (message totals-blurb)))
|
|
|
576
|
|
|
577 (defun vm-burst-rfc934-digest ()
|
|
|
578 "Burst an RFC 934 style digest"
|
|
|
579 (interactive)
|
|
|
580 (vm-burst-digest "rfc934"))
|
|
|
581
|
|
|
582 (defun vm-burst-rfc1153-digest ()
|
|
|
583 "Burst an RFC 1153 style digest"
|
|
|
584 (interactive)
|
|
|
585 (vm-burst-digest "rfc1153"))
|
|
|
586
|
|
98
|
587 (defun vm-burst-mime-digest ()
|
|
|
588 "Burst a MIME digest"
|
|
|
589 (interactive)
|
|
|
590 (vm-burst-digest "mime"))
|
|
|
591
|
|
0
|
592 (defun vm-guess-digest-type (m)
|
|
|
593 "Guess the digest type of the message M.
|
|
|
594 M should be the message struct of a real message.
|
|
98
|
595 Returns either \"rfc934\", \"rfc1153\" or \"mime\"."
|
|
|
596 (catch 'return-value
|
|
|
597 (save-excursion
|
|
|
598 (set-buffer (vm-buffer-of m))
|
|
|
599 (let ((layout (vm-mm-layout m)))
|
|
|
600 (if (and (vectorp layout)
|
|
|
601 (or (vm-mime-types-match "multipart/digest"
|
|
|
602 (car (vm-mm-layout-type layout)))
|
|
|
603 (vm-mime-types-match "message/rfc822"
|
|
|
604 (car (vm-mm-layout-type layout)))))
|
|
|
605 (throw 'return-value "mime"))))
|
|
0
|
606 (save-excursion
|
|
|
607 (save-restriction
|
|
|
608 (widen)
|
|
76
|
609 (goto-char (vm-text-of m))
|
|
98
|
610 (cond ((search-forward "\n----------------------------------------------------------------------\n" (vm-text-end-of m) t)
|
|
|
611 "rfc1153")
|
|
|
612 (t "rfc934"))))))
|
|
100
|
613
|
|
|
614 (defun vm-digest-get-header-contents (header-name-regexp)
|
|
|
615 (let ((contents nil)
|
|
|
616 regexp)
|
|
|
617 (setq regexp (concat "^\\(" header-name-regexp "\\)\\|\\(^$\\)"))
|
|
|
618 (save-excursion
|
|
|
619 (let ((case-fold-search t))
|
|
|
620 (if (and (re-search-forward regexp nil t)
|
|
|
621 (match-beginning 1)
|
|
|
622 (progn (goto-char (match-beginning 0))
|
|
|
623 (vm-match-header)))
|
|
|
624 (vm-matched-header-contents)
|
|
|
625 nil )))))
|
