1 ;;; mml.el --- A package for parsing and validating MML documents
3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 ;; 2005, 2006 Free Software Foundation, Inc.
6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
7 ;; This file is part of GNU Emacs.
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)
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.
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.
33 (eval-when-compile (require 'cl))
36 (autoload 'message-make-message-id "message")
37 (autoload 'gnus-setup-posting-charset "gnus-msg")
38 (autoload 'gnus-make-local-hook "gnus-util")
39 (autoload 'message-fetch-field "message")
40 (autoload 'message-mark-active-p "message")
41 (autoload 'message-info "message")
42 (autoload 'fill-flowed-encode "flow-fill")
43 (autoload 'message-posting-charset "message"))
46 (autoload 'dnd-get-local-file-name "dnd"))
48 (defvar gnus-article-mime-handles)
50 (defvar gnus-newsrc-hashtb)
51 (defvar message-default-charset)
52 (defvar message-deletable-headers)
53 (defvar message-options)
54 (defvar message-posting-charset)
55 (defvar message-required-mail-headers)
56 (defvar message-required-news-headers)
58 (defcustom mml-content-type-parameters
59 '(name access-type expiration size permission format)
60 "*A list of acceptable parameters in MML tag.
61 These parameters are generated in Content-Type header if exists."
63 :type '(repeat (symbol :tag "Parameter"))
66 (defcustom mml-content-disposition-parameters
67 '(filename creation-date modification-date read-date)
68 "*A list of acceptable parameters in MML tag.
69 These parameters are generated in Content-Disposition header if exists."
71 :type '(repeat (symbol :tag "Parameter"))
74 (defcustom mml-insert-mime-headers-always nil
75 "If non-nil, always put Content-Type: text/plain at top of empty parts.
76 It is necessary to work against a bug in certain clients."
81 (defvar mml-tweak-type-alist nil
82 "A list of (TYPE . FUNCTION) for tweaking MML parts.
83 TYPE is a string containing a regexp to match the MIME type. FUNCTION
84 is a Lisp function which is called with the MML handle to tweak the
85 part. This variable is used only when no TWEAK parameter exists in
88 (defvar mml-tweak-function-alist nil
89 "A list of (NAME . FUNCTION) for tweaking MML parts.
90 NAME is a string containing the name of the TWEAK parameter in the MML
91 handle. FUNCTION is a Lisp function which is called with the MML
92 handle to tweak the part.")
94 (defvar mml-tweak-sexp-alist
95 '((mml-externalize-attachments . mml-tweak-externalize-attachments))
96 "A list of (SEXP . FUNCTION) for tweaking MML parts.
97 SEXP is an s-expression. If the evaluation of SEXP is non-nil, FUNCTION
98 is called. FUNCTION is a Lisp function which is called with the MML
99 handle to tweak the part.")
101 (defvar mml-externalize-attachments nil
102 "*If non-nil, local-file attachments are generated as external parts.")
104 (defvar mml-generate-multipart-alist nil
105 "*Alist of multipart generation functions.
106 Each entry has the form (NAME . FUNCTION), where
107 NAME is a string containing the name of the part (without the
108 leading \"/multipart/\"),
109 FUNCTION is a Lisp function which is called to generate the part.
111 The Lisp function has to supply the appropriate MIME headers and the
112 contents of this part.")
114 (defvar mml-syntax-table
115 (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table)))
116 (modify-syntax-entry ?\\ "/" table)
117 (modify-syntax-entry ?< "(" table)
118 (modify-syntax-entry ?> ")" table)
119 (modify-syntax-entry ?@ "w" table)
120 (modify-syntax-entry ?/ "w" table)
121 (modify-syntax-entry ?= " " table)
122 (modify-syntax-entry ?* " " table)
123 (modify-syntax-entry ?\; " " table)
124 (modify-syntax-entry ?\' " " table)
127 (defvar mml-boundary-function 'mml-make-boundary
128 "A function called to suggest a boundary.
129 The function may be called several times, and should try to make a new
130 suggestion each time. The function is called with one parameter,
131 which is a number that says how many times the function has been
132 called for this message.")
134 (defvar mml-confirmation-set nil
135 "A list of symbols, each of which disables some warning.
136 `unknown-encoding': always send messages contain characters with
137 unknown encoding; `use-ascii': always use ASCII for those characters
138 with unknown encoding; `multipart': always send messages with more than
141 (defvar mml-generate-default-type "text/plain"
142 "Content type by which the Content-Type header can be omitted.
143 The Content-Type header will not be put in the MIME part if the type
144 equals the value and there's no parameter (e.g. charset, format, etc.)
145 and `mml-insert-mime-headers-always' is nil. The value will be bound
146 to \"message/rfc822\" when encoding an article to be forwarded as a MIME
147 part. This is for the internal use, you should never modify the value.")
149 (defvar mml-buffer-list nil)
151 (defun mml-generate-new-buffer (name)
152 (let ((buf (generate-new-buffer name)))
153 (push buf mml-buffer-list)
156 (defun mml-destroy-buffers ()
157 (let (kill-buffer-hook)
158 (mapc 'kill-buffer mml-buffer-list)
159 (setq mml-buffer-list nil)))
162 "Parse the current buffer as an MML document."
164 (goto-char (point-min))
165 (with-syntax-table mml-syntax-table
168 (defun mml-parse-1 ()
169 "Parse the current buffer as an MML document."
170 (let (struct tag point contents charsets warn use-ascii no-markup-p raw)
171 (while (and (not (eobp))
172 (not (looking-at "<#/multipart")))
174 ((looking-at "<#secure")
175 ;; The secure part is essentially a meta-meta tag, which
176 ;; expands to either a part tag if there are no other parts in
177 ;; the document or a multipart tag if there are other parts
178 ;; included in the message
180 (taginfo (mml-read-tag))
181 (keyfile (cdr (assq 'keyfile taginfo)))
182 (certfile (cdr (assq 'certfile taginfo)))
183 (recipients (cdr (assq 'recipients taginfo)))
184 (sender (cdr (assq 'sender taginfo)))
185 (location (cdr (assq 'tag-location taginfo)))
186 (mode (cdr (assq 'mode taginfo)))
187 (method (cdr (assq 'method taginfo)))
190 (if (re-search-forward
191 "<#/?\\(multipart\\|part\\|external\\|mml\\)." nil t)
192 (setq secure-mode "multipart")
193 (setq secure-mode "part")))
196 (re-search-forward "<#secure[^\n]*>\n"))
197 (delete-region (match-beginning 0) (match-end 0))
198 (cond ((string= mode "sign")
199 (setq tags (list "sign" method)))
200 ((string= mode "encrypt")
201 (setq tags (list "encrypt" method)))
202 ((string= mode "signencrypt")
203 (setq tags (list "sign" method "encrypt" method))))
204 (eval `(mml-insert-tag ,secure-mode
206 ,(if keyfile "keyfile")
208 ,(if certfile "certfile")
210 ,(if recipients "recipients")
212 ,(if sender "sender")
215 (goto-char location)))
216 ((looking-at "<#multipart")
217 (push (nconc (mml-read-tag) (mml-parse-1)) struct))
218 ((looking-at "<#external")
219 (push (nconc (mml-read-tag) (list (cons 'contents (mml-read-part))))
222 (if (or (looking-at "<#part") (looking-at "<#mml"))
223 (setq tag (mml-read-tag)
226 (setq tag (list 'part '(type . "text/plain"))
229 (setq raw (cdr (assq 'raw tag))
231 contents (mml-read-part (eq 'mml (car tag)))
236 (intern (downcase (cdr (assq 'charset tag))))))
238 (mm-find-mime-charset-region point (point)
240 (when (and (not raw) (memq nil charsets))
241 (if (or (memq 'unknown-encoding mml-confirmation-set)
242 (message-options-get 'unknown-encoding)
244 Message contains characters with unknown encoding. Really send? ")
245 (message-options-set 'unknown-encoding t)))
247 (or (memq 'use-ascii mml-confirmation-set)
248 (message-options-get 'use-ascii)
249 (and (y-or-n-p "Use ASCII as charset? ")
250 (message-options-set 'use-ascii t))))
251 (setq charsets (delq nil charsets))
253 (error "Edit your message to remove those characters")))
256 (< (length charsets) 2))
257 (if (or (not no-markup-p)
258 (string-match "[^ \t\r\n]" contents))
259 ;; Don't create blank parts.
260 (push (nconc tag (list (cons 'contents contents)))
262 (let ((nstruct (mml-parse-singlepart-with-multiple-charsets
263 tag point (point) use-ascii)))
265 (not (memq 'multipart mml-confirmation-set))
266 (not (message-options-get 'multipart))
267 (not (and (y-or-n-p (format "\
268 A message part needs to be split into %d charset parts. Really send? "
270 (message-options-set 'multipart t))))
271 (error "Edit your message to use only one charset"))
272 (setq struct (nconc nstruct struct)))))))
277 (defun mml-parse-singlepart-with-multiple-charsets
278 (orig-tag beg end &optional use-ascii)
281 (narrow-to-region beg end)
282 (goto-char (point-min))
283 (let ((current (or (mm-mime-charset (mm-charset-after))
284 (and use-ascii 'us-ascii)))
285 charset struct space newline paragraph)
287 (setq charset (mm-mime-charset (mm-charset-after)))
289 ;; The charset remains the same.
290 ((eq charset 'us-ascii))
291 ((or (and use-ascii (not charset))
292 (eq charset current))
296 ;; The initial charset was ascii.
297 ((eq current 'us-ascii)
298 (setq current charset
302 ;; We have a change in charsets.
306 (list (cons 'contents
307 (buffer-substring-no-properties
308 beg (or paragraph newline space (point))))))
310 (setq beg (or paragraph newline space (point))
315 ;; Compute places where it might be nice to break the part.
317 ((memq (following-char) '(? ?\t))
318 (setq space (1+ (point))))
319 ((and (eq (following-char) ?\n)
321 (eq (char-after (1- (point))) ?\n))
322 (setq paragraph (point)))
323 ((eq (following-char) ?\n)
324 (setq newline (1+ (point)))))
326 ;; Do the final part.
327 (unless (= beg (point))
328 (push (append orig-tag
329 (list (cons 'contents
330 (buffer-substring-no-properties
335 (defun mml-read-tag ()
336 "Read a tag and return the contents."
337 (let ((orig-point (point))
338 contents name elem val)
340 (setq name (buffer-substring-no-properties
341 (point) (progn (forward-sexp 1) (point))))
342 (skip-chars-forward " \t\n")
343 (while (not (looking-at ">[ \t]*\n?"))
344 (setq elem (buffer-substring-no-properties
345 (point) (progn (forward-sexp 1) (point))))
346 (skip-chars-forward "= \t\n")
347 (setq val (buffer-substring-no-properties
348 (point) (progn (forward-sexp 1) (point))))
349 (when (string-match "^\"\\(.*\\)\"$" val)
350 (setq val (match-string 1 val)))
351 (push (cons (intern elem) val) contents)
352 (skip-chars-forward " \t\n"))
353 (goto-char (match-end 0))
354 ;; Don't skip the leading space.
355 ;;(skip-chars-forward " \t\n")
356 ;; Put the tag location into the returned contents
357 (setq contents (append (list (cons 'tag-location orig-point)) contents))
358 (cons (intern name) (nreverse contents))))
360 (defun mml-buffer-substring-no-properties-except-hard-newlines (start end)
361 (let ((str (buffer-substring-no-properties start end))
362 (bufstart start) tmp)
363 (while (setq tmp (text-property-any start end 'hard 't))
364 (set-text-properties (- tmp bufstart) (- tmp bufstart -1)
366 (setq start (1+ tmp)))
369 (defun mml-read-part (&optional mml)
370 "Return the buffer up till the next part, multipart or closing part or multipart.
371 If MML is non-nil, return the buffer up till the correspondent mml tag."
372 (let ((beg (point)) (count 1))
373 ;; If the tag ended at the end of the line, we go to the next line.
374 (when (looking-at "[ \t]*\n")
378 (while (and (> count 0) (not (eobp)))
379 (if (re-search-forward "<#\\(/\\)?mml." nil t)
380 (setq count (+ count (if (match-beginning 1) -1 1)))
381 (goto-char (point-max))))
382 (mml-buffer-substring-no-properties-except-hard-newlines
385 (match-beginning 0))))
386 (if (re-search-forward
387 "<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)." nil t)
389 (mml-buffer-substring-no-properties-except-hard-newlines
390 beg (match-beginning 0))
391 (if (or (not (match-beginning 1))
392 (equal (match-string 2) "multipart"))
393 (goto-char (match-beginning 0))
394 (when (looking-at "[ \t]*\n")
396 (mml-buffer-substring-no-properties-except-hard-newlines
397 beg (goto-char (point-max)))))))
399 (defvar mml-boundary nil)
400 (defvar mml-base-boundary "-=-=")
401 (defvar mml-multipart-number 0)
403 (defun mml-generate-mime ()
404 "Generate a MIME message based on the current MML document."
405 (let ((cont (mml-parse))
406 (mml-multipart-number mml-multipart-number))
410 (if (and (consp (car cont))
412 (mml-generate-mime-1 (car cont))
413 (mml-generate-mime-1 (nconc (list 'multipart '(type . "mixed"))
417 (defun mml-generate-mime-1 (cont)
418 (let ((mm-use-ultra-safe-encoding
419 (or mm-use-ultra-safe-encoding (assq 'sign cont))))
421 (narrow-to-region (point) (point))
422 (mml-tweak-part cont)
424 ((or (eq (car cont) 'part) (eq (car cont) 'mml))
425 (let* ((raw (cdr (assq 'raw cont)))
426 (filename (cdr (assq 'filename cont)))
427 (type (or (cdr (assq 'type cont))
429 (or (mm-default-file-encoding filename)
430 "application/octet-stream")
432 (charset (cdr (assq 'charset cont)))
433 (coding (mm-charset-to-coding-system charset))
434 encoding flowed coded)
435 (cond ((eq coding 'ascii)
439 (setq charset (intern (downcase charset)))))
441 (member (car (split-string type "/")) '("text" "message")))
445 ((cdr (assq 'buffer cont))
446 (insert-buffer-substring (cdr (assq 'buffer cont))))
448 (not (equal (cdr (assq 'nofile cont)) "yes")))
449 (let ((coding-system-for-read coding))
450 (mm-insert-file-contents filename)))
451 ((eq 'mml (car cont))
452 (insert (cdr (assq 'contents cont))))
455 (narrow-to-region (point) (point))
456 (insert (cdr (assq 'contents cont)))
457 ;; Remove quotes from quoted tags.
458 (goto-char (point-min))
459 (while (re-search-forward
460 "<#!+/?\\(part\\|multipart\\|external\\|mml\\)"
462 (delete-region (+ (match-beginning 0) 2)
463 (+ (match-beginning 0) 3))))))
465 ((eq (car cont) 'mml)
466 (let ((mml-boundary (mml-compute-boundary cont))
467 ;; It is necessary for the case where this
468 ;; function is called recursively since
469 ;; `m-g-d-t' will be bound to "message/rfc822"
470 ;; when encoding an article to be forwarded.
471 (mml-generate-default-type "text/plain"))
473 (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b")))
474 ;; ignore 0x1b, it is part of iso-2022-jp
475 (setq encoding (mm-body-7-or-8))))
476 ((string= (car (split-string type "/")) "message")
477 (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b")))
478 ;; ignore 0x1b, it is part of iso-2022-jp
479 (setq encoding (mm-body-7-or-8))))
481 ;; Only perform format=flowed filling on text/plain
482 ;; parts where there either isn't a format parameter
483 ;; in the mml tag or it says "flowed" and there
484 ;; actually are hard newlines in the text.
485 (let (use-hard-newlines)
486 (when (and (string= type "text/plain")
487 (not (string= (cdr (assq 'sign cont)) "pgp"))
488 (or (null (assq 'format cont))
489 (string= (cdr (assq 'format cont))
491 (setq use-hard-newlines
493 (point-min) (point-max) 'hard 't)))
495 ;; Indicate that `mml-insert-mime-headers' should
496 ;; insert a "; format=flowed" string unless the
497 ;; user has already specified it.
498 (setq flowed (null (assq 'format cont)))))
499 (setq charset (mm-encode-body charset))
500 (setq encoding (mm-body-encoding
501 charset (cdr (assq 'encoding cont))))))
502 (setq coded (buffer-string)))
503 (mml-insert-mime-headers cont type charset encoding flowed)
506 (mm-with-unibyte-buffer
508 ((cdr (assq 'buffer cont))
509 (insert (with-current-buffer (cdr (assq 'buffer cont))
510 (mm-with-unibyte-current-buffer
513 (not (equal (cdr (assq 'nofile cont)) "yes")))
514 (let ((coding-system-for-read mm-binary-coding-system))
515 (mm-insert-file-contents filename nil nil nil nil t))
517 (setq charset (mm-coding-system-to-mime-charset
518 (mm-find-buffer-file-coding-system
521 (let ((contents (cdr (assq 'contents cont))))
522 (if (if (featurep 'xemacs)
523 (string-match "[^\000-\377]" contents)
524 (mm-multibyte-string-p contents))
526 (mm-enable-multibyte)
528 (setq charset (mm-encode-body charset)))
529 (insert contents)))))
530 (setq encoding (mm-encode-buffer type)
531 coded (mm-string-as-multibyte (buffer-string))))
532 (mml-insert-mime-headers cont type charset encoding nil)
534 (mm-with-unibyte-current-buffer
536 ((eq (car cont) 'external)
537 (insert "Content-Type: message/external-body")
538 (let ((parameters (mml-parameter-string
539 cont '(expiration size permission)))
540 (name (cdr (assq 'name cont)))
541 (url (cdr (assq 'url cont))))
543 (setq name (mml-parse-file-name name))
545 (mml-insert-parameter
546 (mail-header-encode-parameter "name" name)
547 "access-type=local-file")
548 (mml-insert-parameter
549 (mail-header-encode-parameter
550 "name" (file-name-nondirectory (nth 2 name)))
551 (mail-header-encode-parameter "site" (nth 1 name))
552 (mail-header-encode-parameter
553 "directory" (file-name-directory (nth 2 name))))
554 (mml-insert-parameter
555 (concat "access-type="
556 (if (member (nth 0 name) '("ftp@" "anonymous@"))
560 (mml-insert-parameter
561 (mail-header-encode-parameter "url" url)
564 (mml-insert-parameter-string
565 cont '(expiration size permission)))
567 (insert "Content-Type: "
568 (or (cdr (assq 'type cont))
570 (or (mm-default-file-encoding name)
571 "application/octet-stream")
574 (insert "Content-ID: " (message-make-message-id) "\n")
575 (insert "Content-Transfer-Encoding: "
576 (or (cdr (assq 'encoding cont)) "binary"))
578 (insert (or (cdr (assq 'contents cont))))
580 ((eq (car cont) 'multipart)
581 (let* ((type (or (cdr (assq 'type cont)) "mixed"))
582 (mml-generate-default-type (if (equal type "digest")
585 (handler (assoc type mml-generate-multipart-alist)))
587 (funcall (cdr handler) cont)
588 ;; No specific handler. Use default one.
589 (let ((mml-boundary (mml-compute-boundary cont)))
590 (insert (format "Content-Type: multipart/%s; boundary=\"%s\""
592 (if (cdr (assq 'start cont))
593 (format "; start=\"%s\"\n" (cdr (assq 'start cont)))
595 (let ((cont cont) part)
596 (while (setq part (pop cont))
597 ;; Skip `multipart' and attributes.
598 (when (and (consp part) (consp (cdr part)))
599 (insert "\n--" mml-boundary "\n")
600 (mml-generate-mime-1 part)
601 (goto-char (point-max)))))
602 (insert "\n--" mml-boundary "--\n")))))
604 (error "Invalid element: %S" cont)))
605 ;; handle sign & encrypt tags in a semi-smart way.
606 (let ((sign-item (assoc (cdr (assq 'sign cont)) mml-sign-alist))
607 (encrypt-item (assoc (cdr (assq 'encrypt cont))
610 (when (or sign-item encrypt-item)
611 (when (setq sender (cdr (assq 'sender cont)))
612 (message-options-set 'mml-sender sender)
613 (message-options-set 'message-sender sender))
614 (if (setq recipients (cdr (assq 'recipients cont)))
615 (message-options-set 'message-recipients recipients))
616 (let ((style (mml-signencrypt-style
617 (first (or sign-item encrypt-item)))))
618 ;; check if: we're both signing & encrypting, both methods
619 ;; are the same (why would they be different?!), and that
620 ;; the signencrypt style allows for combined operation.
621 (if (and sign-item encrypt-item (equal (first sign-item)
622 (first encrypt-item))
623 (equal style 'combined))
624 (funcall (nth 1 encrypt-item) cont t)
625 ;; otherwise, revert to the old behavior.
627 (funcall (nth 1 sign-item) cont))
629 (funcall (nth 1 encrypt-item) cont)))))))))
631 (defun mml-compute-boundary (cont)
632 "Return a unique boundary that does not exist in CONT."
633 (let ((mml-boundary (funcall mml-boundary-function
634 (incf mml-multipart-number))))
635 ;; This function tries again and again until it has found
636 ;; a unique boundary.
637 (while (not (catch 'not-unique
638 (mml-compute-boundary-1 cont))))
641 (defun mml-compute-boundary-1 (cont)
644 ((eq (car cont) 'part)
647 ((cdr (assq 'buffer cont))
648 (insert-buffer-substring (cdr (assq 'buffer cont))))
649 ((and (setq filename (cdr (assq 'filename cont)))
650 (not (equal (cdr (assq 'nofile cont)) "yes")))
651 (mm-insert-file-contents filename nil nil nil nil t))
653 (insert (cdr (assq 'contents cont)))))
654 (goto-char (point-min))
655 (when (re-search-forward (concat "^--" (regexp-quote mml-boundary))
657 (setq mml-boundary (funcall mml-boundary-function
658 (incf mml-multipart-number)))
659 (throw 'not-unique nil))))
660 ((eq (car cont) 'multipart)
661 (mapc 'mml-compute-boundary-1 (cddr cont))))
664 (defun mml-make-boundary (number)
665 (concat (make-string (% number 60) ?=)
671 (defun mml-insert-mime-headers (cont type charset encoding flowed)
672 (let (parameters id disposition description)
674 (mml-parameter-string
675 cont mml-content-type-parameters))
679 (not (equal type mml-generate-default-type))
680 mml-insert-mime-headers-always)
681 (when (consp charset)
683 "Can't encode a part with several charsets"))
684 (insert "Content-Type: " type)
686 (mml-insert-parameter
687 (mail-header-encode-parameter "charset" (symbol-name charset))))
689 (mml-insert-parameter "format=flowed"))
691 (mml-insert-parameter-string
692 cont mml-content-type-parameters))
694 (when (setq id (cdr (assq 'id cont)))
695 (insert "Content-ID: " id "\n"))
697 (mml-parameter-string
698 cont mml-content-disposition-parameters))
699 (when (or (setq disposition (cdr (assq 'disposition cont)))
701 (insert "Content-Disposition: " (or disposition "inline"))
703 (mml-insert-parameter-string
704 cont mml-content-disposition-parameters))
706 (unless (eq encoding '7bit)
707 (insert (format "Content-Transfer-Encoding: %s\n" encoding)))
708 (when (setq description (cdr (assq 'description cont)))
709 (insert "Content-Description: ")
710 (setq description (prog1
712 (insert description "\n")))
713 (mail-encode-encoded-word-region description (point)))))
715 (defun mml-parameter-string (cont types)
718 (while (setq type (pop types))
719 (when (setq value (cdr (assq type cont)))
720 ;; Strip directory component from the filename parameter.
721 (when (eq type 'filename)
722 (setq value (file-name-nondirectory value)))
723 (setq string (concat string "; "
724 (mail-header-encode-parameter
725 (symbol-name type) value)))))
726 (when (not (zerop (length string)))
729 (defun mml-insert-parameter-string (cont types)
731 (while (setq type (pop types))
732 (when (setq value (cdr (assq type cont)))
733 ;; Strip directory component from the filename parameter.
734 (when (eq type 'filename)
735 (setq value (file-name-nondirectory value)))
736 (mml-insert-parameter
737 (mail-header-encode-parameter
738 (symbol-name type) value))))))
741 (defvar ange-ftp-name-format)
742 (defvar efs-path-regexp))
743 (defun mml-parse-file-name (path)
744 (if (if (boundp 'efs-path-regexp)
745 (string-match efs-path-regexp path)
746 (if (boundp 'ange-ftp-name-format)
747 (string-match (car ange-ftp-name-format) path)))
748 (list (match-string 1 path) (match-string 2 path)
749 (substring path (1+ (match-end 2))))
752 (defun mml-insert-buffer (buffer)
753 "Insert BUFFER at point and quote any MML markup."
755 (narrow-to-region (point) (point))
756 (insert-buffer-substring buffer)
757 (mml-quote-region (point-min) (point-max))
758 (goto-char (point-max))))
761 ;;; Transforming MIME to MML
764 (defun mime-to-mml (&optional handles)
765 "Translate the current buffer (which should be a message) into MML.
766 If HANDLES is non-nil, use it instead reparsing the buffer."
767 ;; First decode the head.
769 (message-narrow-to-head)
770 (let ((rfc2047-quote-decoded-words-containing-tspecials t))
771 (mail-decode-encoded-word-region (point-min) (point-max))))
773 (setq handles (mm-dissect-buffer t)))
774 (goto-char (point-min))
775 (search-forward "\n\n" nil t)
776 (delete-region (point) (point-max))
777 (if (stringp (car handles))
778 (mml-insert-mime handles)
779 (mml-insert-mime handles t))
780 (mm-destroy-parts handles)
782 (message-narrow-to-head)
783 ;; Remove them, they are confusing.
784 (message-remove-header "Content-Type")
785 (message-remove-header "MIME-Version")
786 (message-remove-header "Content-Disposition")
787 (message-remove-header "Content-Transfer-Encoding")))
789 (defun mml-to-mime ()
790 "Translate the current buffer from MML to MIME."
791 (message-encode-message-body)
793 (message-narrow-to-headers-or-head)
794 ;; Skip past any From_ headers.
795 (while (looking-at "From ")
797 (let ((mail-parse-charset message-default-charset))
798 (mail-encode-encoded-word-buffer))))
800 (defun mml-insert-mime (handle &optional no-markup)
801 (let (textp buffer mmlp)
802 ;; Determine type and stuff.
803 (unless (stringp (car handle))
804 (unless (setq textp (equal (mm-handle-media-supertype handle) "text"))
806 (set-buffer (setq buffer (mml-generate-new-buffer " *mml*")))
807 (mm-insert-part handle 'no-cache)
808 (if (setq mmlp (equal (mm-handle-media-type handle)
812 (mml-insert-mml-markup handle nil t t)
813 (unless (and no-markup