X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fmml.el;h=de23d5fe993ac706add452e7e4b74afd36f336e7;hb=1e8db0f8bf6ba81f37fe36653e1b5796a32dd204;hp=16c7341266a85d938c6b889341892ba1f745783d;hpb=0bcb697113fbd45da5bc46de153b55b17ff14b00;p=elisp%2Fgnus.git-

diff --git a/lisp/mml.el b/lisp/mml.el
index 16c7341..de23d5f 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.
@@ -27,9 +27,25 @@
 (require 'mm-bodies)
 (require 'mm-encode)
 (require 'mm-decode)
+(require 'mml-sec)
+(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 'gnus-add-minor-mode "gnus-ems")
+  (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)))
@@ -44,19 +60,48 @@
     (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-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))
-  (let ((table (syntax-table)))
-    (unwind-protect
-	(progn
-	  (set-syntax-table mml-syntax-table)
-	  (mml-parse-1))
-      (set-syntax-table table))))
+  (save-excursion
+    (goto-char (point-min))
+    (let ((table (syntax-table)))
+      (unwind-protect
+	  (progn
+	    (set-syntax-table mml-syntax-table)
+	    (mml-parse-1))
+	(set-syntax-table table)))))
 
 (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
@@ -66,89 +111,124 @@
 	(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)
+		  (prog1 (y-or-n-p
+		   "\
+Message contains characters with unknown encoding.  Really send?")
+		    (set (make-local-variable 'mml-confirmation-set)
+			 (push 'unknown-encoding mml-confirmation-set))))
+	      (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? "
-			  (length nstruct)))))
+			(prog1 (y-or-n-p
+				(format
+				 "\
+A message part needs to be split into %d charset parts.  Really send? "
+				 (length nstruct)))
+			  (set (make-local-variable 'mml-confirmation-set)
+			       (push 'multipart mml-confirmation-set)))))
 	      (error "Edit your message to use only one charset"))
 	    (setq struct (nconc nstruct struct)))))))
     (unless (eobp)
       (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."
-  (let (contents name elem val)
+  (let ((orig-point (point))
+	contents name elem val)
     (forward-char 2)
     (setq name (buffer-substring-no-properties
 		(point) (progn (forward-sexp 1) (point))))
     (skip-chars-forward " \t\n")
-    (while (not (looking-at ">"))
+    (while (not (looking-at ">[ \t]*\n?"))
       (setq elem (buffer-substring-no-properties
 		  (point) (progn (forward-sexp 1) (point))))
       (skip-chars-forward "= \t\n")
@@ -158,26 +238,39 @@
 	(setq val (match-string 1 val)))
       (push (cons (intern elem) val) contents)
       (skip-chars-forward " \t\n"))
-    (forward-char 1)
-    (skip-chars-forward " \t\n")
+    (goto-char (match-end 0))
+    ;; Don't skip the leading space.
+    ;;(skip-chars-forward " \t\n")
+    ;; Put the tag location into the returned contents
+    (setq contents (append (list (cons 'tag-location orig-point)) contents))
     (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 "-=-=")
@@ -186,7 +279,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
@@ -198,93 +291,155 @@
 	(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
-	    (cond
-	     ((cdr (assq 'buffer cont))
-	      (insert-buffer-substring (cdr (assq 'buffer cont))))
-	     ((setq filename (cdr (assq 'filename cont)))
-	      (insert-file-contents filename))
-	     (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 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)
+  (let ((mm-use-ultra-safe-encoding 
+	 (or mm-use-ultra-safe-encoding (assq 'sign cont))))
+    (save-restriction
+      (narrow-to-region (point) (point))
+      (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
+		(setq charset (mm-charset-to-coding-system 
+			       (cdr (assq 'charset cont))))
+		(when (eq charset 'ascii)
+		  (setq charset nil))
+		(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")))
+		  (let ((coding-system-for-read charset))
+		    (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 charset))
+		  (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))))
+	       ((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
+		(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)))
+	      (url (cdr (assq 'url 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" (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 url
 	    (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 "url" url)
+	     "access-type=url"))
+	  (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))
+	      (let ((cont cont) part)
+		(while (setq part (pop cont))
+		  ;; Skip `multipart' and attributes.
+		  (when (and (consp part) (consp (cdr part)))
+		    (insert "\n--" mml-boundary "\n")
+		    (mml-generate-mime-1 part))))
+	      (insert "\n--" mml-boundary "--\n")))))
+       (t
+	(error "Invalid element: %S" cont)))
+      (let ((item (assoc (cdr (assq 'sign cont)) mml-sign-alist))
+	    sender recipients)
+	(when item
+	  (if (setq sender (cdr (assq 'sender cont)))
+	      (message-options-set 'message-sender sender))
+	  (if (setq recipients (cdr (assq 'recipients cont)))
+	      (message-options-set 'message-sender recipients))
+	  (funcall (nth 1 item) cont)))
+      (let ((item (assoc (cdr (assq 'encrypt cont)) mml-encrypt-alist))
+	    sender recipients)
+	(when item
+	  (if (setq sender (cdr (assq 'sender cont)))
+	      (message-options-set 'message-sender sender))
+	  (if (setq recipients (cdr (assq 'recipients cont)))
+	      (message-options-set 'message-sender recipients))
+	  (funcall (nth 1 item) 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
@@ -299,32 +454,28 @@
 	(cond
 	 ((cdr (assq 'buffer cont))
 	  (insert-buffer-substring (cdr (assq 'buffer cont))))
-	 ((setq filename (cdr (assq 'filename cont)))
-	  (insert-file-contents 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
@@ -332,7 +483,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."))
@@ -385,13 +536,14 @@
 	 (mail-header-encode-parameter
 	  (symbol-name type) value))))))
 
-(defvar ange-ftp-path-format)
-(defvar efs-path-regexp)
+(eval-when-compile
+  (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))
@@ -408,67 +560,91 @@
 ;;; Transforming MIME to MML
 ;;;
 
-(defun mime-to-mml ()
-  "Translate the current buffer (which should be a message) into MML."
+(defun mime-to-mml (&optional handles)
+  "Translate the current buffer (which should be a message) into MML.
+If HANDLES is non-nil, use it instead reparsing the buffer."
   ;; First decode the head.
   (save-restriction
     (message-narrow-to-head)
     (mail-decode-encoded-word-region (point-min) (point-max)))
-  (let ((handles (mm-dissect-buffer t)))
-    (goto-char (point-min))
-    (search-forward "\n\n" nil t)
-    (delete-region (point) (point-max))
-    (if (stringp (car handles))
-	(mml-insert-mime handles)
-      (mml-insert-mime handles t))
-    (mm-destroy-parts handles)))
+  (unless handles
+    (setq handles (mm-dissect-buffer t)))
+  (goto-char (point-min))
+  (search-forward "\n\n" nil t)
+  (delete-region (point) (point-max))
+  (if (stringp (car handles))
+      (mml-insert-mime handles)
+    (mml-insert-mime handles t))
+  (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 ((charset (mail-content-type-get
+		      (mm-handle-type handle) 'charset)))
+	(if (eq charset 'gnus-decoded)
+	    (mm-insert-part handle)
+	  (insert (mm-decode-string (mm-get-part handle) 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) "\""))
+      (unless (symbolp (cdr elem))
+	(insert " " (symbol-name (car elem)) "=\"" (cdr elem) "\"")))
     (when (mm-handle-disposition handle)
       (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)
@@ -487,8 +663,14 @@
 ;;;
 
 (defvar mml-mode-map
-  (let ((map (make-sparse-keymap))
+  (let ((sign (make-sparse-keymap))
+	(encrypt (make-sparse-keymap))
+	(map (make-sparse-keymap))
 	(main (make-sparse-keymap)))
+    (define-key sign "p" 'mml-secure-sign-pgpmime)
+    (define-key sign "s" 'mml-secure-sign-smime)
+    (define-key encrypt "p" 'mml-secure-encrypt-pgpmime)
+    (define-key encrypt "s" 'mml-secure-encrypt-smime)
     (define-key map "f" 'mml-attach-file)
     (define-key map "b" 'mml-attach-buffer)
     (define-key map "e" 'mml-attach-external)
@@ -497,7 +679,12 @@
     (define-key map "p" 'mml-insert-part)
     (define-key map "v" 'mml-validate)
     (define-key map "P" 'mml-preview)
-    (define-key main "\M-m" map)
+    (define-key map "s" sign)
+    (define-key map "c" encrypt)
+    ;;(define-key map "n" 'mml-narrow-to-part)
+    ;; `M-m' conflicts with `back-to-indentation'.
+    ;; (define-key main "\M-m" map)
+    (define-key main "\C-c\C-m" map)
     main))
 
 (easy-menu-define
@@ -510,8 +697,17 @@
    ("Insert"
     ["Multipart" mml-insert-multipart t]
     ["Part" mml-insert-part t])
+   ("Security"
+    ("Sign"
+     ["PGP/MIME" mml-secure-sign-pgpmime t]
+     ["S/MIME" mml-secure-sign-smime t])
+    ("Encrypt"
+     ["PGP/MIME" mml-secure-encrypt-pgpmime t]
+     ["S/MIME" mml-secure-encrypt-smime 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.")
@@ -521,17 +717,12 @@
 
 \\{mml-mode-map}"
   (interactive "P")
-  (if (not (set (make-local-variable 'mml-mode)
-		(if (null arg) (not mml-mode)
-		  (> (prefix-numeric-value arg) 0))))
-      nil
-    (set (make-local-variable 'mml-mode) t)
-    (unless (assq 'mml-mode minor-mode-alist)
-      (push `(mml-mode " MML") minor-mode-alist))
-    (unless (assq 'mml-mode minor-mode-map-alist)
-      (push (cons 'mml-mode mml-mode-map)
-	    minor-mode-map-alist)))
-  (run-hooks 'mml-mode-hook))
+  (when (set (make-local-variable 'mml-mode)
+	     (if (null arg) (not mml-mode)
+	       (> (prefix-numeric-value arg) 0)))
+    (gnus-add-minor-mode 'mml-mode " MML" mml-mode-map)
+    (easy-menu-add mml-menu mml-mode-map)
+    (run-hooks 'mml-mode-hook)))
 
 ;;;
 ;;; Helper functions for reading MIME stuff from the minibuffer and
@@ -551,6 +742,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
@@ -559,27 +751,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)))
@@ -601,8 +773,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)
@@ -615,10 +788,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<#/" name ">\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.
 
@@ -635,8 +815,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.
@@ -646,8 +826,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.
@@ -658,38 +838,66 @@ 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") ("alternative") ("digest") ("parallel")
-		       ("signed") ("encrypted"))
-		     nil nil "mixed")))
+				      '(("mixed") ("alternative") ("digest") ("parallel")
+					("signed") ("encrypted"))
+				      nil nil "mixed")))
   (or type
       (setq type "mixed"))
-  (mml-insert-tag "multipart" 'type type)
+  (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-options message-options)
+	(message-posting-charset (or (gnus-setup-posting-charset 
+				      (save-restriction
+					(message-narrow-to-headers-or-head)
+					(message-fetch-field "Newsgroups")))
+				     message-posting-charset)))
+    (message-options-set-recipient)
+    (switch-to-buffer (generate-new-buffer
+		       (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