--- a/lisp/vm/vm-digest.el	Mon Aug 13 09:12:43 2007 +0200
+++ b/lisp/vm/vm-digest.el	Mon Aug 13 09:13:56 2007 +0200
@@ -1,5 +1,5 @@
 ;;; Message encapsulation
-;;; Copyright (C) 1989, 1990, 1993, 1994 Kyle E. Jones
+;;; Copyright (C) 1989, 1990, 1993, 1994, 1997 Kyle E. Jones
 ;;;
 ;;; This program is free software; you can redistribute it and/or modify
 ;;; it under the terms of the GNU General Public License as published by
@@ -54,6 +54,149 @@
       (goto-char (point-max))
       (insert "------- end of forwarded message -------\n"))))
 
+(defun vm-mime-encapsulate-messages (message-list keep-list discard-regexp)
+  "Encapsulate the messages in MESSAGE-LIST as per the MIME spec.
+The resulting digest is inserted at point in the current buffer.
+Point is not moved.
+
+MESSAGE-LIST should be a list of message structs (real or virtual).
+These are the messages that will be encapsulated.
+KEEP-LIST should be a list of regexps matching headers to keep.
+DISCARD-REGEXP should be a regexp that matches headers to be discarded.
+KEEP-LIST and DISCARD-REGEXP are used to order and trim the headers
+to be forwarded.  See the docs for vm-reorder-message-headers
+to find out how KEEP-LIST and DISCARD-REGEXP are used.
+
+Returns the multipart boundary parameter (string) that should be used
+in the Content-Type header."
+  (if message-list
+      (let ((target-buffer (current-buffer))
+	    (boundary-positions nil)
+	    (mlist message-list)
+	    (mime-keep-list (append keep-list vm-mime-header-list))
+	    boundary source-buffer m start n beg)
+	(save-restriction
+	  ;; narrow to a zero length region to avoid interacting
+	  ;; with anything that might have already been inserted
+	  ;; into the buffer.
+	  (narrow-to-region (point) (point))
+	  (setq start (point))
+	  (while mlist
+	    (setq boundary-positions (cons (point-marker) boundary-positions))
+	    (setq m (vm-real-message-of (car mlist))
+		  source-buffer (vm-buffer-of m))
+	    (setq beg (point))
+	    (vm-insert-region-from-buffer source-buffer (vm-headers-of m)
+					  (vm-text-end-of m))
+	    (goto-char beg)
+	    (vm-reorder-message-headers nil nil "\\(X-VM-\\|Status:\\)")
+	    (vm-reorder-message-headers
+	     nil (if (vm-mime-plain-message-p m)
+		     keep-list
+		   mime-keep-list)
+	     discard-regexp)
+	    (goto-char (point-max))
+	    (setq mlist (cdr mlist)))
+	  (goto-char start)
+	  (setq boundary (vm-mime-make-multipart-boundary))
+	  (while (re-search-forward (concat "^--"
+					    (regexp-quote boundary)
+					    "\\(--\\)?$")
+				    nil t)
+	    (setq boundary (vm-mime-make-multipart-boundary))
+	    (goto-char start))
+	  (goto-char (point-max))
+	  (insert "\n--" boundary "--\n")
+	  (while boundary-positions
+	    (goto-char (car boundary-positions))
+	    (insert "\n--" boundary "\n\n")
+	    (setq boundary-positions (cdr boundary-positions)))
+	  (goto-char start)
+	  (setq n (length message-list))
+	  (insert (format "This is a %s%sMIME encapsulation.\n"
+			  (if (cdr message-list)
+			      "digest, "
+			    "forwarded message, ")
+			  (if (cdr message-list)
+			      (format "%d messages, " n)
+			    "")))
+	  (goto-char start))
+	boundary )))
+
+(defun vm-mime-burst-message (m)
+  "Burst messages from the digest message M.
+M should be a message struct for a real message.
+MIME encoding is expected.  The message content type
+must be either message/* or multipart/digest."
+  (let ((ident-header nil)
+	(layout (vm-mm-layout m)))
+    (if vm-digest-identifier-header-format
+	(setq ident-header (vm-sprintf 'vm-digest-identifier-header-format m)))
+    (vm-mime-burst-layout layout ident-header)))
+
+(defun vm-mime-burst-layout (layout ident-header)
+  (let ((work-buffer nil)
+	(folder-buffer (current-buffer))
+	start part-list
+	(folder-type vm-folder-type))
+    (unwind-protect
+	(vm-save-restriction
+	 (save-excursion
+	   (widen)
+	   (setq work-buffer (generate-new-buffer "*vm-work*"))
+	   (buffer-disable-undo work-buffer)
+	   (set-buffer work-buffer)
+	   (cond ((not (vectorp layout))
+		  (error "Not a MIME message"))
+		 ((vm-mime-types-match "message"
+				       (car (vm-mm-layout-type layout)))
+		  (insert (vm-leading-message-separator folder-type))
+		  (and ident-header (insert ident-header))
+		  (setq start (point))
+		  (vm-mime-insert-mime-body layout)
+		  (vm-munge-message-separators folder-type start (point))
+		  (insert (vm-trailing-message-separator folder-type)))
+		 ((vm-mime-types-match "multipart/digest"
+				       (car (vm-mm-layout-type layout)))
+		  (setq part-list (vm-mm-layout-parts layout))
+		  (while part-list
+		    ;; Maybe we should verify that each part is
+		    ;; of type message/rfc822 in here.  But it
+		    ;; seems more useful to just copy whatever
+		    ;; the contents are and let teh user see the
+		    ;; goop, whatever type it really is.
+		    (insert (vm-leading-message-separator folder-type))
+		    (and ident-header (insert ident-header))
+		    (setq start (point))
+		    (vm-mime-insert-mime-body (car part-list))
+		    (vm-munge-message-separators folder-type start (point))
+		    (insert (vm-trailing-message-separator folder-type))
+		    (setq part-list (cdr part-list))))
+		 (t (error
+		     "MIME type is not multipart/digest or message/rfc822")))
+	   ;; do header conversions.
+	   (let ((vm-folder-type folder-type))
+	     (goto-char (point-min))
+	     (while (vm-find-leading-message-separator)
+	       (vm-skip-past-leading-message-separator)
+	       (vm-convert-folder-type-headers folder-type folder-type)
+	       (vm-find-trailing-message-separator)
+	       (vm-skip-past-trailing-message-separator)))
+	   ;; now insert the messages into the folder buffer
+	   (cond ((not (zerop (buffer-size)))
+		  (set-buffer folder-buffer)
+		  (let ((old-buffer-modified-p (buffer-modified-p))
+			(buffer-read-only nil)
+			(inhibit-quit t))
+		    (goto-char (point-max))
+		    (insert-buffer-substring work-buffer)
+		    (set-buffer-modified-p old-buffer-modified-p)
+		    ;; return non-nil so caller knows we found some messages
+		    t ))
+		 ;; return nil so the caller knows we didn't find anything
+		 (t nil))))
+	 (and work-buffer (kill-buffer work-buffer)))))
+
 (defun vm-rfc934-char-stuff-region (start end)
   "Quote RFC 934 message separators between START and END.
 START and END are buffer positions in the current buffer.
@@ -92,6 +235,7 @@
 to find out how KEEP-LIST and DISCARD-REGEXP are used."
   (if message-list
       (let ((target-buffer (current-buffer))
+	    (mime-keep-list (append keep-list vm-mime-header-list))
 	    (mlist message-list)
 	    source-buffer m start n)
 	(save-restriction
@@ -116,7 +260,11 @@
 		    (goto-char beg)
 		    (vm-reorder-message-headers nil nil
 						"\\(X-VM-\\|Status:\\)")
-		    (vm-reorder-message-headers nil keep-list discard-regexp)
+		    (vm-reorder-message-headers
+		     nil (if (vm-mime-plain-message-p m)
+			     keep-list
+			   mime-keep-list)
+		     discard-regexp)
 		    (vm-rfc934-char-stuff-region beg (point-max))))))
 	    (goto-char (point-max))
 	    (insert "---------------")
@@ -175,6 +323,7 @@
 to find out how KEEP-LIST and DISCARD-REGEXP are used."
   (if message-list
       (let ((target-buffer (current-buffer))
+	    (mime-keep-list (append keep-list vm-mime-header-list))
 	    (mlist message-list)
 	    source-buffer m start)
 	(save-restriction
@@ -199,7 +348,11 @@
 		    (goto-char beg)
 		    (vm-reorder-message-headers nil nil
 						"\\(X-VM-\\|Status:\\)")
-		    (vm-reorder-message-headers nil keep-list discard-regexp)
+		    (vm-reorder-message-headers
+		     nil (if (vm-mime-plain-message-p m)
+			     keep-list
+			   mime-keep-list)
+		     discard-regexp)
 		    (vm-rfc1153-char-stuff-region beg (point-max))))))
 	    (goto-char (point-max))
 	    (insert "\n---------------")
@@ -228,12 +381,13 @@
 	      separator-regexp "^------------------------------\n")
       (setq prologue-separator-regexp "^-[^ ].*\n"
 	    separator-regexp "^-[^ ].*\n"))
-    (save-excursion
-      (vm-save-restriction
+    (vm-save-restriction
+     (save-excursion
        (widen)
        (unwind-protect
 	   (catch 'done
 	     (setq work-buffer (generate-new-buffer "*vm-work*"))
+	     (buffer-disable-undo work-buffer)
 	     (set-buffer work-buffer)
 	     (insert-buffer-substring (vm-buffer-of m)
 				      (vm-text-of m)
@@ -367,7 +521,9 @@
 		(error "Couldn't guess digest type."))))
       (vm-unsaved-message "Bursting %s digest..." digest-type)
       (cond
-       ((cond ((equal digest-type "rfc934")
+       ((cond ((equal digest-type "mime")
+	       (vm-mime-burst-message m))
+	      ((equal digest-type "rfc934")
 	       (vm-rfc934-burst-message m))
 	      ((equal digest-type "rfc1153")
 	       (vm-rfc1153-burst-message m))
@@ -381,8 +537,10 @@
 	     ;; buffer.  switch back.
 	     (save-excursion
 	       (set-buffer start-buffer)
-	       (vm-delete-message 1)))
-	(vm-assimilate-new-messages t)
+	       ;; don't move message pointer when deleting the message
+	       (let ((vm-move-after-deleting nil))
+		 (vm-delete-message 1))))
+	(vm-assimilate-new-messages t nil (vm-labels-of (car mlist)))
 	;; do this now so if we error later in another iteration
 	;; of the loop the summary and mode line will be correct.
 	(vm-update-summary-and-mode-line)))
@@ -392,6 +550,7 @@
     ;; themselves.
     (setq totals-blurb (vm-emit-totals-blurb))
     (vm-display nil nil '(vm-burst-digest
+			  vm-burst-mime-digest
 			  vm-burst-rfc934-digest
 			  vm-burst-rfc1153-digest)
 		(list this-command))
@@ -410,16 +569,29 @@
   (interactive)
   (vm-burst-digest "rfc1153"))
 
+(defun vm-burst-mime-digest ()
+  "Burst a MIME digest"
+  (interactive)
+  (vm-burst-digest "mime"))
+
 (defun vm-guess-digest-type (m)
   "Guess the digest type of the message M.
 M should be the message struct of a real message.
-Returns either \"rfc934\" or \"rfc1153\"."
-  (save-excursion
-    (set-buffer (vm-buffer-of m))
+Returns either \"rfc934\", \"rfc1153\" or \"mime\"."
+  (catch 'return-value
+    (save-excursion
+      (set-buffer (vm-buffer-of m))
+      (let ((layout (vm-mm-layout m)))
+	(if (and (vectorp layout)
+		 (or (vm-mime-types-match "multipart/digest"
+					  (car (vm-mm-layout-type layout)))
+		     (vm-mime-types-match "message/rfc822"
+					  (car (vm-mm-layout-type layout)))))
+	    (throw 'return-value "mime"))))
     (save-excursion
       (save-restriction
 	(widen)
 	(goto-char (vm-text-of m))
-	(if (search-forward "\n----------------------------------------------------------------------\n" nil t)
-	    "rfc1153"
-	  "rfc934")))))
+	(cond ((search-forward "\n----------------------------------------------------------------------\n" (vm-text-end-of m) t)
+	       "rfc1153")
+	      (t "rfc934"))))))