X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmml.el;h=8c7b849da4833d687a8c6b4befc144d312551b95;hb=08f32419df2e29626bb6c3f270a34aa8b5f95b6d;hp=70abd888bcb22c4f5b96dda3870563abd8b2c4f3;hpb=9f158785ed0902adf59c06790f04d364cd687a61;p=gnus

diff --git a/lisp/mml.el b/lisp/mml.el
index 70abd888b..8c7b849da 100644
--- a/lisp/mml.el
+++ b/lisp/mml.el
@@ -1,5 +1,5 @@
 ;;; mml.el --- A package for parsing and validating MML documents
-;; Copyright (C) 1998,99 Free Software Foundation, Inc.
+;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; This file is part of GNU Emacs.
@@ -26,9 +26,24 @@
 (require 'mm-util)
 (require 'mm-bodies)
 (require 'mm-encode)
+(require 'mm-decode)
+(eval-when-compile (require 'cl))
 
 (eval-and-compile
-  (autoload 'message-make-message-id "message"))
+  (autoload 'message-make-message-id "message")
+  (autoload 'gnus-setup-posting-charset "gnus-msg")
+  (autoload 'message-fetch-field "message")
+  (autoload 'message-posting-charset "message"))
+
+(defvar mml-generate-multipart-alist nil
+  "*Alist of multipart generation functions.
+Each entry has the form (NAME . FUNCTION), where
+NAME is a string containing the name of the part (without the 
+leading \"/multipart/\"),
+FUNCTION is a Lisp function which is called to generate the part.
+
+The Lisp function has to supply the appropriate MIME headers and the
+contents of this part.")
 
 (defvar mml-syntax-table
   (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table)))
@@ -43,6 +58,43 @@
     (modify-syntax-entry ?\' " " table)
     table))
 
+(defvar mml-boundary-function 'mml-make-boundary
+  "A function called to suggest a boundary.
+The function may be called several times, and should try to make a new
+suggestion each time.  The function is called with one parameter,
+which is a number that says how many times the function has been
+called for this message.")
+
+(defvar mml-confirmation-set nil
+  "A list of symbols, each of which disables some warning.
+`unknown-encoding': always send messages contain characters with
+unknown encoding; `use-ascii': always use ASCII for those characters
+with unknown encoding; `multipart': always send messages with more than
+one charsets.")
+
+(defvar mml-generate-mime-preprocess-function nil
+  "A function called before generating a mime part.
+The function is called with one parameter, which is the part to be 
+generated.")
+
+(defvar mml-generate-mime-postprocess-function nil
+  "A function called after generating a mime part.
+The function is called with one parameter, which is the generated part.")
+
+(defvar mml-generate-default-type "text/plain")
+
+(defvar mml-buffer-list nil)
+
+(defun mml-generate-new-buffer (name) 
+  (let ((buf (generate-new-buffer name)))
+    (push buf mml-buffer-list)
+    buf))
+
+(defun mml-destroy-buffers ()
+  (let (kill-buffer-hook)
+    (mapcar 'kill-buffer mml-buffer-list)
+    (setq mml-buffer-list nil)))
+
 (defun mml-parse ()
   "Parse the current buffer as an MML document."
   (goto-char (point-min))
@@ -55,7 +107,7 @@
 
 (defun mml-parse-1 ()
   "Parse the current buffer as an MML document."
-  (let (struct tag point contents charsets warn)
+  (let (struct tag point contents charsets warn use-ascii no-markup-p raw)
     (while (and (not (eobp))
 		(not (looking-at "<#/multipart")))
       (cond
@@ -65,23 +117,44 @@
 	(push (nconc (mml-read-tag) (list (cons 'contents (mml-read-part))))
 	      struct))
        (t
-	(if (looking-at "<#part")
-	    (setq tag (mml-read-tag))
+	(if (or (looking-at "<#part") (looking-at "<#mml"))
+	    (setq tag (mml-read-tag)
+		  no-markup-p nil
+		  warn nil)
 	  (setq tag (list 'part '(type . "text/plain"))
+		no-markup-p t
 		warn t))
-	(setq point (point)
-	      contents (mml-read-part)
-	      charsets (mm-find-mime-charset-region point (point)))
-	(if (< (length charsets) 2)
-	    (push (nconc tag (list (cons 'contents contents)))
-		  struct)
+	(setq raw (cdr (assq 'raw tag))
+	      point (point)
+	      contents (mml-read-part (eq 'mml (car tag)))
+	      charsets (if raw nil 
+			 (mm-find-mime-charset-region point (point))))
+	(when (and (not raw) (memq nil charsets))
+	  (if (or (memq 'unknown-encoding mml-confirmation-set)
+		  (y-or-n-p
+		   "Message contains characters with unknown encoding.  Really send?"))
+	      (if (setq use-ascii 
+			(or (memq 'use-ascii mml-confirmation-set)
+			    (y-or-n-p "Use ASCII as charset?")))
+		  (setq charsets (delq nil charsets))
+		(setq warn nil))
+	    (error "Edit your message to remove those characters")))
+	(if (or raw
+		(eq 'mml (car tag))
+		(< (length charsets) 2))
+	    (if (or (not no-markup-p)
+		    (string-match "[^ \t\r\n]" contents))
+		;; Don't create blank parts.
+		(push (nconc tag (list (cons 'contents contents)))
+		      struct))
 	  (let ((nstruct (mml-parse-singlepart-with-multiple-charsets
-			  tag point (point))))
+			  tag point (point) use-ascii)))
 	    (when (and warn
+		       (not (memq 'multipart mml-confirmation-set))
 		       (not
 			(y-or-n-p
 			 (format
-			  "Warning: Your message contains %d parts.  Really send? "
+			  "Warning: Your message contains more than %d parts.  Really send? "
 			  (length nstruct)))))
 	      (error "Edit your message to use only one charset"))
 	    (setq struct (nconc nstruct struct)))))))
@@ -89,56 +162,63 @@
       (forward-line 1))
     (nreverse struct)))
 
-(defun mml-parse-singlepart-with-multiple-charsets (orig-tag beg end)
+(defun mml-parse-singlepart-with-multiple-charsets 
+  (orig-tag beg end &optional use-ascii)
   (save-excursion
-    (narrow-to-region beg end)
-    (goto-char (point-min))
-    (let ((current (mm-mime-charset (char-charset (following-char))))
-	  charset struct space newline paragraph)
-      (while (not (eobp))
-	(cond
-	 ;; The charset remains the same.
-	 ((or (eq (setq charset (mm-mime-charset
-				 (char-charset (following-char)))) 'us-ascii)
-	      (eq charset current)))
-	 ;; The initial charset was ascii.
-	 ((eq current 'us-ascii)
-	  (setq current charset
-		space nil
-		newline nil
-		paragraph nil))
-	 ;; We have a change in charsets.
-	 (t
-	  (push (append
-		 orig-tag
-		 (list (cons 'contents
-			     (buffer-substring-no-properties
-			      beg (or paragraph newline space (point))))))
-		struct)
-	  (setq beg (or paragraph newline space (point))
-		current charset
-		space nil
-		newline nil
-		paragraph nil)))
-	;; Compute places where it might be nice to break the part.
-	(cond
-	 ((memq (following-char) '(?  ?\t))
-	  (setq space (1+ (point))))
-	 ((eq (following-char) ?\n)
-	  (setq newline (1+ (point))))
-	 ((and (eq (following-char) ?\n)
-	       (not (bobp))
-	       (eq (char-after (1- (point))) ?\n))
-	  (setq paragraph (point))))
-	(forward-char 1))
-      ;; Do the final part.
-      (unless (= beg (point))
-	(push (append orig-tag
-		      (list (cons 'contents
-				  (buffer-substring-no-properties
-				   beg (point)))))
-	      struct))
-      struct)))
+    (save-restriction
+      (narrow-to-region beg end)
+      (goto-char (point-min))
+      (let ((current (or (mm-mime-charset (mm-charset-after))
+			 (and use-ascii 'us-ascii)))
+	    charset struct space newline paragraph)
+	(while (not (eobp))
+	  (setq charset (mm-mime-charset (mm-charset-after)))
+	  (cond
+	   ;; The charset remains the same.
+	   ((eq charset 'us-ascii))
+	   ((or (and use-ascii (not charset))
+		(eq charset current))
+	    (setq space nil
+		  newline nil
+		  paragraph nil))
+	   ;; The initial charset was ascii.
+	   ((eq current 'us-ascii)
+	    (setq current charset
+		  space nil
+		  newline nil
+		  paragraph nil))
+	   ;; We have a change in charsets.
+	   (t
+	    (push (append
+		   orig-tag
+		   (list (cons 'contents
+			       (buffer-substring-no-properties
+				beg (or paragraph newline space (point))))))
+		  struct)
+	    (setq beg (or paragraph newline space (point))
+		  current charset
+		  space nil
+		  newline nil
+		  paragraph nil)))
+	  ;; Compute places where it might be nice to break the part.
+	  (cond
+	   ((memq (following-char) '(?  ?\t))
+	    (setq space (1+ (point))))
+	   ((and (eq (following-char) ?\n)
+		 (not (bobp))
+		 (eq (char-after (1- (point))) ?\n))
+	    (setq paragraph (point)))
+	   ((eq (following-char) ?\n)
+	    (setq newline (1+ (point)))))
+	  (forward-char 1))
+	;; Do the final part.
+	(unless (= beg (point))
+	  (push (append orig-tag
+			(list (cons 'contents
+				    (buffer-substring-no-properties
+				     beg (point)))))
+		struct))
+	struct))))
 
 (defun mml-read-tag ()
   "Read a tag and return the contents."
@@ -161,22 +241,32 @@
     (skip-chars-forward " \t\n")
     (cons (intern name) (nreverse contents))))
 
-(defun mml-read-part ()
-  "Return the buffer up till the next part, multipart or closing part or multipart."
-  (let ((beg (point)))
+(defun mml-read-part (&optional mml)
+  "Return the buffer up till the next part, multipart or closing part or multipart.
+If MML is non-nil, return the buffer up till the correspondent mml tag."
+  (let ((beg (point)) (count 1))
     ;; If the tag ended at the end of the line, we go to the next line.
     (when (looking-at "[ \t]*\n")
       (forward-line 1))
-    (if (re-search-forward
-	 "<#\\(/\\)?\\(multipart\\|part\\|external\\)." nil t)
-	(prog1
-	    (buffer-substring-no-properties beg (match-beginning 0))
-	  (if (or (not (match-beginning 1))
-		  (equal (match-string 2) "multipart"))
-	      (goto-char (match-beginning 0))
-	    (when (looking-at "[ \t]*\n")
-	      (forward-line 1))))
-      (buffer-substring-no-properties beg (goto-char (point-max))))))
+    (if mml
+	(progn
+	  (while (and (> count 0) (not (eobp)))
+	    (if (re-search-forward "<#\\(/\\)?mml." nil t)
+		(setq count (+ count (if (match-beginning 1) -1 1)))
+	      (goto-char (point-max))))
+	  (buffer-substring-no-properties beg (if (> count 0) 
+						  (point)
+						(match-beginning 0))))
+      (if (re-search-forward
+	   "<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)." nil t)
+	  (prog1
+	      (buffer-substring-no-properties beg (match-beginning 0))
+	    (if (or (not (match-beginning 1))
+		    (equal (match-string 2) "multipart"))
+		(goto-char (match-beginning 0))
+	      (when (looking-at "[ \t]*\n")
+		(forward-line 1))))
+	(buffer-substring-no-properties beg (goto-char (point-max)))))))
 
 (defvar mml-boundary nil)
 (defvar mml-base-boundary "-=-=")
@@ -185,7 +275,7 @@
 (defun mml-generate-mime ()
   "Generate a MIME message based on the current MML document."
   (let ((cont (mml-parse))
-	(mml-multipart-number 0))
+	(mml-multipart-number mml-multipart-number))
     (if (not cont)
 	nil
       (with-temp-buffer
@@ -197,93 +287,129 @@
 	(buffer-string)))))
 
 (defun mml-generate-mime-1 (cont)
-  (cond
-   ((eq (car cont) 'part)
-    (let (coded encoding charset filename type)
-      (setq type (or (cdr (assq 'type cont)) "text/plain"))
-      (if (equal (car (split-string type "/")) "text")
-	  (with-temp-buffer
+  (save-restriction
+    (narrow-to-region (point) (point))
+    (if mml-generate-mime-preprocess-function
+	(funcall mml-generate-mime-preprocess-function cont))
+    (cond
+     ((or (eq (car cont) 'part) (eq (car cont) 'mml))
+      (let ((raw (cdr (assq 'raw cont)))
+	    coded encoding charset filename type)
+	(setq type (or (cdr (assq 'type cont)) "text/plain"))
+	(if (and (not raw)
+		 (member (car (split-string type "/")) '("text" "message")))
+	    (with-temp-buffer
+	      (cond
+	       ((cdr (assq 'buffer cont))
+		(insert-buffer-substring (cdr (assq 'buffer cont))))
+	       ((and (setq filename (cdr (assq 'filename cont)))
+		     (not (equal (cdr (assq 'nofile cont)) "yes")))
+		(mm-insert-file-contents filename))
+	       ((eq 'mml (car cont))
+		(insert (cdr (assq 'contents cont))))
+	       (t
+		(save-restriction
+		  (narrow-to-region (point) (point))
+		  (insert (cdr (assq 'contents cont)))
+		  ;; Remove quotes from quoted tags.
+		  (goto-char (point-min))
+		  (while (re-search-forward
+			  "<#!+/?\\(part\\|multipart\\|external\\|mml\\)" nil t)
+		    (delete-region (+ (match-beginning 0) 2)
+				   (+ (match-beginning 0) 3))))))
+	      (cond 
+	       ((eq (car cont) 'mml)
+		(let ((mml-boundary (funcall mml-boundary-function
+					     (incf mml-multipart-number)))
+		      (mml-generate-default-type "text/plain"))
+		  (mml-to-mime))
+		(let ((mm-7bit-chars (concat mm-7bit-chars "\x1b")))
+		  ;; ignore 0x1b, it is part of iso-2022-jp
+		  (setq encoding (mm-body-7-or-8))))
+	       ((string= (car (split-string type "/")) "message")
+		(let ((mm-7bit-chars (concat mm-7bit-chars "\x1b")))
+		  ;; ignore 0x1b, it is part of iso-2022-jp
+		  (setq encoding (mm-body-7-or-8))))
+	       (t 
+		(setq charset (mm-encode-body))
+		(setq encoding (mm-body-encoding
+				charset (cdr (assq 'encoding cont))))))
+	      (setq coded (buffer-string)))
+	  (mm-with-unibyte-buffer
 	    (cond
 	     ((cdr (assq 'buffer cont))
 	      (insert-buffer-substring (cdr (assq 'buffer cont))))
-	     ((setq filename (cdr (assq 'filename cont)))
-	      (insert-file-contents-literally filename))
+	     ((and (setq filename (cdr (assq 'filename cont)))
+		   (not (equal (cdr (assq 'nofile cont)) "yes")))
+	      (let ((coding-system-for-read mm-binary-coding-system))
+		(mm-insert-file-contents filename nil nil nil nil t)))
 	     (t
-	      (save-restriction
-		(narrow-to-region (point) (point))
-		(insert (cdr (assq 'contents cont)))
-		;; Remove quotes from quoted tags.
-		(goto-char (point-min))
-		(while (re-search-forward
-			"<#!+/?\\(part\\|multipart\\|external\\)" nil t)
-		  (delete-region (+ (match-beginning 0) 2)
-				 (+ (match-beginning 0) 3))))))
-	    (setq charset (mm-encode-body))
-	    (setq encoding (mm-body-encoding charset))
-	    (setq coded (buffer-string)))
-	(mm-with-unibyte-buffer
-	  (cond
-	   ((cdr (assq 'buffer cont))
-	    (insert-buffer-substring (cdr (assq 'buffer cont))))
-	   ((setq filename (cdr (assq 'filename cont)))
-	    (insert-file-contents-literally filename))
-	   (t
-	    (insert (cdr (assq 'contents cont)))))
-	  (setq encoding (mm-encode-buffer type)
-		coded (buffer-string))))
-      (mml-insert-mime-headers cont type charset encoding)
-      (insert "\n")
-      (insert coded)))
-   ((eq (car cont) 'external)
-    (insert "Content-Type: message/external-body")
-    (let ((parameters (mml-parameter-string
-		       cont '(expiration size permission)))
-	  (name (cdr (assq 'name cont))))
-      (when name
-	(setq name (mml-parse-file-name name))
-	(if (stringp name)
+	      (insert (cdr (assq 'contents cont)))))
+	    (setq encoding (mm-encode-buffer type)
+		  coded (buffer-string))))
+	(mml-insert-mime-headers cont type charset encoding)
+	(insert "\n")
+	(insert coded)))
+     ((eq (car cont) 'external)
+      (insert "Content-Type: message/external-body")
+      (let ((parameters (mml-parameter-string
+			 cont '(expiration size permission)))
+	    (name (cdr (assq 'name cont))))
+	(when name
+	  (setq name (mml-parse-file-name name))
+	  (if (stringp name)
+	      (mml-insert-parameter
+	       (mail-header-encode-parameter "name" name)
+	       "access-type=local-file")
 	    (mml-insert-parameter
-	     (mail-header-encode-parameter "name" name)
-	     "access-type=local-file")
-	  (mml-insert-parameter
-	   (mail-header-encode-parameter
-	    "name" (file-name-nondirectory (nth 2 name)))
-	   (mail-header-encode-parameter "site" (nth 1 name))
-	   (mail-header-encode-parameter
-	    "directory" (file-name-directory (nth 2 name))))
-	  (mml-insert-parameter
-	   (concat "access-type="
-		   (if (member (nth 0 name) '("ftp@" "anonymous@"))
-		       "anon-ftp"
-		     "ftp")))))      
-      (when parameters
-	(mml-insert-parameter-string
-	 cont '(expiration size permission))))
-    (insert "\n\n")
-    (insert "Content-Type: " (cdr (assq 'type cont)) "\n")
-    (insert "Content-ID: " (message-make-message-id) "\n")
-    (insert "Content-Transfer-Encoding: "
-	    (or (cdr (assq 'encoding cont)) "binary"))
-    (insert "\n\n")
-    (insert (or (cdr (assq 'contents cont))))
-    (insert "\n"))
-   ((eq (car cont) 'multipart)
-    (let ((mml-boundary (mml-compute-boundary cont)))
-      (insert (format "Content-Type: multipart/%s; boundary=\"%s\"\n"
-		      (or (cdr (assq 'type cont)) "mixed")
-		      mml-boundary))
-      (insert "\n")
-      (setq cont (cddr cont))
-      (while cont
-	(insert "\n--" mml-boundary "\n")
-	(mml-generate-mime-1 (pop cont)))
-      (insert "\n--" mml-boundary "--\n")))
-   (t
-    (error "Invalid element: %S" cont))))
+	     (mail-header-encode-parameter
+	      "name" (file-name-nondirectory (nth 2 name)))
+	     (mail-header-encode-parameter "site" (nth 1 name))
+	     (mail-header-encode-parameter
+	      "directory" (file-name-directory (nth 2 name))))
+	    (mml-insert-parameter
+	     (concat "access-type="
+		     (if (member (nth 0 name) '("ftp@" "anonymous@"))
+			 "anon-ftp"
+		       "ftp")))))      
+	(when parameters
+	  (mml-insert-parameter-string
+	   cont '(expiration size permission))))
+      (insert "\n\n")
+      (insert "Content-Type: " (cdr (assq 'type cont)) "\n")
+      (insert "Content-ID: " (message-make-message-id) "\n")
+      (insert "Content-Transfer-Encoding: "
+	      (or (cdr (assq 'encoding cont)) "binary"))
+      (insert "\n\n")
+      (insert (or (cdr (assq 'contents cont))))
+      (insert "\n"))
+     ((eq (car cont) 'multipart)
+      (let* ((type (or (cdr (assq 'type cont)) "mixed"))
+	     (mml-generate-default-type (if (equal type "digest")
+					    "message/rfc822"
+					  "text/plain"))
+	     (handler (assoc type mml-generate-multipart-alist)))
+	(if handler
+	    (funcall (cdr handler) cont)
+	  ;; No specific handler.  Use default one.
+	  (let ((mml-boundary (mml-compute-boundary cont)))
+	    (insert (format "Content-Type: multipart/%s; boundary=\"%s\"\n"
+			    type mml-boundary))
+	    ;; Skip `multipart' and `type' elements.
+	    (setq cont (cddr cont))
+	    (while cont
+	      (insert "\n--" mml-boundary "\n")
+	      (mml-generate-mime-1 (pop cont)))
+	    (insert "\n--" mml-boundary "--\n")))))
+     (t
+      (error "Invalid element: %S" cont)))
+    (if mml-generate-mime-postprocess-function
+	(funcall mml-generate-mime-postprocess-function cont))))
 
 (defun mml-compute-boundary (cont)
   "Return a unique boundary that does not exist in CONT."
-  (let ((mml-boundary (mml-make-boundary)))
+  (let ((mml-boundary (funcall mml-boundary-function
+			       (incf mml-multipart-number))))
     ;; This function tries again and again until it has found
     ;; a unique boundary.
     (while (not (catch 'not-unique
@@ -298,32 +424,28 @@
 	(cond
 	 ((cdr (assq 'buffer cont))
 	  (insert-buffer-substring (cdr (assq 'buffer cont))))
-	 ((setq filename (cdr (assq 'filename cont)))
-	  (insert-file-contents-literally filename))
+	 ((and (setq filename (cdr (assq 'filename cont)))
+	       (not (equal (cdr (assq 'nofile cont)) "yes")))
+	  (mm-insert-file-contents filename))
 	 (t
 	  (insert (cdr (assq 'contents cont)))))
 	(goto-char (point-min))
 	(when (re-search-forward (concat "^--" (regexp-quote mml-boundary))
 				 nil t)
-	  (setq mml-boundary (mml-make-boundary))
+	  (setq mml-boundary (funcall mml-boundary-function
+				      (incf mml-multipart-number)))
 	  (throw 'not-unique nil))))
      ((eq (car cont) 'multipart)
       (mapcar 'mml-compute-boundary-1 (cddr cont))))
     t))
 
-(defun mml-make-boundary ()
-  (concat (make-string (% (incf mml-multipart-number) 60) ?=)
-	  (if (> mml-multipart-number 17)
-	      (format "%x" mml-multipart-number)
+(defun mml-make-boundary (number)
+  (concat (make-string (% number 60) ?=)
+	  (if (> number 17)
+	      (format "%x" number)
 	    "")
 	  mml-base-boundary))
 
-(defun mml-make-string (num string)
-  (let ((out ""))
-    (while (not (zerop (decf num)))
-      (setq out (concat out string)))
-    out))
-
 (defun mml-insert-mime-headers (cont type charset encoding)
   (let (parameters disposition description)
     (setq parameters
@@ -331,7 +453,7 @@
 	   cont '(name access-type expiration size permission)))
     (when (or charset
 	      parameters
-	      (not (equal type "text/plain")))
+	      (not (equal type mml-generate-default-type)))
       (when (consp charset)
 	(error
 	 "Can't encode a part with several charsets."))
@@ -384,13 +506,13 @@
 	 (mail-header-encode-parameter
 	  (symbol-name type) value))))))
 
-(defvar ange-ftp-path-format)
+(defvar ange-ftp-name-format)
 (defvar efs-path-regexp)
 (defun mml-parse-file-name (path)
   (if (if (boundp 'efs-path-regexp)
 	  (string-match efs-path-regexp path)
-	(if (boundp 'ange-ftp-path-format)
-	    (string-match (car ange-ftp-path-format))))
+	(if (boundp 'ange-ftp-name-format)
+	    (string-match (car ange-ftp-name-format) path)))
       (list (match-string 1 path) (match-string 2 path)
 	    (substring path (1+ (match-end 2))))
     path))
@@ -420,44 +542,63 @@
     (if (stringp (car handles))
 	(mml-insert-mime handles)
       (mml-insert-mime handles t))
-    (mm-destroy-parts handles)))
+    (mm-destroy-parts handles))
+  (save-restriction
+    (message-narrow-to-head)
+    ;; Remove them, they are confusing.
+    (message-remove-header "Content-Type")
+    (message-remove-header "MIME-Version")
+    (message-remove-header "Content-Transfer-Encoding")))
 
 (defun mml-to-mime ()
   "Translate the current buffer from MML to MIME."
   (message-encode-message-body)
   (save-restriction
-    (message-narrow-to-headers)
-    (mail-encode-encoded-word-buffer)))
+    (message-narrow-to-headers-or-head)
+    (let ((mail-parse-charset message-default-charset))
+      (mail-encode-encoded-word-buffer))))
 
 (defun mml-insert-mime (handle &optional no-markup)
-  (let (textp buffer)
+  (let (textp buffer mmlp)
     ;; Determine type and stuff.
     (unless (stringp (car handle))
-      (unless (setq textp (equal
-			   (car (split-string
-				 (car (mm-handle-type handle)) "/"))
-			   "text"))
+      (unless (setq textp (equal (mm-handle-media-supertype handle) "text"))
 	(save-excursion
-	  (set-buffer (setq buffer (generate-new-buffer " *mml*")))
-	  (mm-insert-part handle))))
-    (unless no-markup
-      (mml-insert-mml-markup handle buffer))
+	  (set-buffer (setq buffer (mml-generate-new-buffer " *mml*")))
+	  (mm-insert-part handle)
+	  (if (setq mmlp (equal (mm-handle-media-type handle) 
+				"message/rfc822"))
+	      (mime-to-mml)))))
+    (if mmlp
+	(mml-insert-mml-markup handle nil t t)
+      (unless (and no-markup
+		   (equal (mm-handle-media-type handle) "text/plain"))
+	(mml-insert-mml-markup handle buffer textp)))
     (cond
+     (mmlp 
+      (insert-buffer buffer)
+      (goto-char (point-max))
+      (insert "<#/mml>\n"))
      ((stringp (car handle))
       (mapcar 'mml-insert-mime (cdr handle))
       (insert "<#/multipart>\n"))
      (textp
-      (mm-insert-part handle)
+      (let ((text (mm-get-part handle))
+	    (charset (mail-content-type-get
+		      (mm-handle-type handle) 'charset)))
+	(insert (mm-decode-string text charset)))
       (goto-char (point-max)))
      (t
       (insert "<#/part>\n")))))
 
-(defun mml-insert-mml-markup (handle &optional buffer)
+(defun mml-insert-mml-markup (handle &optional buffer nofile mmlp)
   "Take a MIME handle and insert an MML tag."
   (if (stringp (car handle))
-      (insert "<#multipart type=" (cadr (split-string (car handle) "/"))
+      (insert "<#multipart type=" (mm-handle-media-subtype handle)
 	      ">\n")
-    (insert "<#part type=" (car (mm-handle-type handle)))
+    (if mmlp
+	(insert "<#mml type=" (mm-handle-media-type handle))
+      (insert "<#part type=" (mm-handle-media-type handle)))
     (dolist (elem (append (cdr (mm-handle-type handle))
 			  (cdr (mm-handle-disposition handle))))
       (insert " " (symbol-name (car elem)) "=\"" (cdr elem) "\""))
@@ -465,9 +606,10 @@
       (insert " disposition=" (car (mm-handle-disposition handle))))
     (when buffer
       (insert " buffer=\"" (buffer-name buffer) "\""))
+    (when nofile
+      (insert " nofile=yes"))
     (when (mm-handle-description handle)
       (insert " description=\"" (mm-handle-description handle) "\""))
-    (equal (split-string (car (mm-handle-type handle)) "/") "text")
     (insert ">\n")))
 
 (defun mml-insert-parameter (&rest parameters)
@@ -496,6 +638,7 @@
     (define-key map "p" 'mml-insert-part)
     (define-key map "v" 'mml-validate)
     (define-key map "P" 'mml-preview)
+    ;;(define-key map "n" 'mml-narrow-to-part)
     (define-key main "\M-m" map)
     main))
 
@@ -509,8 +652,10 @@
    ("Insert"
     ["Multipart" mml-insert-multipart t]
     ["Part" mml-insert-part t])
+   ;;["Narrow" mml-narrow-to-part t]
    ["Quote" mml-quote-region t]
-   ["Validate" mml-validate t]))
+   ["Validate" mml-validate t]
+   ["Preview" mml-preview t]))
 
 (defvar mml-mode nil
   "Minor mode for editing MML.")
@@ -550,6 +695,7 @@
     file))
 
 (defun mml-minibuffer-read-type (name &optional default)
+  (mailcap-parse-mimetypes)
   (let* ((default (or default
 		      (mm-default-file-encoding name)
 		      ;; Perhaps here we should check what the file
@@ -558,27 +704,7 @@
 		      "application/octet-stream"))
 	 (string (completing-read
 		  (format "Content type (default %s): " default)
-		  (mapcar
-		   'list
-		   (delete-duplicates
-		    (nconc
-		     (mapcar (lambda (m) (cdr m))
-			     mailcap-mime-extensions)
-		     (apply
-		      'nconc
-		      (mapcar
-		       (lambda (l)
-			 (delq nil
-			       (mapcar
-				(lambda (m)
-				  (let ((type (cdr (assq 'type (cdr m)))))
-				    (if (equal (cadr (split-string type "/"))
-					       "*")
-					nil
-				      type)))
-				(cdr l))))
-		       mailcap-mime-data)))
-		    :test 'equal)))))
+		  (mapcar 'list (mailcap-mime-types)))))
     (if (not (equal string ""))
 	string
       default)))
@@ -600,8 +726,9 @@
       (goto-char (point-min))
       ;; Quote parts.
       (while (re-search-forward
-	      "<#/?!*\\(multipart\\|part\\|external\\)" nil t)
-	(goto-char (match-beginning 1))
+	      "<#!*/?\\(multipart\\|part\\|external\\|mml\\)" nil t)
+	;; Insert ! after the #.
+	(goto-char (+ (match-beginning 0) 2))
 	(insert "!")))))
 
 (defun mml-insert-tag (name &rest plist)
@@ -614,10 +741,17 @@
 	  (value (pop plist)))
       (when value
 	;; Quote VALUE if it contains suspicious characters.
-	(when (string-match "[\"\\~/* \t\n]" value)
+	(when (string-match "[\"'\\~/*;() \t\n]" value)
 	  (setq value (prin1-to-string value)))
 	(insert (format " %s=%s" key value)))))
-  (insert ">\n<#/part>\n"))
+  (insert ">\n"))
+
+(defun mml-insert-empty-tag (name &rest plist)
+  "Insert an empty MML tag described by NAME and PLIST."
+  (when (symbolp name)
+    (setq name (symbol-name name)))
+  (apply #'mml-insert-tag name plist)
+  (insert "<#/" name ">\n"))
 
 ;;; Attachment functions.
 
@@ -634,8 +768,8 @@ description of the attachment."
 	  (type (mml-minibuffer-read-type file))
 	  (description (mml-minibuffer-read-description)))
      (list file type description)))
-  (mml-insert-tag 'part 'type type 'filename file 'disposition "attachment"
-		  'description description))
+  (mml-insert-empty-tag 'part 'type type 'filename file
+			'disposition "attachment" 'description description))
 
 (defun mml-attach-buffer (buffer &optional type description)
   "Attach a buffer to the outgoing MIME message.
@@ -645,8 +779,8 @@ See `mml-attach-file' for details of operation."
 	  (type (mml-minibuffer-read-type buffer "text/plain"))
 	  (description (mml-minibuffer-read-description)))
      (list buffer type description)))
-  (mml-insert-tag 'part 'type type 'buffer buffer 'disposition "attachment"
-		  'description description))
+  (mml-insert-empty-tag 'part 'type type 'buffer buffer
+			'disposition "attachment" 'description description))
 
 (defun mml-attach-external (file &optional type description)
   "Attach an external file into the buffer.
@@ -657,39 +791,64 @@ TYPE is the MIME type to use."
 	  (type (mml-minibuffer-read-type file))
 	  (description (mml-minibuffer-read-description)))
      (list file type description)))
-  (mml-insert-tag 'external 'type type 'name file 'disposition "attachment"
-		  'description description))
+  (mml-insert-empty-tag 'external 'type type 'name file
+			'disposition "attachment" 'description description))
 
 (defun mml-insert-multipart (&optional type)
-  (interactive (list (completing-read "Multipart type (default mixed): ")
-		     "mixed"
-		     '(("mixed") ("alternative") ("digest") ("parallel")
-		       ("signed") ("encrypted"))))
+  (interactive (list (completing-read "Multipart type (default mixed): "
+				      '(("mixed") ("alternative") ("digest") ("parallel")
+					("signed") ("encrypted"))
+				      nil nil "mixed")))
   (or type
       (setq type "mixed"))
-  (mml-insert-tag "multipart" 'type type)
-  (insert "<#/!multipart>\n")
+  (mml-insert-empty-tag "multipart" 'type type)
+  (forward-line -1))
+
+(defun mml-insert-part (&optional type)
+  (interactive
+   (list (mml-minibuffer-read-type "")))
+  (mml-insert-tag 'part 'type type 'disposition "inline")
   (forward-line -1))
 
 (defun mml-preview (&optional raw)
- "Display current buffer with Gnus, in a new buffer.
+  "Display current buffer with Gnus, in a new buffer.
 If RAW, don't highlight the article."
- (interactive "P")
- (let ((buf (current-buffer)))
-   (switch-to-buffer (get-buffer-create 
-                     (concat (if raw "*Raw MIME preview of "
-                               "*MIME preview of ") (buffer-name))))
-   (erase-buffer)
-   (insert-buffer buf)
-   (mml-to-mime)
-   (unless raw
-     (run-hooks 'gnus-article-decode-hook)
-     (let ((gnus-newsgroup-name "dummy"))
-      (gnus-article-prepare-display)))
-   (fundamental-mode)
-   (setq buffer-read-only t)
-   (goto-char (point-min))))
- 
+  (interactive "P")
+  (let ((buf (current-buffer))
+	(message-posting-charset (or (gnus-setup-posting-charset 
+				      (save-restriction
+					(message-narrow-to-headers-or-head)
+					(message-fetch-field "Newsgroups")))
+				     message-posting-charset)))
+    (switch-to-buffer (get-buffer-create 
+		       (concat (if raw "*Raw MIME preview of "
+				 "*MIME preview of ") (buffer-name))))
+    (erase-buffer)
+    (insert-buffer buf)
+    (if (re-search-forward
+	 (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
+	(replace-match "\n"))
+    (mml-to-mime)
+    (if raw
+	(when (fboundp 'set-buffer-multibyte)
+	  (let ((s (buffer-string)))
+	    ;; Insert the content into unibyte buffer.
+	    (erase-buffer)
+	    (mm-disable-multibyte)
+	    (insert s)))
+      (let ((gnus-newsgroup-charset (car message-posting-charset)))
+	(run-hooks 'gnus-article-decode-hook)
+	(let ((gnus-newsgroup-name "dummy"))
+	  (gnus-article-prepare-display))))
+    (fundamental-mode)
+    (setq buffer-read-only t)
+    (goto-char (point-min))))
+
+(defun mml-validate ()
+  "Validate the current MML document."
+  (interactive)
+  (mml-parse))
+
 (provide 'mml)
 
 ;;; mml.el ends here