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