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