diff lisp/gnus/mml.el @ 82951:0fde48feb604

Import Gnus 5.10 from the v5_10 branch of the Gnus repository.

--- a/lisp/gnus/mml.el	Thu Jul 22 14:26:26 2004 +0000
+++ b/lisp/gnus/mml.el	Thu Jul 22 16:45:51 2004 +0000
@@ -1,5 +1,6 @@
-;;; mml.el --- package for parsing and validating MML documents
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002 Free Software Foundation, Inc.
+;;; mml.el --- A package for parsing and validating MML documents
+;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003
+;;        Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <[e-mail]>
 ;; This file is part of GNU Emacs.
@@ -27,15 +28,61 @@
 (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 'gnus-setup-posting-charset "gnus-msg")
   (autoload 'gnus-add-minor-mode "gnus-ems")
+  (autoload 'gnus-make-local-hook "gnus-util")
   (autoload 'message-fetch-field "message")
+  (autoload 'fill-flowed-encode "flow-fill")
   (autoload 'message-posting-charset "message"))
 
+(defcustom mml-content-type-parameters
+  '(name access-type expiration size permission format)
+  "*A list of acceptable parameters in MML tag.
+These parameters are generated in Content-Type header if exists."
+  :type '(repeat (symbol :tag "Parameter"))
+  :group 'message)
+
+(defcustom mml-content-disposition-parameters
+  '(filename creation-date modification-date read-date)
+  "*A list of acceptable parameters in MML tag.
+These parameters are generated in Content-Disposition header if exists."
+  :type '(repeat (symbol :tag "Parameter"))
+  :group 'message)
+
+(defcustom mml-insert-mime-headers-always nil
+  "If non-nil, always put Content-Type: text/plain at top of empty parts.
+It is necessary to work against a bug in certain clients."
+  :type 'boolean
+  :group 'message)
+
+(defvar mml-tweak-type-alist nil
+  "A list of (TYPE . FUNCTION) for tweaking MML parts.
+TYPE is a string containing a regexp to match the MIME type.  FUNCTION
+is a Lisp function which is called with the MML handle to tweak the
+part.  This variable is used only when no TWEAK parameter exists in
+the MML handle.")
+
+(defvar mml-tweak-function-alist nil
+  "A list of (NAME . FUNCTION) for tweaking MML parts.
+NAME is a string containing the name of the TWEAK parameter in the MML
+handle.  FUNCTION is a Lisp function which is called with the MML
+handle to tweak the part.")
+
+(defvar mml-tweak-sexp-alist
+  '((mml-externalize-attachments . mml-tweak-externalize-attachments))
+  "A list of (SEXP . FUNCTION) for tweaking MML parts.
+SEXP is an s-expression.  If the evaluation of SEXP is non-nil, FUNCTION
+is called.  FUNCTION is a Lisp function which is called with the MML
+handle to tweak the part.")
+
+(defvar mml-externalize-attachments nil
+  "*If non-nil, local-file attachments are generated as external parts.")
+
 (defvar mml-generate-multipart-alist nil
   "*Alist of multipart generation functions.
 Each entry has the form (NAME . FUNCTION), where
@@ -73,15 +120,6 @@
 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)
@@ -98,13 +136,14 @@
 
 (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."
@@ -112,6 +151,43 @@
     (while (and (not (eobp))
 		(not (looking-at "<#/multipart")))
       (cond
+       ((looking-at "<#secure")
+	;; The secure part is essentially a meta-meta tag, which
+	;; expands to either a part tag if there are no other parts in
+	;; the document or a multipart tag if there are other parts
+	;; included in the message
+	(let* (secure-mode
+	       (taginfo (mml-read-tag))
+	       (recipients (cdr (assq 'recipients taginfo)))
+	       (sender (cdr (assq 'sender taginfo)))
+	       (location (cdr (assq 'tag-location taginfo)))
+	       (mode (cdr (assq 'mode taginfo)))
+	       (method (cdr (assq 'method taginfo)))
+	       tags)
+	  (save-excursion
+	    (if
+		(re-search-forward
+		 "<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)." nil t)
+		(setq secure-mode "multipart")
+	      (setq secure-mode "part")))
+	  (save-excursion
+	    (goto-char location)
+	    (re-search-forward "<#secure[^\n]*>\n"))
+	  (delete-region (match-beginning 0) (match-end 0))
+	  (cond ((string= mode "sign")
+		 (setq tags (list "sign" method)))
+		((string= mode "encrypt")
+		 (setq tags (list "encrypt" method)))
+		((string= mode "signencrypt")
+		 (setq tags (list "sign" method "encrypt" method))))
+	  (eval `(mml-insert-tag ,secure-mode
+				 ,@tags
+				 ,(if recipients "recipients")
+				 ,recipients
+				 ,(if sender "sender")
+				 ,sender))
+	  ;; restart the parse
+	  (goto-char location)))
        ((looking-at "<#multipart")
 	(push (nconc (mml-read-tag) (mml-parse-1)) struct))
        ((looking-at "<#external")
@@ -128,18 +204,25 @@
 	(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))))
+	      charsets (cond
+			(raw nil)
+			((assq 'charset tag)
+			 (list
+			  (intern (downcase (cdr (assq 'charset tag))))))
+			(t
+			 (mm-find-mime-charset-region point (point)
+						      mm-hack-charsets))))
 	(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))))
+		  (message-options-get 'unknown-encoding)
+		  (and (y-or-n-p "\
+Message contains characters with unknown encoding.  Really send? ")
+		       (message-options-set 'unknown-encoding t)))
 	      (if (setq use-ascii
 			(or (memq 'use-ascii mml-confirmation-set)
-			    (y-or-n-p "Use ASCII as charset?")))
+			    (message-options-get 'use-ascii)
+			    (and (y-or-n-p "Use ASCII as charset? ")
+				 (message-options-set 'use-ascii t))))
 		  (setq charsets (delq nil charsets))
 		(setq warn nil))
 	    (error "Edit your message to remove those characters")))
@@ -155,14 +238,11 @@
 			  tag point (point) use-ascii)))
 	    (when (and warn
 		       (not (memq 'multipart mml-confirmation-set))
-		       (not
-			(prog1 (y-or-n-p
-				(format
-				 "\
+		       (not (message-options-get 'multipart))
+		       (not (and (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)))))
+						   (length nstruct)))
+				 (message-options-set 'multipart t))))
 	      (error "Edit your message to use only one charset"))
 	    (setq struct (nconc nstruct struct)))))))
     (unless (eobp)
@@ -229,12 +309,13 @@
 
 (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")
@@ -244,15 +325,27 @@
 	(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-buffer-substring-no-properties-except-hard-newlines (start end)
+  (let ((str (buffer-substring-no-properties start end))
+	(bufstart start) tmp)
+    (while (setq tmp (text-property-any start end 'hard 't))
+      (set-text-properties (- tmp bufstart) (- tmp bufstart -1)
+			   '(hard t) str)
+      (setq start (1+ tmp)))
+    str))
+
 (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.
+    ;; 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 mml
@@ -261,19 +354,22 @@
 	    (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))))
+	  (mml-buffer-substring-no-properties-except-hard-newlines
+	   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))
+	      (mml-buffer-substring-no-properties-except-hard-newlines
+	       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)))))))
+	(mml-buffer-substring-no-properties-except-hard-newlines
+	 beg (goto-char (point-max)))))))
 
 (defvar mml-boundary nil)
 (defvar mml-base-boundary "-=-=")
@@ -294,129 +390,183 @@
 	(buffer-string)))))
 
 (defun mml-generate-mime-1 (cont)
-  (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")))
-	    (progn
-	      (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)))
-	      (mml-insert-mime-headers cont type charset encoding)
-	      (insert "\n")
-	      (insert coded))
-	  (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")
-	  (mm-with-unibyte-current-buffer
-	    (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))
+      (mml-tweak-part cont)
+      (cond
+       ((or (eq (car cont) 'part) (eq (car cont) 'mml))
+	(let ((raw (cdr (assq 'raw cont)))
+	      coded encoding charset filename type flowed)
+	  (setq type (or (cdr (assq 'type cont)) "text/plain"))
+	  (if (and (not raw)
+		   (member (car (split-string type "/")) '("text" "message")))
+	      (progn
+		(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 (mml-compute-boundary cont))
+			  (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
+		    ;; Only perform format=flowed filling on text/plain
+		    ;; parts where there either isn't a format parameter
+		    ;; in the mml tag or it says "flowed" and there
+		    ;; actually are hard newlines in the text.
+		    (let (use-hard-newlines)
+		      (when (and (string= type "text/plain")
+				 (or (null (assq 'format cont))
+				     (string= (cdr (assq 'format cont))
+					      "flowed"))
+				 (setq use-hard-newlines
+				       (text-property-any
+					(point-min) (point-max) 'hard 't)))
+			(fill-flowed-encode)
+			;; Indicate that `mml-insert-mime-headers' should
+			;; insert a "; format=flowed" string unless the
+			;; user has already specified it.
+			(setq flowed (null (assq 'format cont)))))
+		    (setq charset (mm-encode-body charset))
+		    (setq encoding (mm-body-encoding
+				    charset (cdr (assq 'encoding cont))))))
+		  (setq coded (buffer-string)))
+		(mml-insert-mime-headers cont type charset encoding flowed)
+		(insert "\n")
+		(insert coded))
+	    (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 (mm-string-as-multibyte (buffer-string))))
+	    (mml-insert-mime-headers cont type charset encoding nil)
+	    (insert "\n")
+	    (mm-with-unibyte-current-buffer
+	      (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" 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))))
+	       (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
-	     (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))))
+	     (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\""
+			      type mml-boundary)
+		      (if (cdr (assq 'start cont))
+			  (format "; start=\"%s\"\n" (cdr (assq 'start cont)))
+			"\n"))
+	      (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)))
+      ;; handle sign & encrypt tags in a semi-smart way.
+      (let ((sign-item (assoc (cdr (assq 'sign cont)) mml-sign-alist))
+	    (encrypt-item (assoc (cdr (assq 'encrypt cont))
+				 mml-encrypt-alist))
+	    sender recipients)
+	(when (or sign-item encrypt-item)
+	  (when (setq sender (cdr (assq 'sender cont)))
+	    (message-options-set 'mml-sender sender)
+	    (message-options-set 'message-sender sender))
+	  (if (setq recipients (cdr (assq 'recipients cont)))
+	      (message-options-set 'message-recipients recipients))
+	  (let ((style (mml-signencrypt-style (first (or sign-item encrypt-item)))))
+	    ;; check if: we're both signing & encrypting, both methods
+	    ;; are the same (why would they be different?!), and that
+	    ;; the signencrypt style allows for combined operation.
+	    (if (and sign-item encrypt-item (equal (first sign-item)
+						   (first encrypt-item))
+		     (equal style 'combined))
+		(funcall (nth 1 encrypt-item) cont t)
+	      ;; otherwise, revert to the old behavior.
+	      (when sign-item
+		(funcall (nth 1 sign-item) cont))
+	      (when encrypt-item
+		(funcall (nth 1 encrypt-item) cont)))))))))
 
 (defun mml-compute-boundary (cont)
   "Return a unique boundary that does not exist in CONT."
@@ -458,34 +608,40 @@
 	    "")
 	  mml-base-boundary))
 
-(defun mml-insert-mime-headers (cont type charset encoding)
-  (let (parameters disposition description)
+(defun mml-insert-mime-headers (cont type charset encoding flowed)
+  (let (parameters id disposition description)
     (setq parameters
 	  (mml-parameter-string
-	   cont '(name access-type expiration size permission)))
+	   cont mml-content-type-parameters))
     (when (or charset
 	      parameters
-	      (not (equal type mml-generate-default-type)))
+	      flowed
+	      (not (equal type mml-generate-default-type))
+	      mml-insert-mime-headers-always)
       (when (consp charset)
 	(error
-	 "Can't encode a part with several charsets."))
+	 "Can't encode a part with several charsets"))
       (insert "Content-Type: " type)
       (when charset
 	(insert "; " (mail-header-encode-parameter
 		      "charset" (symbol-name charset))))
+      (when flowed
+	(insert "; format=flowed"))
       (when parameters
 	(mml-insert-parameter-string
-	 cont '(name access-type expiration size permission)))
+	 cont mml-content-type-parameters))
       (insert "\n"))
+    (when (setq id (cdr (assq 'id cont)))
+      (insert "Content-ID: " id "\n"))
     (setq parameters
 	  (mml-parameter-string
-	   cont '(filename creation-date modification-date read-date)))
+	   cont mml-content-disposition-parameters))
     (when (or (setq disposition (cdr (assq 'disposition cont)))
 	      parameters)
       (insert "Content-Disposition: " (or disposition "inline"))
       (when parameters
 	(mml-insert-parameter-string
-	 cont '(filename creation-date modification-date read-date)))
+	 cont mml-content-disposition-parameters))
       (insert "\n"))
     (unless (eq encoding '7bit)
       (insert (format "Content-Transfer-Encoding: %s\n" encoding)))
@@ -542,25 +698,28 @@
 ;;; 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-Disposition")
     (message-remove-header "Content-Transfer-Encoding")))
 
 (defun mml-to-mime ()
@@ -568,6 +727,9 @@
   (message-encode-message-body)
   (save-restriction
     (message-narrow-to-headers-or-head)
+    ;; Skip past any From_ headers.
+    (while (looking-at "From ")
+      (forward-line 1))
     (let ((mail-parse-charset message-default-charset))
       (mail-encode-encoded-word-buffer))))
 
@@ -589,17 +751,20 @@
 	(mml-insert-mml-markup handle buffer textp)))
     (cond
      (mmlp
-      (insert-buffer buffer)
+      (insert-buffer-substring buffer)
       (goto-char (point-max))
       (insert "<#/mml>\n"))
      ((stringp (car handle))
       (mapcar 'mml-insert-mime (cdr handle))
       (insert "<#/multipart>\n"))
      (textp
-      (let ((text (mm-get-part handle))
-	    (charset (mail-content-type-get
-		      (mm-handle-type handle) 'charset)))
-	(insert (mm-decode-string text charset)))
+      (let ((charset (mail-content-type-get
+		      (mm-handle-type handle) 'charset))
+	    (start (point)))
+	(if (eq charset 'gnus-decoded)
+	    (mm-insert-part handle)
+	  (insert (mm-decode-string (mm-get-part handle) charset)))
+	(mml-quote-region start (point)))
       (goto-char (point-max)))
      (t
       (insert "<#/part>\n")))))
@@ -607,14 +772,21 @@
 (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=" (mm-handle-media-subtype handle)
-	      ">\n")
+      (progn
+	(insert "<#multipart type=" (mm-handle-media-subtype handle))
+	(let ((start (mm-handle-multipart-ctl-parameter handle 'start)))
+	  (when start
+	    (insert " start=\"" start "\"")))
+	(insert ">\n"))
     (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-id handle)
+      (insert " id=\"" (mm-handle-id handle) "\""))
     (when (mm-handle-disposition handle)
       (insert " disposition=" (car (mm-handle-disposition handle))))
     (when buffer
@@ -641,8 +813,25 @@
 ;;;
 
 (defvar mml-mode-map
-  (let ((map (make-sparse-keymap))
+  (let ((sign (make-sparse-keymap))
+	(encrypt (make-sparse-keymap))
+	(signpart (make-sparse-keymap))
+	(encryptpart (make-sparse-keymap))
+	(map (make-sparse-keymap))
 	(main (make-sparse-keymap)))
+    (define-key sign "p" 'mml-secure-message-sign-pgpmime)
+    (define-key sign "o" 'mml-secure-message-sign-pgp)
+    (define-key sign "s" 'mml-secure-message-sign-smime)
+    (define-key signpart "p" 'mml-secure-sign-pgpmime)
+    (define-key signpart "o" 'mml-secure-sign-pgp)
+    (define-key signpart "s" 'mml-secure-sign-smime)
+    (define-key encrypt "p" 'mml-secure-message-encrypt-pgpmime)
+    (define-key encrypt "o" 'mml-secure-message-encrypt-pgp)
+    (define-key encrypt "s" 'mml-secure-message-encrypt-smime)
+    (define-key encryptpart "p" 'mml-secure-encrypt-pgpmime)
+    (define-key encryptpart "o" 'mml-secure-encrypt-pgp)
+    (define-key encryptpart "s" 'mml-secure-encrypt-smime)
+    (define-key map "\C-n" 'mml-unsecure-message)
     (define-key map "f" 'mml-attach-file)
     (define-key map "b" 'mml-attach-buffer)
     (define-key map "e" 'mml-attach-external)
@@ -651,23 +840,43 @@
     (define-key map "p" 'mml-insert-part)
     (define-key map "v" 'mml-validate)
     (define-key map "P" 'mml-preview)
+    (define-key map "s" sign)
+    (define-key map "S" signpart)
+    (define-key map "c" encrypt)
+    (define-key map "C" encryptpart)
     ;;(define-key map "n" 'mml-narrow-to-part)
-    (define-key main "\M-m" map)
+    ;; `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
   mml-menu mml-mode-map ""
-  '("MML"
-    ("Attach"
-     ["File" mml-attach-file t]
-     ["Buffer" mml-attach-buffer t]
-     ["External" mml-attach-external t])
-    ("Insert"
-     ["Multipart" mml-insert-multipart t]
-     ["Part" mml-insert-part t])
+  `("Attachments"
+    ["Attach File..." mml-attach-file
+     ,@(if (featurep 'xemacs) '(t)
+	 '(:help "Attach a file at point"))]
+    ["Attach Buffer..." mml-attach-buffer t]
+    ["Attach External..." mml-attach-external t]
+    ["Insert Part..." mml-insert-part t]
+    ["Insert Multipart..." mml-insert-multipart t]
+    ["PGP/MIME Sign" mml-secure-message-sign-pgpmime t]
+    ["PGP/MIME Encrypt" mml-secure-message-encrypt-pgpmime t]
+    ["PGP Sign" mml-secure-message-sign-pgp t]
+    ["PGP Encrypt" mml-secure-message-encrypt-pgp t]
+    ["S/MIME Sign" mml-secure-message-sign-smime t]
+    ["S/MIME Encrypt" mml-secure-message-encrypt-smime t]
+    ("Secure MIME part"
+     ["PGP/MIME Sign Part" mml-secure-sign-pgpmime t]
+     ["PGP/MIME Encrypt Part" mml-secure-encrypt-pgpmime t]
+     ["PGP Sign Part" mml-secure-sign-pgp t]
+     ["PGP Encrypt Part" mml-secure-encrypt-pgp t]
+     ["S/MIME Sign Part" mml-secure-sign-smime t]
+     ["S/MIME Encrypt Part" mml-secure-encrypt-smime t])
+    ["Encrypt/Sign off" mml-unsecure-message t]
     ;;["Narrow" mml-narrow-to-part t]
-    ["Quote" mml-quote-region t]
-    ["Validate" mml-validate t]
+    ["Quote MML" mml-quote-region t]
+    ["Validate MML" mml-validate t]
     ["Preview" mml-preview t]))
 
 (defvar mml-mode nil
@@ -675,20 +884,17 @@
 
 (defun mml-mode (&optional arg)
   "Minor mode for editing MML.
+MML is the MIME Meta Language, a minor mode for composing MIME articles.
+See Info node `(emacs-mime)Composing'.
 
 \\{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
@@ -696,8 +902,9 @@
 ;;;
 
 (defun mml-minibuffer-read-file (prompt)
-  (let ((file (read-file-name prompt nil nil t)))
-   ;; Prevent some common errors.  This is inspired by similar code in
+  (let* ((completion-ignored-extensions nil)
+	 (file (read-file-name prompt nil nil t)))
+    ;; Prevent some common errors.  This is inspired by similar code in
     ;; VM.
     (when (file-directory-p file)
       (error "%s is a directory, cannot attach" file))
@@ -728,6 +935,19 @@
       (setq description nil))
     description))
 
+(defun mml-minibuffer-read-disposition (type &optional default)
+  (let* ((default (or default
+		      (if (string-match "^text/.*" type)
+			  "inline"
+			"attachment")))
+	 (disposition (completing-read "Disposition: "
+				       '(("attachment") ("inline") (""))
+				       nil
+				       nil)))
+    (if (not (equal disposition ""))
+	disposition
+      default)))
+
 (defun mml-quote-region (beg end)
   "Quote the MML tags in the region."
   (interactive "r")
@@ -755,7 +975,9 @@
       (when value
 	;; Quote VALUE if it contains suspicious characters.
 	(when (string-match "[\"'\\~/*;() \t\n]" value)
-	  (setq value (prin1-to-string value)))
+	  (setq value (with-output-to-string
+			(let (print-escape-nonascii)
+			  (prin1 value)))))
 	(insert (format " %s=%s" key value)))))
   (insert ">\n"))
 
@@ -768,7 +990,7 @@
 
 ;;; Attachment functions.
 
-(defun mml-attach-file (file &optional type description)
+(defun mml-attach-file (file &optional type description disposition)
   "Attach a file to the outgoing MIME message.
 The file is not inserted or encoded until you send the message with
 `\\[message-send-and-exit]' or `\\[message-send]'.
@@ -779,10 +1001,14 @@
   (interactive
    (let* ((file (mml-minibuffer-read-file "Attach file: "))
 	  (type (mml-minibuffer-read-type file))
-	  (description (mml-minibuffer-read-description)))
-     (list file type description)))
-  (mml-insert-empty-tag 'part 'type type 'filename file
-			'disposition "attachment" 'description description))
+	  (description (mml-minibuffer-read-description))
+	  (disposition (mml-minibuffer-read-disposition type)))
+     (list file type description disposition)))
+  (mml-insert-empty-tag 'part
+			'type type
+			'filename file
+			'disposition (or disposition "attachment")
+			'description description))
 
 (defun mml-attach-buffer (buffer &optional type description)
   "Attach a buffer to the outgoing MIME message.
@@ -823,48 +1049,126 @@
   (mml-insert-tag 'part 'type type 'disposition "inline")
   (forward-line -1))
 
+(defun mml-preview-insert-mail-followup-to ()
+  "Insert a Mail-Followup-To header before previewing an article.
+Should be adopted if code in `message-send-mail' is changed."
+  (when (and (message-mail-p)
+	     (message-subscribed-p)
+	     (not (mail-fetch-field "mail-followup-to"))
+	     (message-make-mail-followup-to))
+    (message-position-on-field "Mail-Followup-To" "X-Draft-From")
+    (insert (message-make-mail-followup-to))))
+
 (defun mml-preview (&optional raw)
   "Display current buffer with Gnus, in a new buffer.
 If RAW, don't highlight the article."
   (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"))
-    (let ((mail-header-separator "")) ;; mail-header-separator is removed.
-      (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))))
-    ;; Disable article-mode-map.
-    (use-local-map nil)
-    (setq buffer-read-only t)
-    (local-set-key "q" (lambda () (interactive) (kill-buffer nil)))
-    (goto-char (point-min))))
+  (save-excursion
+    (let* ((buf (current-buffer))
+	   (message-options message-options)
+	   (message-this-is-mail (message-mail-p))
+	   (message-this-is-news (message-news-p))
+	   (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))))
+      (when (boundp 'gnus-buffers)
+	(push (current-buffer) gnus-buffers))
+      (erase-buffer)
+      (insert-buffer-substring buf)
+      (mml-preview-insert-mail-followup-to)
+      (let ((message-deletable-headers (if (message-news-p)
+					   nil
+					 message-deletable-headers)))
+	(message-generate-headers
+	 (copy-sequence (if (message-news-p)
+			    message-required-news-headers
+			  message-required-mail-headers))))
+      (if (re-search-forward
+	   (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
+	  (replace-match "\n"))
+      (let ((mail-header-separator ""));; mail-header-separator is removed.
+	(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))
+	      gnus-article-prepare-hook gnus-original-article-buffer)
+	  (run-hooks 'gnus-article-decode-hook)
+	  (let ((gnus-newsgroup-name "dummy")
+		(gnus-newsrc-hashtb (or gnus-newsrc-hashtb
+					(gnus-make-hashtable 5))))
+	    (gnus-article-prepare-display))))
+      ;; Disable article-mode-map.
+      (use-local-map nil)
+      (gnus-make-local-hook 'kill-buffer-hook)
+      (add-hook 'kill-buffer-hook
+		(lambda ()
+		  (mm-destroy-parts gnus-article-mime-handles)) nil t)
+      (setq buffer-read-only t)
+      (local-set-key "q" (lambda () (interactive) (kill-buffer nil)))
+      (local-set-key "=" (lambda () (interactive) (delete-other-windows)))
+      (local-set-key "\r"
+		     (lambda ()
+		       (interactive)
+		       (widget-button-press (point))))
+      (local-set-key gnus-mouse-2
+		     (lambda (event)
+		       (interactive "@e")
+		       (widget-button-press (widget-event-point event) event)))
+      (goto-char (point-min)))))
 
 (defun mml-validate ()
   "Validate the current MML document."
   (interactive)
   (mml-parse))
 
+(defun mml-tweak-part (cont)
+  "Tweak a MML part."
+  (let ((tweak (cdr (assq 'tweak cont)))
+	func)
+    (cond
+     (tweak
+      (setq func
+	    (or (cdr (assoc tweak mml-tweak-function-alist))
+		(intern tweak))))
+     (mml-tweak-type-alist
+      (let ((alist mml-tweak-type-alist)
+	    (type (or (cdr (assq 'type cont)) "text/plain")))
+	(while alist
+	  (if (string-match (caar alist) type)
+	      (setq func (cdar alist)
+		    alist nil)
+	    (setq alist (cdr alist)))))))
+    (if func
+	(funcall func cont)
+      cont)
+    (let ((alist mml-tweak-sexp-alist))
+      (while alist
+	(if (eval (caar alist))
+	    (funcall (cdar alist) cont))
+	(setq alist (cdr alist)))))
+  cont)
+
+(defun mml-tweak-externalize-attachments (cont)
+  "Tweak attached files as external parts."
+  (let (filename-cons)
+    (when (and (eq (car cont) 'part)
+	       (not (cdr (assq 'buffer cont)))
+	       (and (setq filename-cons (assq 'filename cont))
+		    (not (equal (cdr (assq 'nofile cont)) "yes"))))
+      (setcar cont 'external)
+      (setcar filename-cons 'name))))
+
 (provide 'mml)
 
 ;;; arch-tag: 583c96cf-1ffe-451b-a5e5-4733ae9ddd12