Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-digest.el @ 20:859a2309aef8 r19-15b93

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b93
author cvs
date Mon, 13 Aug 2007 08:50:05 +0200
parents 49a24b4fd526
children 4103f0995bd7
comparison
equal deleted inserted replaced
19:ac1f612d5250 20:859a2309aef8
1 ;;; Message encapsulation 1 ;;; Message encapsulation
2 ;;; Copyright (C) 1989, 1990, 1993, 1994 Kyle E. Jones 2 ;;; Copyright (C) 1989, 1990, 1993, 1994, 1997 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 "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
57 (defun vm-rfc934-char-stuff-region (start end) 200 (defun vm-rfc934-char-stuff-region (start end)
58 "Quote RFC 934 message separators between START and END. 201 "Quote RFC 934 message separators between START and END.
59 START and END are buffer positions in the current buffer. 202 START and END are buffer positions in the current buffer.
60 Lines beginning with `-' in the region have `- ' prepended to them." 203 Lines beginning with `-' in the region have `- ' prepended to them."
61 (setq end (vm-marker end)) 204 (setq end (vm-marker end))
90 KEEP-LIST and DISCARD-REGEXP are used to order and trim the headers 233 KEEP-LIST and DISCARD-REGEXP are used to order and trim the headers
91 to be forwarded. See the docs for vm-reorder-message-headers 234 to be forwarded. See the docs for vm-reorder-message-headers
92 to find out how KEEP-LIST and DISCARD-REGEXP are used." 235 to find out how KEEP-LIST and DISCARD-REGEXP are used."
93 (if message-list 236 (if message-list
94 (let ((target-buffer (current-buffer)) 237 (let ((target-buffer (current-buffer))
238 (mime-keep-list (append keep-list vm-mime-header-list))
95 (mlist message-list) 239 (mlist message-list)
96 source-buffer m start n) 240 source-buffer m start n)
97 (save-restriction 241 (save-restriction
98 ;; narrow to a zero length region to avoid interacting 242 ;; narrow to a zero length region to avoid interacting
99 ;; with anything that might have already been inserted 243 ;; with anything that might have already been inserted
114 (insert-buffer-substring source-buffer (vm-headers-of m) 258 (insert-buffer-substring source-buffer (vm-headers-of m)
115 (vm-text-end-of m)) 259 (vm-text-end-of m))
116 (goto-char beg) 260 (goto-char beg)
117 (vm-reorder-message-headers nil nil 261 (vm-reorder-message-headers nil nil
118 "\\(X-VM-\\|Status:\\)") 262 "\\(X-VM-\\|Status:\\)")
119 (vm-reorder-message-headers nil keep-list discard-regexp) 263 (vm-reorder-message-headers
264 nil (if (vm-mime-plain-message-p m)
265 keep-list
266 mime-keep-list)
267 discard-regexp)
120 (vm-rfc934-char-stuff-region beg (point-max)))))) 268 (vm-rfc934-char-stuff-region beg (point-max))))))
121 (goto-char (point-max)) 269 (goto-char (point-max))
122 (insert "---------------") 270 (insert "---------------")
123 (setq mlist (cdr mlist))) 271 (setq mlist (cdr mlist)))
124 (delete-region (point) (progn (beginning-of-line) (point))) 272 (delete-region (point) (progn (beginning-of-line) (point)))
173 KEEP-LIST and DISCARD-REGEXP are used to order and trim the headers 321 KEEP-LIST and DISCARD-REGEXP are used to order and trim the headers
174 to be forwarded. See the docs for vm-reorder-message-headers 322 to be forwarded. See the docs for vm-reorder-message-headers
175 to find out how KEEP-LIST and DISCARD-REGEXP are used." 323 to find out how KEEP-LIST and DISCARD-REGEXP are used."
176 (if message-list 324 (if message-list
177 (let ((target-buffer (current-buffer)) 325 (let ((target-buffer (current-buffer))
326 (mime-keep-list (append keep-list vm-mime-header-list))
178 (mlist message-list) 327 (mlist message-list)
179 source-buffer m start) 328 source-buffer m start)
180 (save-restriction 329 (save-restriction
181 ;; narrow to a zero length region to avoid interacting 330 ;; narrow to a zero length region to avoid interacting
182 ;; with anything that might have already been inserted 331 ;; with anything that might have already been inserted
197 (insert-buffer-substring source-buffer (vm-headers-of m) 346 (insert-buffer-substring source-buffer (vm-headers-of m)
198 (vm-text-end-of m)) 347 (vm-text-end-of m))
199 (goto-char beg) 348 (goto-char beg)
200 (vm-reorder-message-headers nil nil 349 (vm-reorder-message-headers nil nil
201 "\\(X-VM-\\|Status:\\)") 350 "\\(X-VM-\\|Status:\\)")
202 (vm-reorder-message-headers nil keep-list discard-regexp) 351 (vm-reorder-message-headers
352 nil (if (vm-mime-plain-message-p m)
353 keep-list
354 mime-keep-list)
355 discard-regexp)
203 (vm-rfc1153-char-stuff-region beg (point-max)))))) 356 (vm-rfc1153-char-stuff-region beg (point-max))))))
204 (goto-char (point-max)) 357 (goto-char (point-max))
205 (insert "\n---------------") 358 (insert "\n---------------")
206 (setq mlist (cdr mlist))) 359 (setq mlist (cdr mlist)))
207 (insert "---------------\n\nEnd of this Digest\n******************\n") 360 (insert "---------------\n\nEnd of this Digest\n******************\n")
226 (if rfc1153 379 (if rfc1153
227 (setq prologue-separator-regexp "^----------------------------------------------------------------------\n" 380 (setq prologue-separator-regexp "^----------------------------------------------------------------------\n"
228 separator-regexp "^------------------------------\n") 381 separator-regexp "^------------------------------\n")
229 (setq prologue-separator-regexp "^-[^ ].*\n" 382 (setq prologue-separator-regexp "^-[^ ].*\n"
230 separator-regexp "^-[^ ].*\n")) 383 separator-regexp "^-[^ ].*\n"))
231 (save-excursion 384 (vm-save-restriction
232 (vm-save-restriction 385 (save-excursion
233 (widen) 386 (widen)
234 (unwind-protect 387 (unwind-protect
235 (catch 'done 388 (catch 'done
236 (setq work-buffer (generate-new-buffer "*vm-work*")) 389 (setq work-buffer (generate-new-buffer "*vm-work*"))
390 (buffer-disable-undo work-buffer)
237 (set-buffer work-buffer) 391 (set-buffer work-buffer)
238 (insert-buffer-substring (vm-buffer-of m) 392 (insert-buffer-substring (vm-buffer-of m)
239 (vm-text-of m) 393 (vm-text-of m)
240 (vm-text-end-of m)) 394 (vm-text-end-of m))
241 (goto-char (point-min)) 395 (goto-char (point-min))
365 (setq digest-type (vm-guess-digest-type m)) 519 (setq digest-type (vm-guess-digest-type m))
366 (if (null digest-type) 520 (if (null digest-type)
367 (error "Couldn't guess digest type.")))) 521 (error "Couldn't guess digest type."))))
368 (vm-unsaved-message "Bursting %s digest..." digest-type) 522 (vm-unsaved-message "Bursting %s digest..." digest-type)
369 (cond 523 (cond
370 ((cond ((equal digest-type "rfc934") 524 ((cond ((equal digest-type "mime")
525 (vm-mime-burst-message m))
526 ((equal digest-type "rfc934")
371 (vm-rfc934-burst-message m)) 527 (vm-rfc934-burst-message m))
372 ((equal digest-type "rfc1153") 528 ((equal digest-type "rfc1153")
373 (vm-rfc1153-burst-message m)) 529 (vm-rfc1153-burst-message m))
374 (t (error "Unknown digest type: %s" digest-type))) 530 (t (error "Unknown digest type: %s" digest-type)))
375 (message "Bursting %s digest... done" digest-type) 531 (message "Bursting %s digest... done" digest-type)
379 (and vm-delete-after-bursting 535 (and vm-delete-after-bursting
380 ;; if start folder was virtual, we're now in the wrong 536 ;; if start folder was virtual, we're now in the wrong
381 ;; buffer. switch back. 537 ;; buffer. switch back.
382 (save-excursion 538 (save-excursion
383 (set-buffer start-buffer) 539 (set-buffer start-buffer)
384 (vm-delete-message 1))) 540 ;; don't move message pointer when deleting the message
385 (vm-assimilate-new-messages t) 541 (let ((vm-move-after-deleting nil))
542 (vm-delete-message 1))))
543 (vm-assimilate-new-messages t nil (vm-labels-of (car mlist)))
386 ;; do this now so if we error later in another iteration 544 ;; do this now so if we error later in another iteration
387 ;; of the loop the summary and mode line will be correct. 545 ;; of the loop the summary and mode line will be correct.
388 (vm-update-summary-and-mode-line))) 546 (vm-update-summary-and-mode-line)))
389 (setq mlist (cdr mlist))) 547 (setq mlist (cdr mlist)))
390 ;; collect this data NOW, before the non-previewers read a 548 ;; collect this data NOW, before the non-previewers read a
391 ;; message, alter the new message count and confuse 549 ;; message, alter the new message count and confuse
392 ;; themselves. 550 ;; themselves.
393 (setq totals-blurb (vm-emit-totals-blurb)) 551 (setq totals-blurb (vm-emit-totals-blurb))
394 (vm-display nil nil '(vm-burst-digest 552 (vm-display nil nil '(vm-burst-digest
553 vm-burst-mime-digest
395 vm-burst-rfc934-digest 554 vm-burst-rfc934-digest
396 vm-burst-rfc1153-digest) 555 vm-burst-rfc1153-digest)
397 (list this-command)) 556 (list this-command))
398 (if (vm-thoughtfully-select-message) 557 (if (vm-thoughtfully-select-message)
399 (vm-preview-current-message) 558 (vm-preview-current-message)
408 (defun vm-burst-rfc1153-digest () 567 (defun vm-burst-rfc1153-digest ()
409 "Burst an RFC 1153 style digest" 568 "Burst an RFC 1153 style digest"
410 (interactive) 569 (interactive)
411 (vm-burst-digest "rfc1153")) 570 (vm-burst-digest "rfc1153"))
412 571
572 (defun vm-burst-mime-digest ()
573 "Burst a MIME digest"
574 (interactive)
575 (vm-burst-digest "mime"))
576
413 (defun vm-guess-digest-type (m) 577 (defun vm-guess-digest-type (m)
414 "Guess the digest type of the message M. 578 "Guess the digest type of the message M.
415 M should be the message struct of a real message. 579 M should be the message struct of a real message.
416 Returns either \"rfc934\" or \"rfc1153\"." 580 Returns either \"rfc934\", \"rfc1153\" or \"mime\"."
417 (save-excursion 581 (catch 'return-value
418 (set-buffer (vm-buffer-of m)) 582 (save-excursion
583 (set-buffer (vm-buffer-of m))
584 (let ((layout (vm-mm-layout m)))
585 (if (and (vectorp layout)
586 (or (vm-mime-types-match "multipart/digest"
587 (car (vm-mm-layout-type layout)))
588 (vm-mime-types-match "message/rfc822"
589 (car (vm-mm-layout-type layout)))))
590 (throw 'return-value "mime"))))
419 (save-excursion 591 (save-excursion
420 (save-restriction 592 (save-restriction
421 (widen) 593 (widen)
422 (goto-char (vm-text-of m)) 594 (goto-char (vm-text-of m))
423 (if (search-forward "\n----------------------------------------------------------------------\n" nil t) 595 (cond ((search-forward "\n----------------------------------------------------------------------\n" (vm-text-end-of m) t)
424 "rfc1153" 596 "rfc1153")
425 "rfc934"))))) 597 (t "rfc934"))))))