1;;; mml.el --- A package for parsing and validating MML documents
2
3;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4;;   2005, 2006, 2007 Free Software Foundation, Inc.
5
6;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
7;; This file is part of GNU Emacs.
8
9;; GNU Emacs is free software; you can redistribute it and/or modify
10;; it under the terms of the GNU General Public License as published by
11;; the Free Software Foundation; either version 2, or (at your option)
12;; any later version.
13
14;; GNU Emacs is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.	 See the
17;; GNU General Public License for more details.
18
19;; You should have received a copy of the GNU General Public License
20;; along with GNU Emacs; see the file COPYING.  If not, write to the
21;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
22;; Boston, MA 02110-1301, USA.
23
24;;; Commentary:
25
26;;; Code:
27
28(require 'mm-util)
29(require 'mm-bodies)
30(require 'mm-encode)
31(require 'mm-decode)
32(require 'mml-sec)
33(eval-when-compile (require 'cl))
34
35(eval-and-compile
36  (autoload 'message-make-message-id "message")
37  (autoload 'gnus-setup-posting-charset "gnus-msg")
38  (autoload 'gnus-add-minor-mode "gnus-ems")
39  (autoload 'gnus-make-local-hook "gnus-util")
40  (autoload 'message-fetch-field "message")
41  (autoload 'message-info "message")
42  (autoload 'fill-flowed-encode "flow-fill")
43  (autoload 'message-posting-charset "message")
44  (autoload 'dnd-get-local-file-name "dnd"))
45
46(defvar gnus-article-mime-handles)
47(defvar gnus-mouse-2)
48(defvar gnus-newsrc-hashtb)
49(defvar message-default-charset)
50(defvar message-deletable-headers)
51(defvar message-options)
52(defvar message-posting-charset)
53(defvar message-required-mail-headers)
54(defvar message-required-news-headers)
55(defvar dnd-protocol-alist)
56
57(defcustom mml-content-type-parameters
58  '(name access-type expiration size permission format)
59  "*A list of acceptable parameters in MML tag.
60These parameters are generated in Content-Type header if exists."
61  :version "22.1"
62  :type '(repeat (symbol :tag "Parameter"))
63  :group 'message)
64
65(defcustom mml-content-disposition-parameters
66  '(filename creation-date modification-date read-date)
67  "*A list of acceptable parameters in MML tag.
68These parameters are generated in Content-Disposition header if exists."
69  :version "22.1"
70  :type '(repeat (symbol :tag "Parameter"))
71  :group 'message)
72
73(defcustom mml-insert-mime-headers-always nil
74  "If non-nil, always put Content-Type: text/plain at top of empty parts.
75It is necessary to work against a bug in certain clients."
76  :version "22.1"
77  :type 'boolean
78  :group 'message)
79
80(defvar mml-tweak-type-alist nil
81  "A list of (TYPE . FUNCTION) for tweaking MML parts.
82TYPE is a string containing a regexp to match the MIME type.  FUNCTION
83is a Lisp function which is called with the MML handle to tweak the
84part.  This variable is used only when no TWEAK parameter exists in
85the MML handle.")
86
87(defvar mml-tweak-function-alist nil
88  "A list of (NAME . FUNCTION) for tweaking MML parts.
89NAME is a string containing the name of the TWEAK parameter in the MML
90handle.  FUNCTION is a Lisp function which is called with the MML
91handle to tweak the part.")
92
93(defvar mml-tweak-sexp-alist
94  '((mml-externalize-attachments . mml-tweak-externalize-attachments))
95  "A list of (SEXP . FUNCTION) for tweaking MML parts.
96SEXP is an s-expression.  If the evaluation of SEXP is non-nil, FUNCTION
97is called.  FUNCTION is a Lisp function which is called with the MML
98handle to tweak the part.")
99
100(defvar mml-externalize-attachments nil
101  "*If non-nil, local-file attachments are generated as external parts.")
102
103(defvar mml-generate-multipart-alist nil
104  "*Alist of multipart generation functions.
105Each entry has the form (NAME . FUNCTION), where
106NAME is a string containing the name of the part (without the
107leading \"/multipart/\"),
108FUNCTION is a Lisp function which is called to generate the part.
109
110The Lisp function has to supply the appropriate MIME headers and the
111contents of this part.")
112
113(defvar mml-syntax-table
114  (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table)))
115    (modify-syntax-entry ?\\ "/" table)
116    (modify-syntax-entry ?< "(" table)
117    (modify-syntax-entry ?> ")" table)
118    (modify-syntax-entry ?@ "w" table)
119    (modify-syntax-entry ?/ "w" table)
120    (modify-syntax-entry ?= " " table)
121    (modify-syntax-entry ?* " " table)
122    (modify-syntax-entry ?\; " " table)
123    (modify-syntax-entry ?\' " " table)
124    table))
125
126(defvar mml-boundary-function 'mml-make-boundary
127  "A function called to suggest a boundary.
128The function may be called several times, and should try to make a new
129suggestion each time.  The function is called with one parameter,
130which is a number that says how many times the function has been
131called for this message.")
132
133(defvar mml-confirmation-set nil
134  "A list of symbols, each of which disables some warning.
135`unknown-encoding': always send messages contain characters with
136unknown encoding; `use-ascii': always use ASCII for those characters
137with unknown encoding; `multipart': always send messages with more than
138one charsets.")
139
140(defvar mml-generate-default-type "text/plain"
141  "Content type by which the Content-Type header can be omitted.
142The Content-Type header will not be put in the MIME part if the type
143equals the value and there's no parameter (e.g. charset, format, etc.)
144and `mml-insert-mime-headers-always' is nil.  The value will be bound
145to \"message/rfc822\" when encoding an article to be forwarded as a MIME
146part.  This is for the internal use, you should never modify the value.")
147
148(defvar mml-buffer-list nil)
149
150(defun mml-generate-new-buffer (name)
151  (let ((buf (generate-new-buffer name)))
152    (push buf mml-buffer-list)
153    buf))
154
155(defun mml-destroy-buffers ()
156  (let (kill-buffer-hook)
157    (mapcar 'kill-buffer mml-buffer-list)
158    (setq mml-buffer-list nil)))
159
160(defun mml-parse ()
161  "Parse the current buffer as an MML document."
162  (save-excursion
163    (goto-char (point-min))
164    (let ((table (syntax-table)))
165      (unwind-protect
166	  (progn
167	    (set-syntax-table mml-syntax-table)
168	    (mml-parse-1))
169	(set-syntax-table table)))))
170
171(defun mml-parse-1 ()
172  "Parse the current buffer as an MML document."
173  (let (struct tag point contents charsets warn use-ascii no-markup-p raw)
174    (while (and (not (eobp))
175		(not (looking-at "<#/multipart")))
176      (cond
177       ((looking-at "<#secure")
178	;; The secure part is essentially a meta-meta tag, which
179	;; expands to either a part tag if there are no other parts in
180	;; the document or a multipart tag if there are other parts
181	;; included in the message
182	(let* (secure-mode
183	       (taginfo (mml-read-tag))
184	       (recipients (cdr (assq 'recipients taginfo)))
185	       (sender (cdr (assq 'sender taginfo)))
186	       (location (cdr (assq 'tag-location taginfo)))
187	       (mode (cdr (assq 'mode taginfo)))
188	       (method (cdr (assq 'method taginfo)))
189	       tags)
190	  (save-excursion
191	    (if
192		(re-search-forward
193		 "<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)." nil t)
194		(setq secure-mode "multipart")
195	      (setq secure-mode "part")))
196	  (save-excursion
197	    (goto-char location)
198	    (re-search-forward "<#secure[^\n]*>\n"))
199	  (delete-region (match-beginning 0) (match-end 0))
200	  (cond ((string= mode "sign")
201		 (setq tags (list "sign" method)))
202		((string= mode "encrypt")
203		 (setq tags (list "encrypt" method)))
204		((string= mode "signencrypt")
205		 (setq tags (list "sign" method "encrypt" method))))
206	  (eval `(mml-insert-tag ,secure-mode
207				 ,@tags
208				 ,(if recipients "recipients")
209				 ,recipients
210				 ,(if sender "sender")
211				 ,sender))
212	  ;; restart the parse
213	  (goto-char location)))
214       ((looking-at "<#multipart")
215	(push (nconc (mml-read-tag) (mml-parse-1)) struct))
216       ((looking-at "<#external")
217	(push (nconc (mml-read-tag) (list (cons 'contents (mml-read-part))))
218	      struct))
219       (t
220	(if (or (looking-at "<#part") (looking-at "<#mml"))
221	    (setq tag (mml-read-tag)
222		  no-markup-p nil
223		  warn nil)
224	  (setq tag (list 'part '(type . "text/plain"))
225		no-markup-p t
226		warn t))
227	(setq raw (cdr (assq 'raw tag))
228	      point (point)
229	      contents (mml-read-part (eq 'mml (car tag)))
230	      charsets (cond
231			(raw nil)
232			((assq 'charset tag)
233			 (list
234			  (intern (downcase (cdr (assq 'charset tag))))))
235			(t
236			 (mm-find-mime-charset-region point (point)
237						      mm-hack-charsets))))
238	(when (and (not raw) (memq nil charsets))
239	  (if (or (memq 'unknown-encoding mml-confirmation-set)
240		  (message-options-get 'unknown-encoding)
241		  (and (y-or-n-p "\
242Message contains characters with unknown encoding.  Really send? ")
243		       (message-options-set 'unknown-encoding t)))
244	      (if (setq use-ascii
245			(or (memq 'use-ascii mml-confirmation-set)
246			    (message-options-get 'use-ascii)
247			    (and (y-or-n-p "Use ASCII as charset? ")
248				 (message-options-set 'use-ascii t))))
249		  (setq charsets (delq nil charsets))
250		(setq warn nil))
251	    (error "Edit your message to remove those characters")))
252	(if (or raw
253		(eq 'mml (car tag))
254		(< (length charsets) 2))
255	    (if (or (not no-markup-p)
256		    (string-match "[^ \t\r\n]" contents))
257		;; Don't create blank parts.
258		(push (nconc tag (list (cons 'contents contents)))
259		      struct))
260	  (let ((nstruct (mml-parse-singlepart-with-multiple-charsets
261			  tag point (point) use-ascii)))
262	    (when (and warn
263		       (not (memq 'multipart mml-confirmation-set))
264		       (not (message-options-get 'multipart))
265		       (not (and (y-or-n-p (format "\
266A message part needs to be split into %d charset parts.  Really send? "
267						   (length nstruct)))
268				 (message-options-set 'multipart t))))
269	      (error "Edit your message to use only one charset"))
270	    (setq struct (nconc nstruct struct)))))))
271    (unless (eobp)
272      (forward-line 1))
273    (nreverse struct)))
274
275(defun mml-parse-singlepart-with-multiple-charsets
276  (orig-tag beg end &optional use-ascii)
277  (save-excursion
278    (save-restriction
279      (narrow-to-region beg end)
280      (goto-char (point-min))
281      (let ((current (or (mm-mime-charset (mm-charset-after))
282			 (and use-ascii 'us-ascii)))
283	    charset struct space newline paragraph)
284	(while (not (eobp))
285	  (setq charset (mm-mime-charset (mm-charset-after)))
286	  (cond
287	   ;; The charset remains the same.
288	   ((eq charset 'us-ascii))
289	   ((or (and use-ascii (not charset))
290		(eq charset current))
291	    (setq space nil
292		  newline nil
293		  paragraph nil))
294	   ;; The initial charset was ascii.
295	   ((eq current 'us-ascii)
296	    (setq current charset
297		  space nil
298		  newline nil
299		  paragraph nil))
300	   ;; We have a change in charsets.
301	   (t
302	    (push (append
303		   orig-tag
304		   (list (cons 'contents
305			       (buffer-substring-no-properties
306				beg (or paragraph newline space (point))))))
307		  struct)
308	    (setq beg (or paragraph newline space (point))
309		  current charset
310		  space nil
311		  newline nil
312		  paragraph nil)))
313	  ;; Compute places where it might be nice to break the part.
314	  (cond
315	   ((memq (following-char) '(?  ?\t))
316	    (setq space (1+ (point))))
317	   ((and (eq (following-char) ?\n)
318		 (not (bobp))
319		 (eq (char-after (1- (point))) ?\n))
320	    (setq paragraph (point)))
321	   ((eq (following-char) ?\n)
322	    (setq newline (1+ (point)))))
323	  (forward-char 1))
324	;; Do the final part.
325	(unless (= beg (point))
326	  (push (append orig-tag
327			(list (cons 'contents
328				    (buffer-substring-no-properties
329				     beg (point)))))
330		struct))
331	struct))))
332
333(defun mml-read-tag ()
334  "Read a tag and return the contents."
335  (let ((orig-point (point))
336	contents name elem val)
337    (forward-char 2)
338    (setq name (buffer-substring-no-properties
339		(point) (progn (forward-sexp 1) (point))))
340    (skip-chars-forward " \t\n")
341    (while (not (looking-at ">[ \t]*\n?"))
342      (setq elem (buffer-substring-no-properties
343		  (point) (progn (forward-sexp 1) (point))))
344      (skip-chars-forward "= \t\n")
345      (setq val (buffer-substring-no-properties
346		 (point) (progn (forward-sexp 1) (point))))
347      (when (string-match "^\"\\(.*\\)\"$" val)
348	(setq val (match-string 1 val)))
349      (push (cons (intern elem) val) contents)
350      (skip-chars-forward " \t\n"))
351    (goto-char (match-end 0))
352    ;; Don't skip the leading space.
353    ;;(skip-chars-forward " \t\n")
354    ;; Put the tag location into the returned contents
355    (setq contents (append (list (cons 'tag-location orig-point)) contents))
356    (cons (intern name) (nreverse contents))))
357
358(defun mml-buffer-substring-no-properties-except-hard-newlines (start end)
359  (let ((str (buffer-substring-no-properties start end))
360	(bufstart start) tmp)
361    (while (setq tmp (text-property-any start end 'hard 't))
362      (set-text-properties (- tmp bufstart) (- tmp bufstart -1)
363			   '(hard t) str)
364      (setq start (1+ tmp)))
365    str))
366
367(defun mml-read-part (&optional mml)
368  "Return the buffer up till the next part, multipart or closing part or multipart.
369If MML is non-nil, return the buffer up till the correspondent mml tag."
370  (let ((beg (point)) (count 1))
371    ;; If the tag ended at the end of the line, we go to the next line.
372    (when (looking-at "[ \t]*\n")
373      (forward-line 1))
374    (if mml
375	(progn
376	  (while (and (> count 0) (not (eobp)))
377	    (if (re-search-forward "<#\\(/\\)?mml." nil t)
378		(setq count (+ count (if (match-beginning 1) -1 1)))
379	      (goto-char (point-max))))
380	  (mml-buffer-substring-no-properties-except-hard-newlines
381	   beg (if (> count 0)
382		   (point)
383		 (match-beginning 0))))
384      (if (re-search-forward
385	   "<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)." nil t)
386	  (prog1
387	      (mml-buffer-substring-no-properties-except-hard-newlines
388	       beg (match-beginning 0))
389	    (if (or (not (match-beginning 1))
390		    (equal (match-string 2) "multipart"))
391		(goto-char (match-beginning 0))
392	      (when (looking-at "[ \t]*\n")
393		(forward-line 1))))
394	(mml-buffer-substring-no-properties-except-hard-newlines
395	 beg (goto-char (point-max)))))))
396
397(defvar mml-boundary nil)
398(defvar mml-base-boundary "-=-=")
399(defvar mml-multipart-number 0)
400
401(defun mml-generate-mime ()
402  "Generate a MIME message based on the current MML document."
403  (let ((cont (mml-parse))
404	(mml-multipart-number mml-multipart-number))
405    (if (not cont)
406	nil
407      (with-temp-buffer
408	(if (and (consp (car cont))
409		 (= (length cont) 1))
410	    (mml-generate-mime-1 (car cont))
411	  (mml-generate-mime-1 (nconc (list 'multipart '(type . "mixed"))
412				      cont)))
413	(buffer-string)))))
414
415(defun mml-generate-mime-1 (cont)
416  (let ((mm-use-ultra-safe-encoding
417	 (or mm-use-ultra-safe-encoding (assq 'sign cont))))
418    (save-restriction
419      (narrow-to-region (point) (point))
420      (mml-tweak-part cont)
421      (cond
422       ((or (eq (car cont) 'part) (eq (car cont) 'mml))
423	(let* ((raw (cdr (assq 'raw cont)))
424	       (filename (cdr (assq 'filename cont)))
425	       (type (or (cdr (assq 'type cont))
426			 (if filename
427			     (or (mm-default-file-encoding filename)
428				 "application/octet-stream")
429			   "text/plain")))
430	       coded encoding charset flowed)
431	  (if (and (not raw)
432		   (member (car (split-string type "/")) '("text" "message")))
433	      (progn
434		(with-temp-buffer
435		  (setq charset (mm-charset-to-coding-system
436				 (cdr (assq 'charset cont))))
437		  (when (eq charset 'ascii)
438		    (setq charset nil))
439		  (cond
440		   ((cdr (assq 'buffer cont))
441		    (insert-buffer-substring (cdr (assq 'buffer cont))))
442		   ((and filename
443			 (not (equal (cdr (assq 'nofile cont)) "yes")))
444		    (let ((coding-system-for-read charset))
445		      (mm-insert-file-contents filename)))
446		   ((eq 'mml (car cont))
447		    (insert (cdr (assq 'contents cont))))
448		   (t
449		    (save-restriction
450		      (narrow-to-region (point) (point))
451		      (insert (cdr (assq 'contents cont)))
452		      ;; Remove quotes from quoted tags.
453		      (goto-char (point-min))
454		      (while (re-search-forward
455			      "<#!+/?\\(part\\|multipart\\|external\\|mml\\)"
456			      nil t)
457			(delete-region (+ (match-beginning 0) 2)
458				       (+ (match-beginning 0) 3))))))
459		  (cond
460		   ((eq (car cont) 'mml)
461		    (let ((mml-boundary (mml-compute-boundary cont))
462			  ;; It is necessary for the case where this
463			  ;; function is called recursively since
464			  ;; `m-g-d-t' will be bound to "message/rfc822"
465			  ;; when encoding an article to be forwarded.
466			  (mml-generate-default-type "text/plain"))
467		      (mml-to-mime))
468		    (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b")))
469		      ;; ignore 0x1b, it is part of iso-2022-jp
470		      (setq encoding (mm-body-7-or-8))))
471		   ((string= (car (split-string type "/")) "message")
472		    (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b")))
473		      ;; ignore 0x1b, it is part of iso-2022-jp
474		      (setq encoding (mm-body-7-or-8))))
475		   (t
476		    ;; Only perform format=flowed filling on text/plain
477		    ;; parts where there either isn't a format parameter
478		    ;; in the mml tag or it says "flowed" and there
479		    ;; actually are hard newlines in the text.
480		    (let (use-hard-newlines)
481		      (when (and (string= type "text/plain")
482				 (not (string= (cdr (assq 'sign cont)) "pgp"))
483				 (or (null (assq 'format cont))
484				     (string= (cdr (assq 'format cont))
485					      "flowed"))
486				 (setq use-hard-newlines
487				       (text-property-any
488					(point-min) (point-max) 'hard 't)))
489			(fill-flowed-encode)
490			;; Indicate that `mml-insert-mime-headers' should
491			;; insert a "; format=flowed" string unless the
492			;; user has already specified it.
493			(setq flowed (null (assq 'format cont)))))
494		    (setq charset (mm-encode-body charset))
495		    (setq encoding (mm-body-encoding
496				    charset (cdr (assq 'encoding cont))))))
497		  (setq coded (buffer-string)))
498		(mml-insert-mime-headers cont type charset encoding flowed)
499		(insert "\n")
500		(insert coded))
501	    (mm-with-unibyte-buffer
502	      (cond
503	       ((cdr (assq 'buffer cont))
504		(insert (mm-string-as-unibyte
505			 (with-current-buffer (cdr (assq 'buffer cont))
506			   (buffer-string)))))
507	       ((and filename
508		     (not (equal (cdr (assq 'nofile cont)) "yes")))
509		(let ((coding-system-for-read mm-binary-coding-system))
510		  (mm-insert-file-contents filename nil nil nil nil t)))
511	       (t
512		(let ((contents (cdr (assq 'contents cont))))
513		  (if (if (featurep 'xemacs)
514			  (string-match "[^\000-\377]" contents)
515			(mm-multibyte-string-p contents))
516		      (progn
517			(mm-enable-multibyte)
518			(insert contents)
519			(setq charset (mm-encode-body)))
520		    (insert contents)))))
521	      (setq encoding (mm-encode-buffer type)
522		    coded (mm-string-as-multibyte (buffer-string))))
523	    (mml-insert-mime-headers cont type charset encoding nil)
524	    (insert "\n")
525	    (mm-with-unibyte-current-buffer
526	      (insert coded)))))
527       ((eq (car cont) 'external)
528	(insert "Content-Type: message/external-body")
529	(let ((parameters (mml-parameter-string
530			   cont '(expiration size permission)))
531	      (name (cdr (assq 'name cont)))
532	      (url (cdr (assq 'url cont))))
533	  (when name
534	    (setq name (mml-parse-file-name name))
535	    (if (stringp name)
536		(mml-insert-parameter
537		 (mail-header-encode-parameter "name" name)
538		 "access-type=local-file")
539	      (mml-insert-parameter
540	       (mail-header-encode-parameter
541		"name" (file-name-nondirectory (nth 2 name)))
542	       (mail-header-encode-parameter "site" (nth 1 name))
543	       (mail-header-encode-parameter
544		"directory" (file-name-directory (nth 2 name))))
545	      (mml-insert-parameter
546	       (concat "access-type="
547		       (if (member (nth 0 name) '("ftp@" "anonymous@"))
548			   "anon-ftp"
549			 "ftp")))))
550	  (when url
551	    (mml-insert-parameter
552	     (mail-header-encode-parameter "url" url)
553	     "access-type=url"))
554	  (when parameters
555	    (mml-insert-parameter-string
556	     cont '(expiration size permission)))
557	  (insert "\n\n")
558	  (insert "Content-Type: "
559		  (or (cdr (assq 'type cont))
560		      (if name
561			  (or (mm-default-file-encoding name)
562			      "application/octet-stream")
563			"text/plain"))
564		  "\n")
565	  (insert "Content-ID: " (message-make-message-id) "\n")
566	  (insert "Content-Transfer-Encoding: "
567		  (or (cdr (assq 'encoding cont)) "binary"))
568	  (insert "\n\n")
569	  (insert (or (cdr (assq 'contents cont))))
570	  (insert "\n")))
571       ((eq (car cont) 'multipart)
572	(let* ((type (or (cdr (assq 'type cont)) "mixed"))
573	       (mml-generate-default-type (if (equal type "digest")
574					      "message/rfc822"
575					    "text/plain"))
576	       (handler (assoc type mml-generate-multipart-alist)))
577	  (if handler
578	      (funcall (cdr handler) cont)
579	    ;; No specific handler.  Use default one.
580	    (let ((mml-boundary (mml-compute-boundary cont)))
581	      (insert (format "Content-Type: multipart/%s; boundary=\"%s\""
582			      type mml-boundary)
583		      (if (cdr (assq 'start cont))
584			  (format "; start=\"%s\"\n" (cdr (assq 'start cont)))
585			"\n"))
586	      (let ((cont cont) part)
587		(while (setq part (pop cont))
588		  ;; Skip `multipart' and attributes.
589		  (when (and (consp part) (consp (cdr part)))
590		    (insert "\n--" mml-boundary "\n")
591		    (mml-generate-mime-1 part)
592		    (goto-char (point-max)))))
593	      (insert "\n--" mml-boundary "--\n")))))
594       (t
595	(error "Invalid element: %S" cont)))
596      ;; handle sign & encrypt tags in a semi-smart way.
597      (let ((sign-item (assoc (cdr (assq 'sign cont)) mml-sign-alist))
598	    (encrypt-item (assoc (cdr (assq 'encrypt cont))
599				 mml-encrypt-alist))
600	    sender recipients)
601	(when (or sign-item encrypt-item)
602	  (when (setq sender (cdr (assq 'sender cont)))
603	    (message-options-set 'mml-sender sender)
604	    (message-options-set 'message-sender sender))
605	  (if (setq recipients (cdr (assq 'recipients cont)))
606	      (message-options-set 'message-recipients recipients))
607	  (let ((style (mml-signencrypt-style
608			(first (or sign-item encrypt-item)))))
609	    ;; check if: we're both signing & encrypting, both methods
610	    ;; are the same (why would they be different?!), and that
611	    ;; the signencrypt style allows for combined operation.
612	    (if (and sign-item encrypt-item (equal (first sign-item)
613						   (first encrypt-item))
614		     (equal style 'combined))
615		(funcall (nth 1 encrypt-item) cont t)
616	      ;; otherwise, revert to the old behavior.
617	      (when sign-item
618		(funcall (nth 1 sign-item) cont))
619	      (when encrypt-item
620		(funcall (nth 1 encrypt-item) cont)))))))))
621
622(defun mml-compute-boundary (cont)
623  "Return a unique boundary that does not exist in CONT."
624  (let ((mml-boundary (funcall mml-boundary-function
625			       (incf mml-multipart-number))))
626    ;; This function tries again and again until it has found
627    ;; a unique boundary.
628    (while (not (catch 'not-unique
629		  (mml-compute-boundary-1 cont))))
630    mml-boundary))
631
632(defun mml-compute-boundary-1 (cont)
633  (let (filename)
634    (cond
635     ((eq (car cont) 'part)
636      (with-temp-buffer
637	(cond
638	 ((cdr (assq 'buffer cont))
639	  (insert-buffer-substring (cdr (assq 'buffer cont))))
640	 ((and (setq filename (cdr (assq 'filename cont)))
641	       (not (equal (cdr (assq 'nofile cont)) "yes")))
642	  (mm-insert-file-contents filename nil nil nil nil t))
643	 (t
644	  (insert (cdr (assq 'contents cont)))))
645	(goto-char (point-min))
646	(when (re-search-forward (concat "^--" (regexp-quote mml-boundary))
647				 nil t)
648	  (setq mml-boundary (funcall mml-boundary-function
649				      (incf mml-multipart-number)))
650	  (throw 'not-unique nil))))
651     ((eq (car cont) 'multipart)
652      (mapcar 'mml-compute-boundary-1 (cddr cont))))
653    t))
654
655(defun mml-make-boundary (number)
656  (concat (make-string (% number 60) ?=)
657	  (if (> number 17)
658	      (format "%x" number)
659	    "")
660	  mml-base-boundary))
661
662(defun mml-insert-mime-headers (cont type charset encoding flowed)
663  (let (parameters id disposition description)
664    (setq parameters
665	  (mml-parameter-string
666	   cont mml-content-type-parameters))
667    (when (or charset
668	      parameters
669	      flowed
670	      (not (equal type mml-generate-default-type))
671	      mml-insert-mime-headers-always)
672      (when (consp charset)
673	(error
674	 "Can't encode a part with several charsets"))
675      (insert "Content-Type: " type)
676      (when charset
677	(mml-insert-parameter
678	 (mail-header-encode-parameter "charset" (symbol-name charset))))
679      (when flowed
680	(mml-insert-parameter "format=flowed"))
681      (when parameters
682	(mml-insert-parameter-string
683	 cont mml-content-type-parameters))
684      (insert "\n"))
685    (when (setq id (cdr (assq 'id cont)))
686      (insert "Content-ID: " id "\n"))
687    (setq parameters
688	  (mml-parameter-string
689	   cont mml-content-disposition-parameters))
690    (when (or (setq disposition (cdr (assq 'disposition cont)))
691	      parameters)
692      (insert "Content-Disposition: " (or disposition "inline"))
693      (when parameters
694	(mml-insert-parameter-string
695	 cont mml-content-disposition-parameters))
696      (insert "\n"))
697    (unless (eq encoding '7bit)
698      (insert (format "Content-Transfer-Encoding: %s\n" encoding)))
699    (when (setq description (cdr (assq 'description cont)))
700      (insert "Content-Description: ")
701      (setq description (prog1
702			    (point)
703			  (insert description "\n")))
704      (mail-encode-encoded-word-region description (point)))))
705
706(defun mml-parameter-string (cont types)
707  (let ((string "")
708	value type)
709    (while (setq type (pop types))
710      (when (setq value (cdr (assq type cont)))
711	;; Strip directory component from the filename parameter.
712	(when (eq type 'filename)
713	  (setq value (file-name-nondirectory value)))
714	(setq string (concat string "; "
715			     (mail-header-encode-parameter
716			      (symbol-name type) value)))))
717    (when (not (zerop (length string)))
718      string)))
719
720(defun mml-insert-parameter-string (cont types)
721  (let (value type)
722    (while (setq type (pop types))
723      (when (setq value (cdr (assq type cont)))
724	;; Strip directory component from the filename parameter.
725	(when (eq type 'filename)
726	  (setq value (file-name-nondirectory value)))
727	(mml-insert-parameter
728	 (mail-header-encode-parameter
729	  (symbol-name type) value))))))
730
731(eval-when-compile
732  (defvar ange-ftp-name-format)
733  (defvar efs-path-regexp))
734(defun mml-parse-file-name (path)
735  (if (if (boundp 'efs-path-regexp)
736	  (string-match efs-path-regexp path)
737	(if (boundp 'ange-ftp-name-format)
738	    (string-match (car ange-ftp-name-format) path)))
739      (list (match-string 1 path) (match-string 2 path)
740	    (substring path (1+ (match-end 2))))
741    path))
742
743(defun mml-insert-buffer (buffer)
744  "Insert BUFFER at point and quote any MML markup."
745  (save-restriction
746    (narrow-to-region (point) (point))
747    (insert-buffer-substring buffer)
748    (mml-quote-region (point-min) (point-max))
749    (goto-char (point-max))))
750
751;;;
752;;; Transforming MIME to MML
753;;;
754
755(defun mime-to-mml (&optional handles)
756  "Translate the current buffer (which should be a message) into MML.
757If HANDLES is non-nil, use it instead reparsing the buffer."
758  ;; First decode the head.
759  (save-restriction
760    (message-narrow-to-head)
761    (let ((rfc2047-quote-decoded-words-containing-tspecials t))
762      (mail-decode-encoded-word-region (point-min) (point-max))))
763  (unless handles
764    (setq handles (mm-dissect-buffer t)))
765  (goto-char (point-min))
766  (search-forward "\n\n" nil t)
767  (delete-region (point) (point-max))
768  (if (stringp (car handles))
769      (mml-insert-mime handles)
770    (mml-insert-mime handles t))
771  (mm-destroy-parts handles)
772  (save-restriction
773    (message-narrow-to-head)
774    ;; Remove them, they are confusing.
775    (message-remove-header "Content-Type")
776    (message-remove-header "MIME-Version")
777    (message-remove-header "Content-Disposition")
778    (message-remove-header "Content-Transfer-Encoding")))
779
780(defun mml-to-mime ()
781  "Translate the current buffer from MML to MIME."
782  (message-encode-message-body)
783  (save-restriction
784    (message-narrow-to-headers-or-head)
785    ;; Skip past any From_ headers.
786    (while (looking-at "From ")
787      (forward-line 1))
788    (let ((mail-parse-charset message-default-charset))
789      (mail-encode-encoded-word-buffer))))
790
791(defun mml-insert-mime (handle &optional no-markup)
792  (let (textp buffer mmlp)
793    ;; Determine type and stuff.
794    (unless (stringp (car handle))
795      (unless (setq textp (equal (mm-handle-media-supertype handle) "text"))
796	(save-excursion
797	  (set-buffer (setq buffer (mml-generate-new-buffer " *mml*")))
798	  (mm-insert-part handle 'no-cache)
799	  (if (setq mmlp (equal (mm-handle-media-type handle)
800				"message/rfc822"))
801	      (mime-to-mml)))))
802    (if mmlp
803	(mml-insert-mml-markup handle nil t t)
804      (unless (and no-markup
805		   (equal (mm-handle-media-type handle) "text/plain"))
806	(mml-insert-mml-markup handle buffer textp)))
807    (cond
808     (mmlp
809      (insert-buffer-substring buffer)
810      (goto-char (point-max))
811      (insert "<#/mml>\n"))
812     ((stringp (car handle))
813      (mapcar 'mml-insert-mime (cdr handle))
814      (insert "<#/multipart>\n"))
815     (textp
816      (let ((charset (mail-content-type-get
817		      (mm-handle-type handle) 'charset))
818	    (start (point)))
819	(if (eq charset 'gnus-decoded)
820	    (mm-insert-part handle)
821	  (insert (mm-decode-string (mm-get-part handle) charset)))
822	(mml-quote-region start (point)))
823      (goto-char (point-max)))
824     (t
825      (insert "<#/part>\n")))))
826
827(defun mml-insert-mml-markup (handle &optional buffer nofile mmlp)
828  "Take a MIME handle and insert an MML tag."
829  (if (stringp (car handle))
830      (progn
831	(insert "<#multipart type=" (mm-handle-media-subtype handle))
832	(let ((start (mm-handle-multipart-ctl-parameter handle 'start)))
833	  (when start
834	    (insert " start=\"" start "\"")))
835	(insert ">\n"))
836    (if mmlp
837	(insert "<#mml type=" (mm-handle-media-type handle))
838      (insert "<#part type=" (mm-handle-media-type handle)))
839    (dolist (elem (append (cdr (mm-handle-type handle))
840			  (cdr (mm-handle-disposition handle))))
841      (unless (symbolp (cdr elem))
842	(insert " " (symbol-name (car elem)) "=\"" (cdr elem) "\"")))
843    (when (mm-handle-id handle)
844      (insert " id=\"" (mm-handle-id handle) "\""))
845    (when (mm-handle-disposition handle)
846      (insert " disposition=" (car (mm-handle-disposition handle))))
847    (when buffer
848      (insert " buffer=\"" (buffer-name buffer) "\""))
849    (when nofile
850      (insert " nofile=yes"))
851    (when (mm-handle-description handle)
852      (insert " description=\"" (mm-handle-description handle) "\""))
853    (insert ">\n")))
854
855(defun mml-insert-parameter (&rest parameters)
856  "Insert PARAMETERS in a nice way."
857  (let (start end)
858    (dolist (param parameters)
859      (insert ";")
860      (setq start (point))
861      (insert " " param)
862      (setq end (point))
863      (goto-char start)
864      (end-of-line)
865      (if (> (current-column) 76)
866	  (progn
867	    (goto-char start)
868	    (insert "\n")
869	    (goto-char (1+ end)))
870	(goto-char end)))))
871
872;;;
873;;; Mode for inserting and editing MML forms
874;;;
875
876(defvar mml-mode-map
877  (let ((sign (make-sparse-keymap))
878	(encrypt (make-sparse-keymap))
879	(signpart (make-sparse-keymap))
880	(encryptpart (make-sparse-keymap))
881	(map (make-sparse-keymap))
882	(main (make-sparse-keymap)))
883    (define-key map "\C-s" 'mml-secure-message-sign)
884    (define-key map "\C-c" 'mml-secure-message-encrypt)
885    (define-key map "\C-e" 'mml-secure-message-sign-encrypt)
886    (define-key map "\C-p\C-s" 'mml-secure-sign)
887    (define-key map "\C-p\C-c" 'mml-secure-encrypt)
888    (define-key sign "p" 'mml-secure-message-sign-pgpmime)
889    (define-key sign "o" 'mml-secure-message-sign-pgp)
890    (define-key sign "s" 'mml-secure-message-sign-smime)
891    (define-key signpart "p" 'mml-secure-sign-pgpmime)
892    (define-key signpart "o" 'mml-secure-sign-pgp)
893    (define-key signpart "s" 'mml-secure-sign-smime)
894    (define-key encrypt "p" 'mml-secure-message-encrypt-pgpmime)
895    (define-key encrypt "o" 'mml-secure-message-encrypt-pgp)
896    (define-key encrypt "s" 'mml-secure-message-encrypt-smime)
897    (define-key encryptpart "p" 'mml-secure-encrypt-pgpmime)
898    (define-key encryptpart "o" 'mml-secure-encrypt-pgp)
899    (define-key encryptpart "s" 'mml-secure-encrypt-smime)
900    (define-key map "\C-n" 'mml-unsecure-message)
901    (define-key map "f" 'mml-attach-file)
902    (define-key map "b" 'mml-attach-buffer)
903    (define-key map "e" 'mml-attach-external)
904    (define-key map "q" 'mml-quote-region)
905    (define-key map "m" 'mml-insert-multipart)
906    (define-key map "p" 'mml-insert-part)
907    (define-key map "v" 'mml-validate)
908    (define-key map "P" 'mml-preview)
909    (define-key map "s" sign)
910    (define-key map "S" signpart)
911    (define-key map "c" encrypt)
912    (define-key map "C" encryptpart)
913    ;;(define-key map "n" 'mml-narrow-to-part)
914    ;; `M-m' conflicts with `back-to-indentation'.
915    ;; (define-key main "\M-m" map)
916    (define-key main "\C-c\C-m" map)
917    main))
918
919(easy-menu-define
920  mml-menu mml-mode-map ""
921  `("Attachments"
922    ["Attach File..." mml-attach-file
923     ,@(if (featurep 'xemacs) '(t)
924	 '(:help "Attach a file at point"))]
925    ["Attach Buffer..." mml-attach-buffer
926     ,@(if (featurep 'xemacs) '(t)
927	 '(:help "Attach a buffer to the outgoing MIME message"))]
928    ["Attach External..." mml-attach-external
929     ,@(if (featurep 'xemacs) '(t)
930	 '(:help "Attach reference to file"))]
931    ;;
932    ("Change Security Method"
933     ["PGP/MIME"
934      (lambda () (interactive) (setq mml-secure-method "pgpmime"))
935      ,@(if (featurep 'xemacs) nil
936	  '(:help "Set Security Method to PGP/MIME"))
937      :style radio
938      :selected (equal mml-secure-method "pgpmime") ]
939     ["S/MIME"
940      (lambda () (interactive) (setq mml-secure-method "smime"))
941      ,@(if (featurep 'xemacs) nil
942	  '(:help "Set Security Method to S/MIME"))
943      :style radio
944      :selected (equal mml-secure-method "smime") ]
945     ["Inline PGP"
946      (lambda () (interactive) (setq mml-secure-method "pgp"))
947      ,@(if (featurep 'xemacs) nil
948	  '(:help "Set Security Method to inline PGP"))
949      :style radio
950      :selected (equal mml-secure-method "pgp") ] )
951    ;;
952    ["Sign Message" mml-secure-message-sign t]
953    ["Encrypt Message" mml-secure-message-encrypt t]
954    ["Sign and Encrypt Message" mml-secure-message-sign-encrypt t]
955    ["Encrypt/Sign off" mml-unsecure-message
956     ,@(if (featurep 'xemacs) '(t)
957	 '(:help "Don't Encrypt/Sign Message"))]
958    ;; Maybe we could remove these, because people who write MML most probably
959    ;; don't use the menu:
960    ["Insert Part..." mml-insert-part
961     :active (message-in-body-p)]
962    ["Insert Multipart..." mml-insert-multipart
963     :active (message-in-body-p)]
964    ;;
965    ;; Do we have separate encrypt and encrypt/sign commands for parts?
966    ["Sign Part" mml-secure-sign t]
967    ["Encrypt Part" mml-secure-encrypt t]
968    ;;["Narrow" mml-narrow-to-part t]
969    ["Quote MML in region" mml-quote-region
970     :active (message-mark-active-p)
971     ,@(if (featurep 'xemacs) nil
972	 '(:help "Quote MML tags in region"))]
973    ["Validate MML" mml-validate t]
974    ["Preview" mml-preview t]
975    "----"
976    ["Emacs MIME manual" (lambda () (interactive) (message-info 4))
977     ,@(if (featurep 'xemacs) '(t)
978	 '(:help "Display the Emacs MIME manual"))]
979    ["PGG manual" (lambda () (interactive) (message-info 16))
980     ,@(if (featurep 'xemacs) '(t)
981	 '(:help "Display the PGG manual"))]))
982
983(defvar mml-mode nil
984  "Minor mode for editing MML.")
985
986(defun mml-mode (&optional arg)
987  "Minor mode for editing MML.
988MML is the MIME Meta Language, a minor mode for composing MIME articles.
989See Info node `(emacs-mime)Composing'.
990
991\\{mml-mode-map}"
992  (interactive "P")
993  (when (set (make-local-variable 'mml-mode)
994	     (if (null arg) (not mml-mode)
995	       (> (prefix-numeric-value arg) 0)))
996    (add-minor-mode 'mml-mode " MML" mml-mode-map)
997    (easy-menu-add mml-menu mml-mode-map)
998    (when (boundp 'dnd-protocol-alist)
999      (set (make-local-variable 'dnd-protocol-alist)
1000	   (append mml-dnd-protocol-alist dnd-protocol-alist)))
1001    (run-hooks 'mml-mode-hook)))
1002
1003;;;
1004;;; Helper functions for reading MIME stuff from the minibuffer and
1005;;; inserting stuff to the buffer.
1006;;;
1007
1008(defun mml-minibuffer-read-file (prompt)
1009  (let* ((completion-ignored-extensions nil)
1010	 (file (read-file-name prompt nil nil t)))
1011    ;; Prevent some common errors.  This is inspired by similar code in
1012    ;; VM.
1013    (when (file-directory-p file)
1014      (error "%s is a directory, cannot attach" file))
1015    (unless (file-exists-p file)
1016      (error "No such file: %s" file))
1017    (unless (file-readable-p file)
1018      (error "Permission denied: %s" file))
1019    file))
1020
1021(defun mml-minibuffer-read-type (name &optional default)
1022  (mailcap-parse-mimetypes)
1023  (let* ((default (or default
1024		      (mm-default-file-encoding name)
1025		      ;; Perhaps here we should check what the file
1026		      ;; looks like, and offer text/plain if it looks
1027		      ;; like text/plain.
1028		      "application/octet-stream"))
1029	 (string (completing-read
1030		  (format "Content type (default %s): " default)
1031		  (mapcar 'list (mailcap-mime-types)))))
1032    (if (not (equal string ""))
1033	string
1034      default)))
1035
1036(defun mml-minibuffer-read-description ()
1037  (let ((description (read-string "One line description: ")))
1038    (when (string-match "\\`[ \t]*\\'" description)
1039      (setq description nil))
1040    description))
1041
1042(defun mml-minibuffer-read-disposition (type &optional default)
1043  (unless default (setq default
1044                        (if (and (string-match "\\`text/" type)
1045                                 (not (string-match "\\`text/rtf\\'" type)))
1046                            "inline"
1047                          "attachment")))
1048  (let ((disposition (completing-read
1049                      (format "Disposition (default %s): " default)
1050                      '(("attachment") ("inline") (""))
1051                      nil t nil nil default)))
1052    (if (not (equal disposition ""))
1053	disposition
1054      default)))
1055
1056(defun mml-quote-region (beg end)
1057  "Quote the MML tags in the region."
1058  (interactive "r")
1059  (save-excursion
1060    (save-restriction
1061      ;; Temporarily narrow the region to defend from changes
1062      ;; invalidating END.
1063      (narrow-to-region beg end)
1064      (goto-char (point-min))
1065      ;; Quote parts.
1066      (while (re-search-forward
1067	      "<#!*/?\\(multipart\\|part\\|external\\|mml\\)" nil t)
1068	;; Insert ! after the #.
1069	(goto-char (+ (match-beginning 0) 2))
1070	(insert "!")))))
1071
1072(defun mml-insert-tag (name &rest plist)
1073  "Insert an MML tag described by NAME and PLIST."
1074  (when (symbolp name)
1075    (setq name (symbol-name name)))
1076  (insert "<#" name)
1077  (while plist
1078    (let ((key (pop plist))
1079	  (value (pop plist)))
1080      (when value
1081	;; Quote VALUE if it contains suspicious characters.
1082	(when (string-match "[\"'\\~/*;() \t\n]" value)
1083	  (setq value (with-output-to-string
1084			(let (print-escape-nonascii)
1085			  (prin1 value)))))
1086	(insert (format " %s=%s" key value)))))
1087  (insert ">\n"))
1088
1089(defun mml-insert-empty-tag (name &rest plist)
1090  "Insert an empty MML tag described by NAME and PLIST."
1091  (when (symbolp name)
1092    (setq name (symbol-name name)))
1093  (apply #'mml-insert-tag name plist)
1094  (insert "<#/" name ">\n"))
1095
1096;;; Attachment functions.
1097
1098(defcustom mml-dnd-protocol-alist
1099  '(("^file:///" . mml-dnd-attach-file)
1100    ("^file://"  . dnd-open-file)
1101    ("^file:"    . mml-dnd-attach-file))
1102  "The functions to call when a drop in `mml-mode' is made.
1103See `dnd-protocol-alist' for more information.  When nil, behave
1104as in other buffers."
1105  :type '(choice (repeat (cons (regexp) (function)))
1106		 (const :tag "Behave as in other buffers" nil))
1107  :version "22.1" ;; Gnus 5.10.9
1108  :group 'message)
1109
1110(defcustom mml-dnd-attach-options nil
1111  "Which options should be queried when attaching a file via drag and drop.
1112
1113If it is a list, valid members are `type', `description' and
1114`disposition'.  `disposition' implies `type'.  If it is nil,
1115don't ask for options.  If it is t, ask the user whether or not
1116to specify options."
1117  :type '(choice
1118	  (const :tag "Non" nil)
1119	  (const :tag "Query" t)
1120	  (list :value (type description disposition)
1121	   (set :inline t
1122		(const type)
1123		(const description)
1124		(const disposition))))
1125  :version "22.1" ;; Gnus 5.10.9
1126  :group 'message)
1127
1128(defun mml-attach-file (file &optional type description disposition)
1129  "Attach a file to the outgoing MIME message.
1130The file is not inserted or encoded until you send the message with
1131`\\[message-send-and-exit]' or `\\[message-send]'.
1132
1133FILE is the name of the file to attach.  TYPE is its
1134content-type, a string of the form \"type/subtype\".  DESCRIPTION
1135is a one-line description of the attachment.  The DISPOSITION
1136specifies how the attachment is intended to be displayed.  It can
1137be either \"inline\" (displayed automatically within the message
1138body) or \"attachment\" (separate from the body)."
1139  (interactive
1140   (let* ((file (mml-minibuffer-read-file "Attach file: "))
1141	  (type (mml-minibuffer-read-type file))
1142	  (description (mml-minibuffer-read-description))
1143	  (disposition (mml-minibuffer-read-disposition type)))
1144     (list file type description disposition)))
1145  (save-excursion
1146    (unless (message-in-body-p) (goto-char (point-max)))
1147    (mml-insert-empty-tag 'part
1148			  'type type
1149			  'filename file
1150			  'disposition (or disposition "attachment")
1151			  'description description)))
1152
1153(defun mml-dnd-attach-file (uri action)
1154  "Attach a drag and drop file.
1155
1156Ask for type, description or disposition according to
1157`mml-dnd-attach-options'."
1158  (let ((file (dnd-get-local-file-name uri t)))
1159    (when (and file (file-regular-p file))
1160      (let ((mml-dnd-attach-options mml-dnd-attach-options)
1161	    type description disposition)
1162	(setq mml-dnd-attach-options
1163	      (when (and (eq mml-dnd-attach-options t)
1164			 (not
1165			  (y-or-n-p
1166			   "Use default type, disposition and description? ")))
1167		'(type description disposition)))
1168	(when (or (memq 'type mml-dnd-attach-options)
1169		  (memq 'disposition mml-dnd-attach-options))
1170	  (setq type (mml-minibuffer-read-type file)))
1171	(when (memq 'description mml-dnd-attach-options)
1172	  (setq description (mml-minibuffer-read-description)))
1173	(when (memq 'disposition mml-dnd-attach-options)
1174	  (setq disposition (mml-minibuffer-read-disposition type)))
1175	(mml-attach-file file type description disposition)))))
1176
1177(defun mml-attach-buffer (buffer &optional type description)
1178  "Attach a buffer to the outgoing MIME message.
1179See `mml-attach-file' for details of operation."
1180  (interactive
1181   (let* ((buffer (read-buffer "Attach buffer: "))
1182	  (type (mml-minibuffer-read-type buffer "text/plain"))
1183	  (description (mml-minibuffer-read-description)))
1184     (list buffer type description)))
1185  (save-excursion
1186    (unless (message-in-body-p) (goto-char (point-max)))
1187    (mml-insert-empty-tag 'part 'type type 'buffer buffer
1188			  'disposition "attachment"
1189			  'description description)))
1190
1191(defun mml-attach-external (file &optional type description)
1192  "Attach an external file into the buffer.
1193FILE is an ange-ftp/efs specification of the part location.
1194TYPE is the MIME type to use."
1195  (interactive
1196   (let* ((file (mml-minibuffer-read-file "Attach external file: "))
1197	  (type (mml-minibuffer-read-type file))
1198	  (description (mml-minibuffer-read-description)))
1199     (list file type description)))
1200  (save-excursion
1201    (unless (message-in-body-p) (goto-char (point-max)))
1202    (mml-insert-empty-tag 'external 'type type 'name file
1203			  'disposition "attachment" 'description description)))
1204
1205(defun mml-insert-multipart (&optional type)
1206  (interactive (list (completing-read "Multipart type (default mixed): "
1207				      '(("mixed") ("alternative") ("digest") ("parallel")
1208					("signed") ("encrypted"))
1209				      nil nil "mixed")))
1210  (or type
1211      (setq type "mixed"))
1212  (mml-insert-empty-tag "multipart" 'type type)
1213  (forward-line -1))
1214
1215(defun mml-insert-part (&optional type)
1216  (interactive
1217   (list (mml-minibuffer-read-type "")))
1218  (mml-insert-tag 'part 'type type 'disposition "inline")
1219  (forward-line -1))
1220
1221(defun mml-preview-insert-mail-followup-to ()
1222  "Insert a Mail-Followup-To header before previewing an article.
1223Should be adopted if code in `message-send-mail' is changed."
1224  (when (and (message-mail-p)
1225	     (message-subscribed-p)
1226	     (not (mail-fetch-field "mail-followup-to"))
1227	     (message-make-mail-followup-to))
1228    (message-position-on-field "Mail-Followup-To" "X-Draft-From")
1229    (insert (message-make-mail-followup-to))))
1230
1231(defun mml-preview (&optional raw)
1232  "Display current buffer with Gnus, in a new buffer.
1233If RAW, display a raw encoded MIME message."
1234  (interactive "P")
1235  (save-excursion
1236    (let* ((buf (current-buffer))
1237	   (message-options message-options)
1238	   (message-this-is-mail (message-mail-p))
1239	   (message-this-is-news (message-news-p))
1240	   (message-posting-charset (or (gnus-setup-posting-charset
1241					 (save-restriction
1242					   (message-narrow-to-headers-or-head)
1243					   (message-fetch-field "Newsgroups")))
1244					message-posting-charset)))
1245      (message-options-set-recipient)
1246      (pop-to-buffer (generate-new-buffer
1247		      (concat (if raw "*Raw MIME preview of "
1248				"*MIME preview of ") (buffer-name))))
1249      (when (boundp 'gnus-buffers)
1250	(push (current-buffer) gnus-buffers))
1251      (erase-buffer)
1252      (insert-buffer-substring buf)
1253      (mml-preview-insert-mail-followup-to)
1254      (let ((message-deletable-headers (if (message-news-p)
1255					   nil
1256					 message-deletable-headers)))
1257	(message-generate-headers
1258	 (copy-sequence (if (message-news-p)
1259			    message-required-news-headers
1260			  message-required-mail-headers))))
1261      (if (re-search-forward
1262	   (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
1263	  (replace-match "\n"))
1264      (let ((mail-header-separator ""));; mail-header-separator is removed.
1265	(mml-to-mime))
1266      (if raw
1267	  (when (fboundp 'set-buffer-multibyte)
1268	    (let ((s (buffer-string)))
1269	      ;; Insert the content into unibyte buffer.
1270	      (erase-buffer)
1271	      (mm-disable-multibyte)
1272	      (insert s)))
1273	(let ((gnus-newsgroup-charset (car message-posting-charset))
1274	      gnus-article-prepare-hook gnus-original-article-buffer)
1275	  (run-hooks 'gnus-article-decode-hook)
1276	  (let ((gnus-newsgroup-name "dummy")
1277		(gnus-newsrc-hashtb (or gnus-newsrc-hashtb
1278					(gnus-make-hashtable 5))))
1279	    (gnus-article-prepare-display))))
1280      ;; Disable article-mode-map.
1281      (use-local-map nil)
1282      (gnus-make-local-hook 'kill-buffer-hook)
1283      (add-hook 'kill-buffer-hook
1284		(lambda ()
1285		  (mm-destroy-parts gnus-article-mime-handles)) nil t)
1286      (setq buffer-read-only t)
1287      (local-set-key "q" (lambda () (interactive) (kill-buffer nil)))
1288      (local-set-key "=" (lambda () (interactive) (delete-other-windows)))
1289      (local-set-key "\r"
1290		     (lambda ()
1291		       (interactive)
1292		       (widget-button-press (point))))
1293      (local-set-key gnus-mouse-2
1294		     (lambda (event)
1295		       (interactive "@e")
1296		       (widget-button-press (widget-event-point event) event)))
1297      (goto-char (point-min)))))
1298
1299(defun mml-validate ()
1300  "Validate the current MML document."
1301  (interactive)
1302  (mml-parse))
1303
1304(defun mml-tweak-part (cont)
1305  "Tweak a MML part."
1306  (let ((tweak (cdr (assq 'tweak cont)))
1307	func)
1308    (cond
1309     (tweak
1310      (setq func
1311	    (or (cdr (assoc tweak mml-tweak-function-alist))
1312		(intern tweak))))
1313     (mml-tweak-type-alist
1314      (let ((alist mml-tweak-type-alist)
1315	    (type (or (cdr (assq 'type cont)) "text/plain")))
1316	(while alist
1317	  (if (string-match (caar alist) type)
1318	      (setq func (cdar alist)
1319		    alist nil)
1320	    (setq alist (cdr alist)))))))
1321    (if func
1322	(funcall func cont)
1323      cont)
1324    (let ((alist mml-tweak-sexp-alist))
1325      (while alist
1326	(if (eval (caar alist))
1327	    (funcall (cdar alist) cont))
1328	(setq alist (cdr alist)))))
1329  cont)
1330
1331(defun mml-tweak-externalize-attachments (cont)
1332  "Tweak attached files as external parts."
1333  (let (filename-cons)
1334    (when (and (eq (car cont) 'part)
1335	       (not (cdr (assq 'buffer cont)))
1336	       (and (setq filename-cons (assq 'filename cont))
1337		    (not (equal (cdr (assq 'nofile cont)) "yes"))))
1338      (setcar cont 'external)
1339      (setcar filename-cons 'name))))
1340
1341(provide 'mml)
1342
1343;;; arch-tag: 583c96cf-1ffe-451b-a5e5-4733ae9ddd12
1344;;; mml.el ends here
1345