1 ;;; mml.el --- A package for parsing and validating MML documents
3 ;; Copyright (C) 1998-2015 Free Software Foundation, Inc.
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
6 ;; This file is part of GNU Emacs.
8 ;; GNU Emacs is free software: you can redistribute it and/or modify
9 ;; it under the terms of the GNU General Public License as published by
10 ;; the Free Software Foundation, either version 3 of the License, or
11 ;; (at your option) any later version.
13 ;; GNU Emacs is distributed in the hope that it will be useful,
14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 ;; GNU General Public License for more details.
18 ;; You should have received a copy of the GNU General Public License
19 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
30 (eval-when-compile (require 'cl))
31 (eval-when-compile (require 'url))
33 (when (featurep 'xemacs)
34 (require 'easy-mmode))) ; for `define-minor-mode'
36 (autoload 'message-make-message-id "message")
37 (declare-function gnus-setup-posting-charset "gnus-msg" (group))
38 (autoload 'gnus-make-local-hook "gnus-util")
39 (autoload 'gnus-completing-read "gnus-util")
40 (autoload 'message-fetch-field "message")
41 (autoload 'message-mark-active-p "message")
42 (autoload 'message-info "message")
43 (autoload 'fill-flowed-encode "flow-fill")
44 (autoload 'message-posting-charset "message")
45 (autoload 'dnd-get-local-file-name "dnd")
47 (autoload 'message-options-set "message")
48 (autoload 'message-narrow-to-head "message")
49 (autoload 'message-in-body-p "message")
50 (autoload 'message-mail-p "message")
52 (defvar gnus-article-mime-handles)
54 (defvar gnus-newsrc-hashtb)
55 (defvar message-default-charset)
56 (defvar message-deletable-headers)
57 (defvar message-options)
58 (defvar message-posting-charset)
59 (defvar message-required-mail-headers)
60 (defvar message-required-news-headers)
61 (defvar dnd-protocol-alist)
62 (defvar mml-dnd-protocol-alist)
64 (defcustom mml-content-type-parameters
65 '(name access-type expiration size permission format)
66 "*A list of acceptable parameters in MML tag.
67 These parameters are generated in Content-Type header if exists."
69 :type '(repeat (symbol :tag "Parameter"))
72 (defcustom mml-content-disposition-parameters
73 '(filename creation-date modification-date read-date)
74 "*A list of acceptable parameters in MML tag.
75 These parameters are generated in Content-Disposition header if exists."
77 :type '(repeat (symbol :tag "Parameter"))
80 (defcustom mml-content-disposition-alist
81 '((text (rtf . "attachment") (t . "inline"))
83 "Alist of MIME types or regexps matching file names and default dispositions.
84 Each element should be one of the following three forms:
86 (REGEXP . DISPOSITION)
87 (SUPERTYPE (SUBTYPE . DISPOSITION) (SUBTYPE . DISPOSITION)...)
90 Where REGEXP is a string which matches the file name (if any) of an
91 attachment, SUPERTYPE, SUBTYPE and TYPE should be symbols which are a
92 MIME supertype (e.g., text), a MIME subtype (e.g., plain) and a MIME
93 type (e.g., text/plain) respectively, and DISPOSITION should be either
94 the string \"attachment\" or the string \"inline\". The value t for
95 SUPERTYPE, SUBTYPE or TYPE matches any of those types. The first
96 match found will be used."
97 :version "23.1" ;; No Gnus
98 :type (let ((dispositions '(radio :format "DISPOSITION: %v"
100 (const :format "%v " "attachment")
101 (const :format "%v\n" "inline"))))
104 (choice :format "%[Value Menu%]%v"
105 (cons :tag "(REGEXP . DISPOSITION)" :extra-offset 4
106 (regexp :tag "REGEXP" :value ".*")
108 (cons :tag "(SUPERTYPE (SUBTYPE . DISPOSITION)...)"
110 (symbol :tag " SUPERTYPE" :value text)
111 (repeat :format "%v%i\n" :offset 0 :extra-offset 4
112 (cons :format "%v" :extra-offset 5
113 (symbol :tag "SUBTYPE" :value t)
115 (cons :tag "(TYPE . DISPOSITION)" :extra-offset 4
116 (symbol :tag "TYPE" :value t)
120 (defcustom mml-insert-mime-headers-always t
121 "If non-nil, always put Content-Type: text/plain at top of empty parts.
122 It is necessary to work against a bug in certain clients."
127 (defcustom mml-enable-flowed t
128 "If non-nil, enable format=flowed usage when encoding a message.
129 This is only performed when filling on text/plain with hard
130 newlines in the text."
135 (defvar mml-tweak-type-alist nil
136 "A list of (TYPE . FUNCTION) for tweaking MML parts.
137 TYPE is a string containing a regexp to match the MIME type. FUNCTION
138 is a Lisp function which is called with the MML handle to tweak the
139 part. This variable is used only when no TWEAK parameter exists in
142 (defvar mml-tweak-function-alist nil
143 "A list of (NAME . FUNCTION) for tweaking MML parts.
144 NAME is a string containing the name of the TWEAK parameter in the MML
145 handle. FUNCTION is a Lisp function which is called with the MML
146 handle to tweak the part.")
148 (defvar mml-tweak-sexp-alist
149 '((mml-externalize-attachments . mml-tweak-externalize-attachments))
150 "A list of (SEXP . FUNCTION) for tweaking MML parts.
151 SEXP is an s-expression. If the evaluation of SEXP is non-nil, FUNCTION
152 is called. FUNCTION is a Lisp function which is called with the MML
153 handle to tweak the part.")
155 (defvar mml-externalize-attachments nil
156 "*If non-nil, local-file attachments are generated as external parts.")
158 (defvar mml-generate-multipart-alist nil
159 "*Alist of multipart generation functions.
160 Each entry has the form (NAME . FUNCTION), where
161 NAME is a string containing the name of the part (without the
162 leading \"/multipart/\"),
163 FUNCTION is a Lisp function which is called to generate the part.
165 The Lisp function has to supply the appropriate MIME headers and the
166 contents of this part.")
168 (defvar mml-syntax-table
169 (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table)))
170 (modify-syntax-entry ?\\ "/" table)
171 (modify-syntax-entry ?< "(" table)
172 (modify-syntax-entry ?> ")" table)
173 (modify-syntax-entry ?@ "w" table)
174 (modify-syntax-entry ?/ "w" table)
175 (modify-syntax-entry ?= " " table)
176 (modify-syntax-entry ?* " " table)
177 (modify-syntax-entry ?\; " " table)
178 (modify-syntax-entry ?\' " " table)
181 (defvar mml-boundary-function 'mml-make-boundary
182 "A function called to suggest a boundary.
183 The function may be called several times, and should try to make a new
184 suggestion each time. The function is called with one parameter,
185 which is a number that says how many times the function has been
186 called for this message.")
188 (defvar mml-confirmation-set nil
189 "A list of symbols, each of which disables some warning.
190 `unknown-encoding': always send messages contain characters with
191 unknown encoding; `use-ascii': always use ASCII for those characters
192 with unknown encoding; `multipart': always send messages with more than
195 (defvar mml-generate-default-type "text/plain"
196 "Content type by which the Content-Type header can be omitted.
197 The Content-Type header will not be put in the MIME part if the type
198 equals the value and there's no parameter (e.g. charset, format, etc.)
199 and `mml-insert-mime-headers-always' is nil. The value will be bound
200 to \"message/rfc822\" when encoding an article to be forwarded as a MIME
201 part. This is for the internal use, you should never modify the value.")
203 (defvar mml-buffer-list nil)
205 (defun mml-generate-new-buffer (name)
206 (let ((buf (generate-new-buffer name)))
207 (push buf mml-buffer-list)
210 (defun mml-destroy-buffers ()
211 (let (kill-buffer-hook)
212 (mapc 'kill-buffer mml-buffer-list)
213 (setq mml-buffer-list nil)))
216 "Parse the current buffer as an MML document."
218 (goto-char (point-min))
219 (with-syntax-table mml-syntax-table
222 (defun mml-parse-1 ()
223 "Parse the current buffer as an MML document."
224 (let (struct tag point contents charsets warn use-ascii no-markup-p raw)
225 (while (and (not (eobp))
226 (not (looking-at "<#/multipart")))
228 ((looking-at "<#secure")
229 ;; The secure part is essentially a meta-meta tag, which
230 ;; expands to either a part tag if there are no other parts in
231 ;; the document or a multipart tag if there are other parts
232 ;; included in the message
234 (taginfo (mml-read-tag))
235 (keyfile (cdr (assq 'keyfile taginfo)))
236 (certfiles (delq nil (mapcar (lambda (tag)
237 (if (eq (car-safe tag) 'certfile)
240 (recipients (cdr (assq 'recipients taginfo)))
241 (sender (cdr (assq 'sender taginfo)))
242 (location (cdr (assq 'tag-location taginfo)))
243 (mode (cdr (assq 'mode taginfo)))
244 (method (cdr (assq 'method taginfo)))
247 (if (re-search-forward
248 "<#/?\\(multipart\\|part\\|external\\|mml\\)." nil t)
249 (setq secure-mode "multipart")
250 (setq secure-mode "part")))
253 (re-search-forward "<#secure[^\n]*>\n"))
254 (delete-region (match-beginning 0) (match-end 0))
255 (cond ((string= mode "sign")
256 (setq tags (list "sign" method)))
257 ((string= mode "encrypt")
258 (setq tags (list "encrypt" method)))
259 ((string= mode "signencrypt")
260 (setq tags (list "sign" method "encrypt" method)))
262 (error "Unknown secure mode %s" mode)))
263 (eval `(mml-insert-tag ,secure-mode
265 ,(if keyfile "keyfile")
268 (mapcar (lambda (certfile)
269 (list "certfile" certfile))
271 ,(if recipients "recipients")
273 ,(if sender "sender")
276 (goto-char location)))
277 ((looking-at "<#multipart")
278 (push (nconc (mml-read-tag) (mml-parse-1)) struct))
279 ((looking-at "<#external")
280 (push (nconc (mml-read-tag) (list (cons 'contents (mml-read-part))))
283 (if (or (looking-at "<#part") (looking-at "<#mml"))
284 (setq tag (mml-read-tag)
287 (setq tag (list 'part '(type . "text/plain"))
290 (setq raw (cdr (assq 'raw tag))
292 contents (mml-read-part (eq 'mml (car tag)))
297 (intern (downcase (cdr (assq 'charset tag))))))
299 (mm-find-mime-charset-region point (point)
301 (when (and (not raw) (memq nil charsets))
302 (if (or (memq 'unknown-encoding mml-confirmation-set)
303 (message-options-get 'unknown-encoding)
305 Message contains characters with unknown encoding. Really send? ")
306 (message-options-set 'unknown-encoding t)))
308 (or (memq 'use-ascii mml-confirmation-set)
309 (message-options-get 'use-ascii)
310 (and (y-or-n-p "Use ASCII as charset? ")
311 (message-options-set 'use-ascii t))))
312 (setq charsets (delq nil charsets))
314 (error "Edit your message to remove those characters")))
317 (< (length charsets) 2))
318 (if (or (not no-markup-p)
319 (string-match "[^ \t\r\n]" contents))
320 ;; Don't create blank parts.
321 (push (nconc tag (list (cons 'contents contents)))
323 (let ((nstruct (mml-parse-singlepart-with-multiple-charsets
324 tag point (point) use-ascii)))
326 (not (memq 'multipart mml-confirmation-set))
327 (not (message-options-get 'multipart))
328 (not (and (y-or-n-p (format "\
329 A message part needs to be split into %d charset parts. Really send? "
331 (message-options-set 'multipart t))))
332 (error "Edit your message to use only one charset"))
333 (setq struct (nconc nstruct struct)))))))
338 (defun mml-parse-singlepart-with-multiple-charsets
339 (orig-tag beg end &optional use-ascii)
342 (narrow-to-region beg end)
343 (goto-char (point-min))
344 (let ((current (or (mm-mime-charset (mm-charset-after))
345 (and use-ascii 'us-ascii)))
346 charset struct space newline paragraph)
348 (setq charset (mm-mime-charset (mm-charset-after)))
350 ;; The charset remains the same.
351 ((eq charset 'us-ascii))
352 ((or (and use-ascii (not charset))
353 (eq charset current))
357 ;; The initial charset was ascii.
358 ((eq current 'us-ascii)
359 (setq current charset
363 ;; We have a change in charsets.
367 (list (cons 'contents
368 (buffer-substring-no-properties
369 beg (or paragraph newline space (point))))))
371 (setq beg (or paragraph newline space (point))
376 ;; Compute places where it might be nice to break the part.
378 ((memq (following-char) '(? ?\t))
379 (setq space (1+ (point))))
380 ((and (eq (following-char) ?\n)
382 (eq (char-after (1- (point))) ?\n))
383 (setq paragraph (point)))
384 ((eq (following-char) ?\n)
385 (setq newline (1+ (point)))))
387 ;; Do the final part.
388 (unless (= beg (point))
389 (push (append orig-tag
390 (list (cons 'contents
391 (buffer-substring-no-properties
396 (defun mml-read-tag ()
397 "Read a tag and return the contents."
398 (let ((orig-point (point))
399 contents name elem val)
401 (setq name (buffer-substring-no-properties
402 (point) (progn (forward-sexp 1) (point))))
403 (skip-chars-forward " \t\n")
404 (while (not (looking-at ">[ \t]*\n?"))
405 (setq elem (buffer-substring-no-properties
406 (point) (progn (forward-sexp 1) (point))))
407 (skip-chars-forward "= \t\n")
408 (setq val (buffer-substring-no-properties
409 (point) (progn (forward-sexp 1) (point))))
410 (when (string-match "\\`\"" val)
411 (setq val (read val))) ;; inverse of prin1 in mml-insert-tag
412 (push (cons (intern elem) val) contents)
413 (skip-chars-forward " \t\n"))
414 (goto-char (match-end 0))
415 ;; Don't skip the leading space.
416 ;;(skip-chars-forward " \t\n")
417 ;; Put the tag location into the returned contents
418 (setq contents (append (list (cons 'tag-location orig-point)) contents))
419 (cons (intern name) (nreverse contents))))
421 (defun mml-buffer-substring-no-properties-except-hard-newlines (start end)
422 (let ((str (buffer-substring-no-properties start end))
423 (bufstart start) tmp)
424 (while (setq tmp (text-property-any start end 'hard 't))
425 (set-text-properties (- tmp bufstart) (- tmp bufstart -1)
427 (setq start (1+ tmp)))
430 (defun mml-read-part (&optional mml)
431 "Return the buffer up till the next part, multipart or closing part or multipart.
432 If MML is non-nil, return the buffer up till the correspondent mml tag."
433 (let ((beg (point)) (count 1))
434 ;; If the tag ended at the end of the line, we go to the next line.
435 (when (looking-at "[ \t]*\n")
439 (while (and (> count 0) (not (eobp)))
440 (if (re-search-forward "<#\\(/\\)?mml." nil t)
441 (setq count (+ count (if (match-beginning 1) -1 1)))
442 (goto-char (point-max))))
443 (mml-buffer-substring-no-properties-except-hard-newlines
446 (match-beginning 0))))
447 (if (re-search-forward
448 "<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)." nil t)
450 (mml-buffer-substring-no-properties-except-hard-newlines
451 beg (match-beginning 0))
452 (if (or (not (match-beginning 1))
453 (equal (match-string 2) "multipart"))
454 (goto-char (match-beginning 0))
455 (when (looking-at "[ \t]*\n")
457 (mml-buffer-substring-no-properties-except-hard-newlines
458 beg (goto-char (point-max)))))))
460 (defvar mml-boundary nil)
461 (defvar mml-base-boundary "-=-=")
462 (defvar mml-multipart-number 0)
463 (defvar mml-inhibit-compute-boundary nil)
465 (declare-function libxml-parse-html-region "xml.c"
466 (start end &optional base-url))
468 (defun mml-generate-mime (&optional multipart-type)
469 "Generate a MIME message based on the current MML document.
470 MULTIPART-TYPE defaults to \"mixed\", but can also
471 be \"related\" or \"alternate\"."
472 (let ((cont (mml-parse))
473 (mml-multipart-number mml-multipart-number)
474 (options message-options))
477 (when (and (consp (car cont))
479 (fboundp 'libxml-parse-html-region)
480 (equal (cdr (assq 'type (car cont))) "text/html"))
481 (setq cont (mml-expand-html-into-multipart-related (car cont))))
483 (mm-with-multibyte-buffer
484 (setq message-options options)
486 ((and (consp (car cont))
488 (mml-generate-mime-1 (car cont)))
489 ((eq (car cont) 'multipart)
490 (mml-generate-mime-1 cont))
493 (nconc (list 'multipart (cons 'type (or multipart-type "mixed")))
495 (setq options message-options)
497 (setq message-options options)))))
499 (defun mml-expand-html-into-multipart-related (cont)
500 (let ((new-parts nil)
502 (mm-with-multibyte-buffer
503 (insert (cdr (assq 'contents cont)))
504 (goto-char (point-min))
505 (with-syntax-table mml-syntax-table
506 (while (re-search-forward "<img\\b" nil t)
507 (goto-char (match-beginning 0))
508 (let* ((start (point))
511 (libxml-parse-html-region
512 (point) (progn (forward-sexp) (point))))))
514 (parsed (url-generic-parse-url (cdr (assq 'src (cadr img))))))
515 (when (and (null (url-type parsed))
516 (url-filename parsed)
517 (file-exists-p (url-filename parsed)))
519 (when (search-forward (url-filename parsed) end t)
520 (let ((cid (format "fsf.%d" cid)))
521 (replace-match (concat "cid:" cid) t t)
522 (push (list cid (url-filename parsed)) new-parts))
523 (setq cid (1+ cid)))))))
524 ;; We have local images that we want to include.
527 (setcdr (assq 'contents cont) (buffer-string))
529 (nconc (list 'multipart (cons 'type "related"))
531 (dolist (new-part (nreverse new-parts))
534 (list `(part (type . "image/png")
535 (filename . ,(nth 1 new-part))
536 (id . ,(concat "<" (nth 0 new-part)
540 (defun mml-generate-mime-1 (cont)
541 (let ((mm-use-ultra-safe-encoding
542 (or mm-use-ultra-safe-encoding (assq 'sign cont))))
544 (narrow-to-region (point) (point))
545 (mml-tweak-part cont)
547 ((or (eq (car cont) 'part) (eq (car cont) 'mml))
548 (let* ((raw (cdr (assq 'raw cont)))
549 (filename (cdr (assq 'filename cont)))
550 (type (or (cdr (assq 'type cont))
552 (or (mm-default-file-encoding filename)
553 "application/octet-stream")
555 (charset (cdr (assq 'charset cont)))
556 (coding (mm-charset-to-coding-system charset))
557 encoding flowed coded)
558 (cond ((eq coding 'ascii)
562 ;; The value of `charset' might be a bogus alias that
563 ;; `mm-charset-synonym-alist' provides, like `utf8',
564 ;; so we prefer the MIME charset that Emacs knows for
565 ;; the coding system `coding'.
566 (setq charset (or (mm-coding-system-to-mime-charset coding)
567 (intern (downcase charset))))))
569 (member (car (split-string type "/")) '("text" "message")))
573 ((cdr (assq 'buffer cont))
574 (insert-buffer-substring (cdr (assq 'buffer cont))))
576 (not (equal (cdr (assq 'nofile cont)) "yes")))
577 (let ((coding-system-for-read coding))
578 (mm-insert-file-contents filename)))
579 ((eq 'mml (car cont))
580 (insert (cdr (assq 'contents cont))))
583 (narrow-to-region (point) (point))
584 (insert (cdr (assq 'contents cont)))
585 ;; Remove quotes from quoted tags.
586 (goto-char (point-min))
587 (while (re-search-forward
588 "<#!+/?\\(part\\|multipart\\|external\\|mml\\|secure\\)"
590 (delete-region (+ (match-beginning 0) 2)
591 (+ (match-beginning 0) 3))))))
593 ((eq (car cont) 'mml)
594 (let ((mml-boundary (mml-compute-boundary cont))
595 ;; It is necessary for the case where this
596 ;; function is called recursively since
597 ;; `m-g-d-t' will be bound to "message/rfc822"
598 ;; when encoding an article to be forwarded.
599 (mml-generate-default-type "text/plain"))
601 ;; Update handle so mml-compute-boundary can
602 ;; detect collisions with the nested parts.
603 (unless mml-inhibit-compute-boundary
604 (setcdr (assoc 'contents cont) (buffer-string))))
605 (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b")))
606 ;; ignore 0x1b, it is part of iso-2022-jp
607 (setq encoding (mm-body-7-or-8))))
608 ((string= (car (split-string type "/")) "message")
609 (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b")))
610 ;; ignore 0x1b, it is part of iso-2022-jp
611 (setq encoding (mm-body-7-or-8))))
613 ;; Only perform format=flowed filling on text/plain
614 ;; parts where there either isn't a format parameter
615 ;; in the mml tag or it says "flowed" and there
616 ;; actually are hard newlines in the text.
617 (let (use-hard-newlines)
618 (when (and mml-enable-flowed
619 (string= type "text/plain")
620 (not (string= (cdr (assq 'sign cont)) "pgp"))
621 (or (null (assq 'format cont))
622 (string= (cdr (assq 'format cont))
624 (setq use-hard-newlines
626 (point-min) (point-max) 'hard 't)))
628 ;; Indicate that `mml-insert-mime-headers' should
629 ;; insert a "; format=flowed" string unless the
630 ;; user has already specified it.
631 (setq flowed (null (assq 'format cont)))))
632 ;; Prefer `utf-8' for text/calendar parts.
634 (not (string= type "text/calendar")))
635 (setq charset (mm-encode-body charset))
636 (let ((mm-coding-system-priorities
637 (cons 'utf-8 mm-coding-system-priorities)))
638 (setq charset (mm-encode-body))))
639 (setq encoding (mm-body-encoding
640 charset (cdr (assq 'encoding cont))))))
641 (setq coded (buffer-string)))
642 (mml-insert-mime-headers cont type charset encoding flowed)
645 (mm-with-unibyte-buffer
647 ((cdr (assq 'buffer cont))
648 (insert (mm-string-as-unibyte
649 (with-current-buffer (cdr (assq 'buffer cont))
652 (not (equal (cdr (assq 'nofile cont)) "yes")))
653 (let ((coding-system-for-read mm-binary-coding-system))
654 (mm-insert-file-contents filename nil nil nil nil t))
656 (setq charset (mm-coding-system-to-mime-charset
657 (mm-find-buffer-file-coding-system
660 (let ((contents (cdr (assq 'contents cont))))
661 (if (if (featurep 'xemacs)
662 (string-match "[^\000-\377]" contents)
663 (mm-multibyte-string-p contents))
665 (mm-enable-multibyte)
668 (setq charset (mm-encode-body charset))))
669 (insert contents)))))
670 (if (setq encoding (cdr (assq 'encoding cont)))
671 (setq encoding (intern (downcase encoding))))
672 (setq encoding (mm-encode-buffer type encoding)
673 coded (mm-string-as-multibyte (buffer-string))))
674 (mml-insert-mime-headers cont type charset encoding nil)
675 (insert "\n" coded))))
676 ((eq (car cont) 'external)
677 (insert "Content-Type: message/external-body")
678 (let ((parameters (mml-parameter-string
679 cont '(expiration size permission)))
680 (name (cdr (assq 'name cont)))
681 (url (cdr (assq 'url cont))))
683 (setq name (mml-parse-file-name name))
685 (mml-insert-parameter
686 (mail-header-encode-parameter "name" name)
687 "access-type=local-file")
688 (mml-insert-parameter
689 (mail-header-encode-parameter
690 "name" (file-name-nondirectory (nth 2 name)))
691 (mail-header-encode-parameter "site" (nth 1 name))
692 (mail-header-encode-parameter
693 "directory" (file-name-directory (nth 2 name))))
694 (mml-insert-parameter
695 (concat "access-type="
696 (if (member (nth 0 name) '("ftp@" "anonymous@"))
700 (mml-insert-parameter
701 (mail-header-encode-parameter "url" url)
704 (mml-insert-parameter-string
705 cont '(expiration size permission)))
707 (insert "Content-Type: "
708 (or (cdr (assq 'type cont))
710 (or (mm-default-file-encoding name)
711 "application/octet-stream")
714 (insert "Content-ID: " (message-make-message-id) "\n")
715 (insert "Content-Transfer-Encoding: "
716 (or (cdr (assq 'encoding cont)) "binary"))
718 (insert (or (cdr (assq 'contents cont))))
720 ((eq (car cont) 'multipart)
721 (let* ((type (or (cdr (assq 'type cont)) "mixed"))
722 (mml-generate-default-type (if (equal type "digest")
725 (handler (assoc type mml-generate-multipart-alist)))
727 (funcall (cdr handler) cont)
728 ;; No specific handler. Use default one.
729 (let ((mml-boundary (mml-compute-boundary cont)))
730 (insert (format "Content-Type: multipart/%s; boundary=\"%s\""
732 (if (cdr (assq 'start cont))
733 (format "; start=\"%s\"\n" (cdr (assq 'start cont)))
735 (let ((cont cont) part)
736 (while (setq part (pop cont))
737 ;; Skip `multipart' and attributes.
738 (when (and (consp part) (consp (cdr part)))
739 (insert "\n--" mml-boundary "\n")
740 (mml-generate-mime-1 part)
741 (goto-char (point-max)))))
742 (insert "\n--" mml-boundary "--\n")))))
744 (error "Invalid element: %S" cont)))
745 ;; handle sign & encrypt tags in a semi-smart way.
746 (let ((sign-item (assoc (cdr (assq 'sign cont)) mml-sign-alist))
747 (encrypt-item (assoc (cdr (assq 'encrypt cont))
750 (when (or sign-item encrypt-item)
751 (when (setq sender (cdr (assq 'sender cont)))
752 (message-options-set 'mml-sender sender)
753 (message-options-set 'message-sender sender))
754 (if (setq recipients (cdr (assq 'recipients cont)))
755 (message-options-set 'message-recipients recipients))
756 (let ((style (mml-signencrypt-style
757 (first (or sign-item encrypt-item)))))
758 ;; check if: we're both signing & encrypting, both methods
759 ;; are the same (why would they be different?!), and that
760 ;; the signencrypt style allows for combined operation.
761 (if (and sign-item encrypt-item (equal (first sign-item)
762 (first encrypt-item))
763 (equal style 'combined))
764 (funcall (nth 1 encrypt-item) cont t)
765 ;; otherwise, revert to the old behavior.
767 (funcall (nth 1 sign-item) cont))
769 (funcall (nth 1 encrypt-item) cont)))))))))
771 (defun mml-compute-boundary (cont)
772 "Return a unique boundary that does not exist in CONT."
773 (let ((mml-boundary (funcall mml-boundary-function
774 (incf mml-multipart-number))))
775 (unless mml-inhibit-compute-boundary
776 ;; This function tries again and again until it has found
777 ;; a unique boundary.
778 (while (not (catch 'not-unique
779 (mml-compute-boundary-1 cont)))))
782 (defun mml-compute-boundary-1 (cont)
784 ((member (car cont) '(part mml))
785 (mm-with-multibyte-buffer
786 (let ((mml-inhibit-compute-boundary t)
787 (mml-multipart-number 0)
788 mml-sign-alist mml-encrypt-alist)
789 (mml-generate-mime-1 cont))
790 (goto-char (point-min))
791 (when (re-search-forward (concat "^--" (regexp-quote mml-boundary))
793 (setq mml-boundary (funcall mml-boundary-function
794 (incf mml-multipart-number)))
795 (throw 'not-unique nil))))
796 ((eq (car cont) 'multipart)
797 (mapc 'mml-compute-boundary-1 (cddr cont))))
800 (defun mml-make-boundary (number)
801 (concat (make-string (% number 60) ?=)
807 (defun mml-content-disposition (type &optional filename)
808 "Return a default disposition name suitable to TYPE or FILENAME."
809 (let ((defs mml-content-disposition-alist)
810 disposition def types)
811 (while (and (not disposition) defs)
812 (setq def (pop defs))
813 (cond ((stringp (car def))
815 (string-match (car def) filename))
816 (setq disposition (cdr def))))
818 (when (string= (car (setq types (split-string type "/")))
820 (setq type (cadr types)
822 (while (and (not disposition) types)
823 (setq def (pop types))
824 (when (or (eq (car def) t) (string= type (car def)))
825 (setq disposition (cdr def))))))
827 (when (or (eq (car def) t) (string= type (car def)))
828 (setq disposition (cdr def))))))
829 (or disposition "attachment")))
831 (defun mml-insert-mime-headers (cont type charset encoding flowed)
832 (let (parameters id disposition description)
834 (mml-parameter-string
835 cont mml-content-type-parameters))
839 (not (equal type mml-generate-default-type))
840 mml-insert-mime-headers-always)
841 (when (consp charset)
843 "Can't encode a part with several charsets"))
844 (insert "Content-Type: " type)
846 (mml-insert-parameter
847 (mail-header-encode-parameter "charset" (symbol-name charset))))
849 (mml-insert-parameter "format=flowed"))
851 (mml-insert-parameter-string
852 cont mml-content-type-parameters))
854 (when (setq id (cdr (assq 'id cont)))
855 (insert "Content-ID: " id "\n"))
857 (mml-parameter-string
858 cont mml-content-disposition-parameters))
859 (when (or (setq disposition (cdr (assq 'disposition cont)))
861 (insert "Content-Disposition: "
863 (mml-content-disposition type (cdr (assq 'filename cont)))))
865 (mml-insert-parameter-string
866 cont mml-content-disposition-parameters))
868 (unless (eq encoding '7bit)
869 (insert (format "Content-Transfer-Encoding: %s\n" encoding)))
870 (when (setq description (cdr (assq 'description cont)))
871 (insert "Content-Description: ")
872 (setq description (prog1
874 (insert description "\n")))
875 (mail-encode-encoded-word-region description (point)))))
877 (defun mml-parameter-string (cont types)
880 (while (setq type (pop types))
881 (when (setq value (cdr (assq type cont)))
882 ;; Strip directory component from the filename parameter.
883 (when (eq type 'filename)
884 (setq value (file-name-nondirectory value)))
885 (setq string (concat string "; "
886 (mail-header-encode-parameter
887 (symbol-name type) value)))))
888 (when (not (zerop (length string)))
891 (defun mml-insert-parameter-string (cont types)
893 (while (setq type (pop types))
894 (when (setq value (cdr (assq type cont)))
895 ;; Strip directory component from the filename parameter.
896 (when (eq type 'filename)
897 (setq value (file-name-nondirectory value)))
898 (mml-insert-parameter
899 (mail-header-encode-parameter
900 (symbol-name type) value))))))
902 (defvar ange-ftp-name-format)
903 (defvar efs-path-regexp)
905 (defun mml-parse-file-name (path)
906 (if (if (boundp 'efs-path-regexp)
907 (string-match efs-path-regexp path)
908 (if (boundp 'ange-ftp-name-format)
909 (string-match (car ange-ftp-name-format) path)))
910 (list (match-string 1 path) (match-string 2 path)
911 (substring path (1+ (match-end 2))))
914 (defun mml-insert-buffer (buffer)
915 "Insert BUFFER at point and quote any MML markup."
917 (narrow-to-region (point) (point))
918 (insert-buffer-substring buffer)
919 (mml-quote-region (point-min) (point-max))
920 (goto-char (point-max))))
923 ;;; Transforming MIME to MML
926 ;; message-narrow-to-head autoloads message.
927 (declare-function message-remove-header "message"
928 (header &optional is-regexp first reverse))
930 (defun mime-to-mml (&optional handles)
931 "Translate the current buffer (which should be a message) into MML.
932 If HANDLES is non-nil, use it instead reparsing the buffer."
933 ;; First decode the head.
935 (message-narrow-to-head)
936 (let ((rfc2047-quote-decoded-words-containing-tspecials t))
937 (mail-decode-encoded-word-region (point-min) (point-max))))
939 (setq handles (mm-dissect-buffer t)))
940 (goto-char (point-min))
941 (search-forward "\n\n" nil t)
942 (delete-region (point) (point-max))
943 (if (stringp (car handles))
944 (mml-insert-mime handles)
945 (mml-insert-mime handles t))
946 (mm-destroy-parts handles)
948 (message-narrow-to-head)
949 ;; Remove them, they are confusing.
950 (message-remove-header "Content-Type")
951 (message-remove-header "MIME-Version")
952 (message-remove-header "Content-Disposition")
953 (message-remove-header "Content-Transfer-Encoding")))
955 (autoload 'message-encode-message-body "message")
956 (declare-function message-narrow-to-headers-or-head "message" ())
959 (defun mml-to-mime ()
960 "Translate the current buffer from MML to MIME."
961 ;; `message-encode-message-body' will insert an encoded Content-Description
962 ;; header in the message header if the body contains a single part
963 ;; that is specified by a user with a MML tag cont