diff lisp/vm/vm-mime.el @ 136:b980b6286996 r20-2b2

Import from CVS: tag r20-2b2
author cvs
date Mon, 13 Aug 2007 09:31:12 +0200
parents 869e1851236b
children 585fb297b004
line wrap: on
line diff
--- a/lisp/vm/vm-mime.el	Mon Aug 13 09:30:13 2007 +0200
+++ b/lisp/vm/vm-mime.el	Mon Aug 13 09:31:12 2007 +0200
@@ -624,7 +624,7 @@
 				  (vm-headers-of m)
 				  (vm-text-of m)
 				  (vm-text-end-of m)
-				  nil nil nil )))
+				  nil nil )))
 		  ((null type)
 		   (goto-char (point-min))
 		   (or (re-search-forward "^\n\\|\n\\'" nil t)
@@ -635,7 +635,7 @@
 			   (vm-marker (point-min))
 			   (vm-marker (point))
 			   (vm-marker (point-max))
-			   nil nil nil ))
+			   nil nil ))
 		  ((null (string-match "[^/ ]+/[^/ ]+" (car type)))
 		   (vm-mime-error "Malformed MIME content type: %s" (car type)))
 		  ((and (string-match "^multipart/\\|^message/" (car type))
@@ -757,7 +757,8 @@
 	     '("attachment") '("attachment")
 	     header
 	     text
-	     text-end)))))
+	     text-end
+	     nil nil)))))
 
 (defun vm-mime-get-xxx-parameter (layout name param-list)
   (let ((match-end (1+ (length name)))
@@ -824,7 +825,7 @@
 	     (make-local-variable 'scroll-in-place)
 	     (setq scroll-in-place nil)
 	     (and vm-xemacs-mule-p
-		  (set-buffer-file-coding-system 'no-conversion t))
+		  (set-file-coding-system 'binary t))
 	     (cond (vm-fsfemacs-19-p
 		    ;; need to do this outside the let because
 		    ;; loading disp-table initializes
@@ -889,7 +890,7 @@
 (fset 'vm-presentation-mode 'vm-mode)
 (put 'vm-presentation-mode 'mode-class 'special)
 
-(defvar buffer-file-coding-system)
+(defvar file-coding-system)
 
 (defun vm-determine-proper-charset (beg end)
   (save-excursion
@@ -903,9 +904,8 @@
 		     "us-ascii")
 		    ((cdr charsets)
 		     (or (car (cdr
-			       (assq (coding-system-name
-				      buffer-file-coding-system)
-				     vm-mime-mule-coding-to-charset-alist)))
+			       (assoc (coding-system-name file-coding-system)
+				      vm-mime-mule-coding-to-charset-alist)))
 			 "iso-2022-jp"))
 		    (t
 		     (or (car (cdr
@@ -1341,15 +1341,15 @@
 	     (vm-mime-transfer-decode-region layout start end)
 	     (setq tempfile (vm-make-tempfile-name))
 	     (let ((buffer-file-type buffer-file-type)
-		   buffer-file-coding-system)
+		   file-coding-system)
 	       ;; Tell DOS/Windows NT whether the file is binary
 	       (setq buffer-file-type (not (vm-mime-text-type-p layout)))
 	       ;; Tell XEmacs/MULE not to mess with the bits unless
 	       ;; this is a text type.
 	       (if vm-xemacs-mule-p
 		   (if (vm-mime-text-type-p layout)
-		       (set-buffer-file-coding-system 'no-conversion nil)
-		     (set-buffer-file-coding-system 'binary t)))
+		       (set-file-coding-system 'no-conversion nil)
+		     (set-file-coding-system 'binary t)))
 	       (write-region start end tempfile nil 0))
 	     (delete-region start end)
 	     (save-excursion
@@ -1831,10 +1831,11 @@
 	      file (and file (if colorful (nth 2 file) (nth 1 file)))
 	      sym (and file (intern file vm-image-obarray))
 	      glyph (and sym (boundp sym) (symbol-value sym))
-	      glyph (or glyph (not file)
-			(make-glyph
-			 (vector 'autodetect
-				 ':data (expand-file-name file dir)))))
+	      glyph (or glyph
+			(and file
+			     (make-glyph
+			      (vector 'autodetect
+				      ':data (expand-file-name file dir))))))
 	(and sym (not (boundp sym)) (set sym glyph))
 	(and glyph (set-extent-begin-glyph e glyph)))))
 
@@ -1930,8 +1931,8 @@
 	    ;; this is a text type.
 	    (if vm-xemacs-mule-p
 		(if (vm-mime-text-type-p layout)
-		    (set-buffer-file-coding-system 'no-conversion nil)
-		  (set-buffer-file-coding-system 'binary t)))
+		    (set-file-coding-system 'no-conversion nil)
+		  (set-file-coding-system 'binary t)))
 	    (vm-mime-insert-mime-body layout)
 	    (vm-mime-transfer-decode-region layout (point-min) (point-max))
 	    (or (not (file-exists-p file))
@@ -2394,17 +2395,53 @@
     encoding ))
 
 (defun vm-mime-transfer-encode-layout (layout)
-  (let ((encoding
-	 (vm-mime-transfer-encode-region (vm-mm-layout-encoding layout)
-					 (vm-mm-layout-body-start layout)
-					 (vm-mm-layout-body-end layout)
-					 (vm-mime-text-type-p layout))))
-    (save-excursion
-      (save-restriction
-	(goto-char (vm-mm-layout-header-start layout))
-	(narrow-to-region (point) (vm-mm-layout-body-start layout))
-	(vm-reorder-message-headers nil nil "Content-Transfer-Encoding:")
-	(insert "Content-Transfer-Encoding: " encoding "\n")))))
+  (let ((list (vm-mm-layout-parts layout))
+	(type (car (vm-mm-layout-type layout)))
+	(encoding "7bit")
+	(vm-mime-8bit-text-transfer-encoding
+	 vm-mime-8bit-text-transfer-encoding))
+  (cond ((vm-mime-composite-type-p type)
+	 ;; MIME messages of type "message" and
+	 ;; "multipart" are required to have a non-opaque
+	 ;; content transfer encoding.  This means that
+	 ;; if the user only wants to send out 7bit data,
+	 ;; then any subpart that contains 8bit data must
+	 ;; have an opaque (qp or base64) 8->7bit
+	 ;; conversion performed on it so that the
+	 ;; enclosing entity can use a non-opaque
+	 ;; encoding.
+	 ;;
+	 ;; message/partial requires a "7bit" encoding so
+	 ;; force 8->7 conversion in that case.
+	 (cond ((memq vm-mime-8bit-text-transfer-encoding
+		      '(quoted-printable base64))
+		t)
+	       ((vm-mime-types-match "message/partial" type)
+		(setq vm-mime-8bit-text-transfer-encoding
+		      'quoted-printable)))
+	 (while list
+	   (if (equal (vm-mime-transfer-encode-layout (car list)) "8bit")
+	       (setq encoding "8bit"))
+	   (setq list (cdr list))))
+	(t
+	 (if (and (vm-mime-types-match "message/partial" type)
+		  (not (memq vm-mime-8bit-text-transfer-encoding
+			     '(quoted-printable base64))))
+		(setq vm-mime-8bit-text-transfer-encoding
+		      'quoted-printable))
+	 (setq encoding
+	       (vm-mime-transfer-encode-region (vm-mm-layout-encoding layout)
+					       (vm-mm-layout-body-start layout)
+					       (vm-mm-layout-body-end layout)
+					       (vm-mime-text-type-p layout)))))
+  (save-excursion
+    (save-restriction
+      (goto-char (vm-mm-layout-header-start layout))
+      (narrow-to-region (point) (vm-mm-layout-body-start layout))
+      (vm-reorder-message-headers nil nil "Content-Transfer-Encoding:")
+      (if (not (equal encoding "7bit"))
+	  (insert "CONTENT-TRANSFER-ENCODING: " encoding "\n"))
+      encoding ))))
 
 (defun vm-mime-encode-composition ()
  "MIME encode the current mail composition buffer.
@@ -2501,11 +2538,11 @@
 	  (cond ((bufferp object)
 		 (insert-buffer-substring object))
 		((stringp object)
-		 (let ((coding-system-for-read 'no-conversion)
+		 (let ((overriding-file-coding-system 'no-conversion)
 		       ;; don't let file-coding-system be changed
 		       ;; by insert-file-contents-literally.  The
 		       ;; value we bind to it to here isn't important.
-		       (buffer-file-coding-system 'no-conversion))
+		       (file-coding-system 'no-conversion))
 		   (insert-file-contents-literally object))))
 	  ;; gather information about the object from the extent.
 	  (if (setq already-mimed (extent-property e 'vm-mime-encoded))
@@ -2548,41 +2585,13 @@
 				 (point-max)
 				 t))
 		 (setq 8bit (or 8bit (equal encoding "8bit"))))
-		((or (vm-mime-types-match "message/rfc822" type)
-		     (vm-mime-types-match "message/news" type)
-		     (vm-mime-types-match "multipart" type))
+		((vm-mime-composite-type-p type)
 		 (setq opoint-min (point-min))
 		 (if (not already-mimed)
 		     (setq layout (vm-mime-parse-entity
 				   nil (list "text/plain" "charset=us-ascii")
 				   "7bit")))
-		 ;; MIME messages of type "message" and
-		 ;; "multipart" are required to have a non-opaque
-		 ;; content transfer encoding.  This means that
-		 ;; if the user only wants to send out 7bit data,
-		 ;; then any subpart that contains 8bit data must
-		 ;; have an opaque (qp or base64) 8->7bit
-		 ;; conversion performed on it so that the
-		 ;; enclosing entity can use a non-opaque
-		 ;; encoding.
-		 ;;
-		 ;; message/partial requires a "7bit" encoding so
-		 ;; force 8->7 conversion in that case.
-		 (let ((vm-mime-8bit-text-transfer-encoding
-			(if (vm-mime-types-match "message/partial" type)
-			    'quoted-printable
-			  vm-mime-8bit-text-transfer-encoding)))
-		   (vm-mime-map-atomic-layouts 'vm-mime-transfer-encode-layout
-					       (vm-mm-layout-parts layout)))
-		 ;; now figure out a proper content transfer
-		 ;; encoding value for the enclosing entity.
-		 (re-search-forward "^\n" nil t)
-		 (save-restriction
-		   (narrow-to-region (point) (point-max))
-		   (setq encoding
-			 (vm-determine-proper-content-transfer-encoding
-			  (point-min)
-			  (point-max))))
+		 (setq encoding (vm-mime-transfer-encode-layout layout))
 		 (setq 8bit (or 8bit (equal encoding "8bit")))
 		 (goto-char (point-max))
 		 (widen)
@@ -2859,41 +2868,13 @@
 				 (point-max)
 				 t))
 		 (setq 8bit (or 8bit (equal encoding "8bit"))))
-		((or (vm-mime-types-match "message/rfc822" type)
-		     (vm-mime-types-match "message/news" type)
-		     (vm-mime-types-match "multipart" type))
+		((vm-mime-composite-type-p type)
 		 (setq opoint-min (point-min))
 		 (if (not already-mimed)
 		     (setq layout (vm-mime-parse-entity
 				   nil (list "text/plain" "charset=us-ascii")
 				   "7bit")))
-		 ;; MIME messages of type "message" and
-		 ;; "multipart" are required to have a non-opaque
-		 ;; content transfer encoding.  This means that
-		 ;; if the user only wants to send out 7bit data,
-		 ;; then any subpart that contains 8bit data must
-		 ;; have an opaque (qp or base64) 8->7bit
-		 ;; conversion performed on it so that the
-		 ;; enclosing entity can use a non-opaque
-		 ;; encoding.
-		 ;;
-		 ;; message/partial requires a "7bit" encoding so
-		 ;; force 8->7 conversion in that case.
-		 (let ((vm-mime-8bit-text-transfer-encoding
-			(if (vm-mime-types-match "message/partial" type)
-			    'quoted-printable
-			  vm-mime-8bit-text-transfer-encoding)))
-		   (vm-mime-map-atomic-layouts 'vm-mime-transfer-encode-layout
-					       (vm-mm-layout-parts layout)))
-		 ;; now figure out a proper content transfer
-		 ;; encoding value for the enclosing entity.
-		 (re-search-forward "^\n" nil t)
-		 (save-restriction
-		   (narrow-to-region (point) (point-max))
-		   (setq encoding
-			 (vm-determine-proper-content-transfer-encoding
-			  (point-min)
-			  (point-max))))
+		 (setq encoding (vm-mime-transfer-encode-layout layout))
 		 (setq 8bit (or 8bit (equal encoding "8bit")))
 		 (goto-char (point-max))
 		 (widen)
@@ -3045,16 +3026,15 @@
 	  b header-start header-end master-buffer start end)
       (vm-remove-mail-mode-header-separator)
       ;; message/partial must have "7bit" content transfer
-      ;; encoding, so verify that everything has been encoded for
+      ;; encoding, so force everything to be encoded for
       ;; 7bit transmission.
       (let ((vm-mime-8bit-text-transfer-encoding
 	     (if (eq vm-mime-8bit-text-transfer-encoding '8bit)
 		 'quoted-printable
 	       vm-mime-8bit-text-transfer-encoding)))
-	(vm-mime-map-atomic-layouts
-	 'vm-mime-transfer-encode-layout
-	 (list (vm-mime-parse-entity nil (list "text/plain" "charset=us-ascii")
-				     "7bit"))))
+	(vm-mime-transfer-encode-layout
+	 (vm-mime-parse-entity nil (list "text/plain" "charset=us-ascii")
+			       "7bit")))
       (goto-char (point-min))
       (setq header-start (point))
       (search-forward "\n\n")
@@ -3156,12 +3136,16 @@
       (and temp-buffer (kill-buffer temp-buffer)))))
 
 (defun vm-mime-composite-type-p (type)
-  (or (vm-mime-types-match "message" type)
+  (or (and (vm-mime-types-match "message" type)
+	   (not (vm-mime-types-match "message/partial" type))
+	   (not (vm-mime-types-match "message/external-body" type)))
       (vm-mime-types-match "multipart" type)))
 
-(defun vm-mime-map-atomic-layouts (function list)
-  (while list
-    (if (vm-mime-composite-type-p (car (vm-mm-layout-type (car list))))
-	(vm-mime-map-atomic-layouts function (vm-mm-layout-parts (car list)))
-      (funcall function (car list)))
-    (setq list (cdr list))))
+;; Unused currrently.
+;;
+;;(defun vm-mime-map-atomic-layouts (function list)
+;;  (while list
+;;    (if (vm-mime-composite-type-p (car (vm-mm-layout-type (car list))))
+;;	(vm-mime-map-atomic-layouts function (vm-mm-layout-parts (car list)))
+;;      (funcall function (car list)))
+;;    (setq list (cdr list))))