Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-digest.el @ 54:05472e90ae02 r19-16-pre2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-16-pre2
author cvs
date Mon, 13 Aug 2007 08:57:55 +0200
parents ec9a17fef872
children 131b0175ea99
comparison
equal deleted inserted replaced
53:875393c1a535 54:05472e90ae02
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) 57 (defun vm-mime-encapsulate-messages (message-list keep-list discard-regexp
58 always-use-digest)
58 "Encapsulate the messages in MESSAGE-LIST as per the MIME spec. 59 "Encapsulate the messages in MESSAGE-LIST as per the MIME spec.
59 The resulting digest is inserted at point in the current buffer. 60 The resulting digest is inserted at point in the current buffer.
60 Point is not moved. 61 Point is not moved.
61 62
62 MESSAGE-LIST should be a list of message structs (real or virtual). 63 MESSAGE-LIST should be a list of message structs (real or virtual).
65 DISCARD-REGEXP should be a regexp that matches headers to be discarded. 66 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 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 be forwarded. See the docs for vm-reorder-message-headers
68 to find out how KEEP-LIST and DISCARD-REGEXP are used. 69 to find out how KEEP-LIST and DISCARD-REGEXP are used.
69 70
70 Returns the multipart boundary parameter (string) that should be used 71 If ALWAYS-USE-DIGEST is non-nil, always encapsulate for a multipart/digest.
71 in the Content-Type header." 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."
72 (if message-list 79 (if message-list
73 (let ((target-buffer (current-buffer)) 80 (let ((target-buffer (current-buffer))
74 (boundary-positions nil) 81 (boundary-positions nil)
75 (mlist message-list) 82 (mlist message-list)
76 (mime-keep-list (append keep-list vm-mime-header-list)) 83 (mime-keep-list (append keep-list vm-mime-header-list))
77 boundary source-buffer m start n beg) 84 (boundary nil)
85 source-buffer m start n beg)
78 (save-restriction 86 (save-restriction
79 ;; narrow to a zero length region to avoid interacting 87 ;; narrow to a zero length region to avoid interacting
80 ;; with anything that might have already been inserted 88 ;; with anything that might have already been inserted
81 ;; into the buffer. 89 ;; into the buffer.
82 (narrow-to-region (point) (point)) 90 (narrow-to-region (point) (point))
95 keep-list 103 keep-list
96 mime-keep-list) 104 mime-keep-list)
97 discard-regexp) 105 discard-regexp)
98 (goto-char (point-max)) 106 (goto-char (point-max))
99 (setq mlist (cdr mlist))) 107 (setq mlist (cdr mlist)))
100 (goto-char start) 108 (if (and (< (length message-list) 2) (not always-use-digest))
101 (setq boundary (vm-mime-make-multipart-boundary)) 109 nil
102 (while (re-search-forward (concat "^--" 110 (goto-char start)
103 (regexp-quote boundary)
104 "\\(--\\)?$")
105 nil t)
106 (setq boundary (vm-mime-make-multipart-boundary)) 111 (setq boundary (vm-mime-make-multipart-boundary))
107 (goto-char start)) 112 (while (re-search-forward (concat "^--"
108 (goto-char (point-max)) 113 (regexp-quote boundary)
109 (insert "\n--" boundary "--\n") 114 "\\(--\\)?$")
110 (while boundary-positions 115 nil t)
111 (goto-char (car boundary-positions)) 116 (setq boundary (vm-mime-make-multipart-boundary))
112 (insert "\n--" boundary "\n\n") 117 (goto-char start))
113 (setq boundary-positions (cdr boundary-positions))) 118 (goto-char (point-max))
114 (goto-char start) 119 (insert "\n--" boundary "--\n")
115 (setq n (length message-list)) 120 (while boundary-positions
116 (insert (format "This is a %s%sMIME encapsulation.\n" 121 (goto-char (car boundary-positions))
117 (if (cdr message-list) 122 (insert "\n--" boundary "\n\n")
118 "digest, " 123 (setq boundary-positions (cdr boundary-positions)))
119 "forwarded message, ") 124 (goto-char start)
120 (if (cdr message-list) 125 (setq n (length message-list))
121 (format "%d messages, " n) 126 (insert
122 ""))) 127 (format "This is a digest, %d messages, MIME encapsulation.\n"
128 n)))
123 (goto-char start)) 129 (goto-char start))
124 boundary ))) 130 boundary )))
125 131
126 (defun vm-mime-burst-message (m) 132 (defun vm-mime-burst-message (m)
127 "Burst messages from the digest message M. 133 "Burst messages from the digest message M.
128 M should be a message struct for a real message. 134 M should be a message struct for a real message.
129 MIME encoding is expected. The message content type 135 MIME encoding is expected. Somewhere within the MIME layout
130 must be either message/* or multipart/digest." 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."
131 (let ((ident-header nil) 139 (let ((ident-header nil)
132 (layout (vm-mm-layout m))) 140 (did-burst nil)
141 (list (vm-mime-find-digests-in-layout (vm-mm-layout m))))
133 (if vm-digest-identifier-header-format 142 (if vm-digest-identifier-header-format
134 (setq ident-header (vm-sprintf 'vm-digest-identifier-header-format m))) 143 (setq ident-header (vm-sprintf 'vm-digest-identifier-header-format m)))
135 (vm-mime-burst-layout layout ident-header))) 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))
136 149
137 (defun vm-mime-burst-layout (layout ident-header) 150 (defun vm-mime-burst-layout (layout ident-header)
138 (let ((work-buffer nil) 151 (let ((work-buffer nil)
139 (folder-buffer (current-buffer)) 152 (folder-buffer (current-buffer))
140 start part-list 153 start part-list
409 (unwind-protect 422 (unwind-protect
410 (vm-munge-message-separators 423 (vm-munge-message-separators
411 folder-type 424 folder-type
412 after-prev-sep 425 after-prev-sep
413 (match-beginning 0)) 426 (match-beginning 0))
414 (store-match-data md))) 427 (store-match-data md)))))
415 ;; eat preceding newlines
416 (while (= (preceding-char) ?\n)
417 (delete-char -1))
418 ;; put one back
419 (insert ?\n)))
420 ;; there should be at least one valid header at 428 ;; there should be at least one valid header at
421 ;; the beginning of an encapsulated message. If 429 ;; the beginning of an encapsulated message. If
422 ;; there isn't a valid header, then assume that 430 ;; there isn't a valid header, then assume that
423 ;; the digest was packed improperly and that this 431 ;; the digest was packed improperly and that this
424 ;; isn't a real boundary. 432 ;; isn't a real boundary.
430 (vm-digest-get-header-contents "From")) 438 (vm-digest-get-header-contents "From"))
431 (not (re-search-forward separator-regexp 439 (not (re-search-forward separator-regexp
432 nil t)))))) 440 nil t))))))
433 (setq prev-sep (point) 441 (setq prev-sep (point)
434 after-prev-sep (point)) 442 after-prev-sep (point))
435 ;; insert a trailing message separator 443 ;; if this isn't the first message, delete the
436 ;; delete the digest separator 444 ;; digest separator goop and insert a trailing message
437 ;; insert the leading separator 445 ;; separator of the proper type.
438 (if prev-sep 446 (if prev-sep
439 (progn 447 (progn
440 (delete-region (match-beginning 0) (match-end 0)) 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
441 (insert (vm-trailing-message-separator folder-type)))) 456 (insert (vm-trailing-message-separator folder-type))))
442 (setq prev-sep (point)) 457 (setq prev-sep (point))
458 ;; insert the leading separator
443 (insert (vm-leading-message-separator folder-type)) 459 (insert (vm-leading-message-separator folder-type))
444 (setq after-prev-sep (point)) 460 (setq after-prev-sep (point))
445 ;; eat trailing newlines 461 ;; eat trailing newlines
446 (while (= (following-char) ?\n) 462 (while (= (following-char) ?\n)
447 (delete-char 1)) 463 (delete-char 1))
597 (catch 'return-value 613 (catch 'return-value
598 (save-excursion 614 (save-excursion
599 (set-buffer (vm-buffer-of m)) 615 (set-buffer (vm-buffer-of m))
600 (let ((layout (vm-mm-layout m))) 616 (let ((layout (vm-mm-layout m)))
601 (if (and (vectorp layout) 617 (if (and (vectorp layout)
602 (or (vm-mime-types-match "multipart/digest" 618 (or (vm-mime-layout-contains-type
603 (car (vm-mm-layout-type layout))) 619 layout
604 (vm-mime-types-match "message/rfc822" 620 "multipart/digest")
605 (car (vm-mm-layout-type layout))) 621 (vm-mime-layout-contains-type
606 (vm-mime-types-match "message/news" 622 layout
607 (car (vm-mm-layout-type layout))))) 623 "message/rfc822")
624 (vm-mime-layout-contains-type
625 layout
626 "message/news")))
608 (throw 'return-value "mime")))) 627 (throw 'return-value "mime"))))
609 (save-excursion 628 (save-excursion
610 (save-restriction 629 (save-restriction
611 (widen) 630 (widen)
612 (goto-char (vm-text-of m)) 631 (goto-char (vm-text-of m))