Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-digest.el @ 70:131b0175ea99 r20-0b30

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents 05472e90ae02
children c0c698873ce1
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
1 ;;; Message encapsulation 1 ;;; Message encapsulation
2 ;;; Copyright (C) 1989, 1990, 1993, 1994, 1997 Kyle E. Jones 2 ;;; Copyright (C) 1989, 1990, 1993, 1994 Kyle E. Jones
3 ;;; 3 ;;;
4 ;;; This program is free software; you can redistribute it and/or modify 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 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) 6 ;;; the Free Software Foundation; either version 1, or (at your option)
7 ;;; any later version. 7 ;;; any later version.
52 (vm-reorder-message-headers nil nil "\\(X-VM-\\|Status:\\)") 52 (vm-reorder-message-headers nil nil "\\(X-VM-\\|Status:\\)")
53 (vm-reorder-message-headers nil keep-list discard-regexp))))) 53 (vm-reorder-message-headers nil keep-list discard-regexp)))))
54 (goto-char (point-max)) 54 (goto-char (point-max))
55 (insert "------- end of forwarded message -------\n")))) 55 (insert "------- end of forwarded message -------\n"))))
56 56
57 (defun vm-mime-encapsulate-messages (message-list keep-list discard-regexp
58 always-use-digest)
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
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."
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))
84 (boundary nil)
85 source-buffer m start n beg)
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)))
108 (if (and (< (length message-list) 2) (not always-use-digest))
109 nil
110 (goto-char start)
111 (setq boundary (vm-mime-make-multipart-boundary))
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)))
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.
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."
139 (let ((ident-header nil)
140 (did-burst nil)
141 (list (vm-mime-find-digests-in-layout (vm-mm-layout m))))
142 (if vm-digest-identifier-header-format
143 (setq ident-header (vm-sprintf 'vm-digest-identifier-header-format m)))
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))
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
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.
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
190 "MIME type is not multipart/digest or message/rfc822 or message/news")))
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
214 (defun vm-rfc934-char-stuff-region (start end) 57 (defun vm-rfc934-char-stuff-region (start end)
215 "Quote RFC 934 message separators between START and END. 58 "Quote RFC 934 message separators between START and END.
216 START and END are buffer positions in the current buffer. 59 START and END are buffer positions in the current buffer.
217 Lines beginning with `-' in the region have `- ' prepended to them." 60 Lines beginning with `-' in the region have `- ' prepended to them."
218 (setq end (vm-marker end)) 61 (setq end (vm-marker end))
247 KEEP-LIST and DISCARD-REGEXP are used to order and trim the headers 90 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 91 to be forwarded. See the docs for vm-reorder-message-headers
249 to find out how KEEP-LIST and DISCARD-REGEXP are used." 92 to find out how KEEP-LIST and DISCARD-REGEXP are used."
250 (if message-list 93 (if message-list
251 (let ((target-buffer (current-buffer)) 94 (let ((target-buffer (current-buffer))
252 (mime-keep-list (append keep-list vm-mime-header-list))
253 (mlist message-list) 95 (mlist message-list)
254 source-buffer m start n) 96 source-buffer m start n)
255 (save-restriction 97 (save-restriction
256 ;; narrow to a zero length region to avoid interacting 98 ;; narrow to a zero length region to avoid interacting
257 ;; with anything that might have already been inserted 99 ;; with anything that might have already been inserted
272 (insert-buffer-substring source-buffer (vm-headers-of m) 114 (insert-buffer-substring source-buffer (vm-headers-of m)
273 (vm-text-end-of m)) 115 (vm-text-end-of m))
274 (goto-char beg) 116 (goto-char beg)
275 (vm-reorder-message-headers nil nil 117 (vm-reorder-message-headers nil nil
276 "\\(X-VM-\\|Status:\\)") 118 "\\(X-VM-\\|Status:\\)")
277 (vm-reorder-message-headers 119 (vm-reorder-message-headers nil keep-list discard-regexp)
278 nil (if (vm-mime-plain-message-p m)
279 keep-list
280 mime-keep-list)
281 discard-regexp)
282 (vm-rfc934-char-stuff-region beg (point-max)))))) 120 (vm-rfc934-char-stuff-region beg (point-max))))))
283 (goto-char (point-max)) 121 (goto-char (point-max))
284 (insert "---------------") 122 (insert "---------------")
285 (setq mlist (cdr mlist))) 123 (setq mlist (cdr mlist)))
286 (delete-region (point) (progn (beginning-of-line) (point))) 124 (delete-region (point) (progn (beginning-of-line) (point)))
335 KEEP-LIST and DISCARD-REGEXP are used to order and trim the headers 173 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 174 to be forwarded. See the docs for vm-reorder-message-headers
337 to find out how KEEP-LIST and DISCARD-REGEXP are used." 175 to find out how KEEP-LIST and DISCARD-REGEXP are used."
338 (if message-list 176 (if message-list
339 (let ((target-buffer (current-buffer)) 177 (let ((target-buffer (current-buffer))
340 (mime-keep-list (append keep-list vm-mime-header-list))
341 (mlist message-list) 178 (mlist message-list)
342 source-buffer m start) 179 source-buffer m start)
343 (save-restriction 180 (save-restriction
344 ;; narrow to a zero length region to avoid interacting 181 ;; narrow to a zero length region to avoid interacting
345 ;; with anything that might have already been inserted 182 ;; with anything that might have already been inserted
360 (insert-buffer-substring source-buffer (vm-headers-of m) 197 (insert-buffer-substring source-buffer (vm-headers-of m)
361 (vm-text-end-of m)) 198 (vm-text-end-of m))
362 (goto-char beg) 199 (goto-char beg)
363 (vm-reorder-message-headers nil nil 200 (vm-reorder-message-headers nil nil
364 "\\(X-VM-\\|Status:\\)") 201 "\\(X-VM-\\|Status:\\)")
365 (vm-reorder-message-headers 202 (vm-reorder-message-headers nil keep-list discard-regexp)
366 nil (if (vm-mime-plain-message-p m)
367 keep-list
368 mime-keep-list)
369 discard-regexp)
370 (vm-rfc1153-char-stuff-region beg (point-max)))))) 203 (vm-rfc1153-char-stuff-region beg (point-max))))))
371 (goto-char (point-max)) 204 (goto-char (point-max))
372 (insert "\n---------------") 205 (insert "\n---------------")
373 (setq mlist (cdr mlist))) 206 (setq mlist (cdr mlist)))
374 (insert "---------------\n\nEnd of this Digest\n******************\n") 207 (insert "---------------\n\nEnd of this Digest\n******************\n")
375 (goto-char start) 208 (goto-char start)
376 (delete-region (point) (progn (forward-line 1) (point))) 209 (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" ""))) 210 (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))))) 211 (goto-char start)))))
212
213 (defun vm-rfc1521-encapsulate-messages (message-list keep-list discard-regexp)
214 "Encapsulate the messages in MESSAGE-LIST as per RFC 1521 (MIME).
215 The resulting digest is inserted at point in the current buffer.
216 MIME headers at point-max are added/updated.
217 Point is not moved.
218
219 MESSAGE-LIST should be a list of message structs (real or virtual).
220 These are the messages that will be encapsulated.
221 KEEP-LIST should be a list of regexps matching headers to keep.
222 DISCARD-REGEXP should be a regexp that matches headers to be discarded.
223 KEEP-LIST and DISCARD-REGEXP are used to order and trim the headers
224 to be forwarded. See the docs for vm-reorder-message-headers
225 to find out how KEEP-LIST and DISCARD-REGEXP are used."
226 (if message-list
227 (let ((target-buffer (current-buffer))
228 (mlist message-list)
229 (boundary (format "-----%07X%07X" (abs (random)) (abs (random))))
230 ; insertion-point
231 source-buffer m start)
232 (save-restriction
233 ;; narrow to a zero length region to avoid interacting
234 ;; with anything that might have already been inserted
235 ;; into the buffer.
236 (narrow-to-region (point) (point))
237 (setq start (point))
238 (while mlist
239 (insert "--" boundary "\nContent-Type: message/rfc822\n\n")
240 (setq m (vm-real-message-of (car mlist))
241 source-buffer (vm-buffer-of m))
242 (save-excursion
243 (set-buffer source-buffer)
244 (save-restriction
245 (widen)
246 (save-excursion
247 (set-buffer target-buffer)
248 (let ((beg (point)))
249 (insert-buffer-substring source-buffer (vm-headers-of m)
250 (vm-text-end-of m))
251 (goto-char beg)
252 (vm-reorder-message-headers nil nil
253 "\\(X-VM-\\|Status:\\)")
254 (vm-reorder-message-headers nil keep-list discard-regexp)
255 ))))
256 (goto-char (point-max))
257 (insert "\n")
258 (setq mlist (cdr mlist)))
259 (insert "--" boundary "--\n")
260
261 (goto-char start)
262 (insert "--" boundary "\nContent-Type: text/plain\n\n")
263 (insert (format
264 "This is an RFC 1521 (MIME) digest; %d message%s.\n\n\n\n\n"
265 (length message-list)
266 (if (cdr message-list) "s" "")))
267 ; (setq insertion-point (point-marker))
268 (goto-char start))
269
270 ;; outside of the save-restriction
271 (save-excursion
272 (let (end)
273 (goto-char (point-min))
274 (re-search-forward
275 (concat "^" (regexp-quote mail-header-separator) "$")
276 nil t)
277 (setq end (point))
278 (goto-char (point-min))
279 (cond
280 ((re-search-forward "^content-type:" end t)
281 (delete-region (point) (progn (forward-line 1) (point)))
282 (while (looking-at " \t")
283 (delete-region (point) (progn (forward-line 1) (point))))))
284 (goto-char end)
285 (insert "MIME-Version: 1.0\n"
286 "Content-Type: multipart/digest; boundary=\""
287 boundary "\"\n")
288 ))
289
290 ; (goto-char insertion-point)
291 ; (set-marker insertion-point nil)
292 )))
293
379 294
380 (defun vm-rfc1153-or-rfc934-burst-message (m rfc1153) 295 (defun vm-rfc1153-or-rfc934-burst-message (m rfc1153)
381 "Burst messages from the digest message M. 296 "Burst messages from the digest message M.
382 M should be a message struct for a real message. 297 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 298 If RFC1153 is non-nil, assume the digest is of the form specified by
391 (if vm-digest-identifier-header-format 306 (if vm-digest-identifier-header-format
392 (setq ident-header (vm-sprintf 'vm-digest-identifier-header-format m))) 307 (setq ident-header (vm-sprintf 'vm-digest-identifier-header-format m)))
393 (if rfc1153 308 (if rfc1153
394 (setq prologue-separator-regexp "^----------------------------------------------------------------------\n" 309 (setq prologue-separator-regexp "^----------------------------------------------------------------------\n"
395 separator-regexp "^------------------------------\n") 310 separator-regexp "^------------------------------\n")
396 (setq prologue-separator-regexp "\\(^-[^ ].*\n+\\)+" 311 (setq prologue-separator-regexp "^-[^ ].*\n"
397 separator-regexp "\\(^-[^ ].*\n+\\)+")) 312 separator-regexp "^-[^ ].*\n"))
398 (vm-save-restriction 313 (save-excursion
399 (save-excursion 314 (vm-save-restriction
400 (widen) 315 (widen)
401 (unwind-protect 316 (unwind-protect
402 (catch 'done 317 (catch 'done
403 (setq work-buffer (generate-new-buffer "*vm-work*")) 318 (setq work-buffer (generate-new-buffer "*vm-work*"))
404 (buffer-disable-undo work-buffer)
405 (set-buffer work-buffer) 319 (set-buffer work-buffer)
406 (insert-buffer-substring (vm-buffer-of m) 320 (insert-buffer-substring (vm-buffer-of m)
407 (vm-text-of m) 321 (vm-text-of m)
408 (vm-text-end-of m)) 322 (vm-text-end-of m))
409 (goto-char (point-min)) 323 (goto-char (point-min))
422 (unwind-protect 336 (unwind-protect
423 (vm-munge-message-separators 337 (vm-munge-message-separators
424 folder-type 338 folder-type
425 after-prev-sep 339 after-prev-sep
426 (match-beginning 0)) 340 (match-beginning 0))
427 (store-match-data md))))) 341 (store-match-data md)))
428 ;; there should be at least one valid header at 342 ;; eat preceding newlines
429 ;; the beginning of an encapsulated message. If 343 (while (= (preceding-char) ?\n)
430 ;; there isn't a valid header, then assume that 344 (delete-char -1))
431 ;; the digest was packed improperly and that this 345 ;; put one back
432 ;; isn't a real boundary. 346 (insert ?\n)))
433 (if (not 347 ;; insert a trailing message separator
434 (save-excursion 348 ;; delete the digest separator
435 (save-match-data 349 ;; insert the leading separator
436 (skip-chars-forward "\n") 350 (if prev-sep
437 (or (and (vm-match-header) 351 (progn
438 (vm-digest-get-header-contents "From")) 352 (delete-region (match-beginning 0) (match-end 0))
439 (not (re-search-forward separator-regexp 353 (insert (vm-trailing-message-separator folder-type))))
440 nil t)))))) 354 (setq prev-sep (point))
441 (setq prev-sep (point) 355 (insert (vm-leading-message-separator folder-type))
442 after-prev-sep (point)) 356 (setq after-prev-sep (point))
443 ;; if this isn't the first message, delete the 357 ;; eat trailing newlines
444 ;; digest separator goop and insert a trailing message 358 (while (= (following-char) ?\n)
445 ;; separator of the proper type. 359 (delete-char 1))
446 (if prev-sep 360 (insert ident-header)
447 (progn
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
454 (delete-region (match-beginning 0) (point))
455 ;; insert a trailing message separator
456 (insert (vm-trailing-message-separator folder-type))))
457 (setq prev-sep (point))
458 ;; insert the leading separator
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))
465 ;; try to match message separator and repeat. 361 ;; try to match message separator and repeat.
466 (setq match (re-search-forward separator-regexp nil t))) 362 (setq match (re-search-forward separator-regexp nil t)))
467 ;; from the last separator to eof is the digest epilogue. 363 ;; from the last separator to eof is the digest epilogue.
468 ;; discard it. 364 ;; discard it.
469 (delete-region (or prev-sep (point-min)) (point-max)) 365 (delete-region (or prev-sep (point-min)) (point-max))
549 (if (equal digest-type "guess") 445 (if (equal digest-type "guess")
550 (progn 446 (progn
551 (setq digest-type (vm-guess-digest-type m)) 447 (setq digest-type (vm-guess-digest-type m))
552 (if (null digest-type) 448 (if (null digest-type)
553 (error "Couldn't guess digest type.")))) 449 (error "Couldn't guess digest type."))))
554 (message "Bursting %s digest..." digest-type) 450 (vm-unsaved-message "Bursting %s digest..." digest-type)
555 (cond 451 (cond
556 ((cond ((equal digest-type "mime") 452 ((cond ((equal digest-type "rfc934")
557 (vm-mime-burst-message m))
558 ((equal digest-type "rfc934")
559 (vm-rfc934-burst-message m)) 453 (vm-rfc934-burst-message m))
560 ((equal digest-type "rfc1153") 454 ((equal digest-type "rfc1153")
561 (vm-rfc1153-burst-message m)) 455 (vm-rfc1153-burst-message m))
456 ((equal digest-type "rfc1521")
457 (error "Don't yet know how to burst MIME digests."))
562 (t (error "Unknown digest type: %s" digest-type))) 458 (t (error "Unknown digest type: %s" digest-type)))
563 (message "Bursting %s digest... done" digest-type) 459 (message "Bursting %s digest... done" digest-type)
564 (vm-clear-modification-flag-undos) 460 (vm-clear-modification-flag-undos)
565 (vm-set-buffer-modified-p t) 461 (vm-set-buffer-modified-p t)
566 (vm-increment vm-modification-counter) 462 (vm-increment vm-modification-counter)
567 (and vm-delete-after-bursting 463 (and vm-delete-after-bursting
568 ;; if start folder was virtual, we're now in the wrong 464 ;; if start folder was virtual, we're now in the wrong
569 ;; buffer. switch back. 465 ;; buffer. switch back.
570 (save-excursion 466 (save-excursion
571 (set-buffer start-buffer) 467 (set-buffer start-buffer)
572 ;; don't move message pointer when deleting the message 468 (vm-delete-message 1)))
573 (let ((vm-move-after-deleting nil)) 469 (vm-assimilate-new-messages t)
574 (vm-delete-message 1))))
575 (vm-assimilate-new-messages t nil (vm-labels-of (car mlist)))
576 ;; do this now so if we error later in another iteration 470 ;; do this now so if we error later in another iteration
577 ;; of the loop the summary and mode line will be correct. 471 ;; of the loop the summary and mode line will be correct.
578 (vm-update-summary-and-mode-line))) 472 (vm-update-summary-and-mode-line)))
579 (setq mlist (cdr mlist))) 473 (setq mlist (cdr mlist)))
580 ;; collect this data NOW, before the non-previewers read a 474 ;; collect this data NOW, before the non-previewers read a
581 ;; message, alter the new message count and confuse 475 ;; message, alter the new message count and confuse
582 ;; themselves. 476 ;; themselves.
583 (setq totals-blurb (vm-emit-totals-blurb)) 477 (setq totals-blurb (vm-emit-totals-blurb))
584 (vm-display nil nil '(vm-burst-digest 478 (vm-display nil nil '(vm-burst-digest
585 vm-burst-mime-digest
586 vm-burst-rfc934-digest 479 vm-burst-rfc934-digest
587 vm-burst-rfc1153-digest) 480 vm-burst-rfc1153-digest
481 vm-burst-rfc1521-digest)
588 (list this-command)) 482 (list this-command))
589 (if (vm-thoughtfully-select-message) 483 (if (vm-thoughtfully-select-message)
590 (vm-preview-current-message) 484 (vm-preview-current-message)
591 (vm-update-summary-and-mode-line)) 485 (vm-update-summary-and-mode-line))
592 (message totals-blurb))) 486 (message totals-blurb)))
599 (defun vm-burst-rfc1153-digest () 493 (defun vm-burst-rfc1153-digest ()
600 "Burst an RFC 1153 style digest" 494 "Burst an RFC 1153 style digest"
601 (interactive) 495 (interactive)
602 (vm-burst-digest "rfc1153")) 496 (vm-burst-digest "rfc1153"))
603 497
604 (defun vm-burst-mime-digest () 498 (defun vm-burst-rfc1521-digest ()
605 "Burst a MIME digest" 499 "Burst an RFC 1521 (MIME) style digest"
606 (interactive) 500 (interactive)
607 (vm-burst-digest "mime")) 501 (vm-burst-digest "rfc1521"))
608 502
609 (defun vm-guess-digest-type (m) 503 (defun vm-guess-digest-type (m)
610 "Guess the digest type of the message M. 504 "Guess the digest type of the message M.
611 M should be the message struct of a real message. 505 M should be the message struct of a real message.
612 Returns either \"rfc934\", \"rfc1153\" or \"mime\"." 506 Returns either \"rfc934\", \"rfc1153\", or \"rfc1521\"."
613 (catch 'return-value 507 (save-excursion
614 (save-excursion 508 (set-buffer (vm-buffer-of m))
615 (set-buffer (vm-buffer-of m))
616 (let ((layout (vm-mm-layout m)))
617 (if (and (vectorp layout)
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")))
627 (throw 'return-value "mime"))))
628 (save-excursion 509 (save-excursion
629 (save-restriction 510 (save-restriction
630 (widen) 511 (widen)
631 (goto-char (vm-text-of m)) 512 (goto-char (vm-headers-of m))
632 (cond ((search-forward "\n----------------------------------------------------------------------\n" (vm-text-end-of m) t) 513 (if (let ((case-fold-search t))
633 "rfc1153") 514 (re-search-forward "^MIME-Version:" nil t))
634 (t "rfc934")))))) 515 "rfc1521"
635 516 (goto-char (vm-text-of m))
636 (defun vm-digest-get-header-contents (header-name-regexp) 517 (if (search-forward "\n----------------------------------------------------------------------\n" nil t)
637 (let ((contents nil) 518 "rfc1153"
638 regexp) 519 "rfc934"))))))
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 )))))