1 ;;; mml.el --- A package for parsing and validating MML documents
3 ;; Copyright (C) 1998-2012 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/>.
25 ;; For Emacs <22.2 and XEmacs.
27 (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
34 (eval-when-compile (require 'cl))
36 (when (featurep 'xemacs)
37 (require 'easy-mmode))) ; for `define-minor-mode'
39 (autoload 'message-make-message-id "message")
40 (declare-function gnus-setup-posting-charset "gnus-msg" (group))
41 (autoload 'gnus-make-local-hook "gnus-util")
42 (autoload 'gnus-completing-read "gnus-util")
43 (autoload 'message-fetch-field "message")
44 (autoload 'message-mark-active-p "message")
45 (autoload 'message-info "message")
46 (autoload 'fill-flowed-encode "flow-fill")
47 (autoload 'message-posting-charset "message")
48 (autoload 'dnd-get-local-file-name "dnd")
50 (autoload 'message-options-set "message")
51 (autoload 'message-narrow-to-head "message")
52 (autoload 'message-in-body-p "message")
53 (autoload 'message-mail-p "message")
55 (defvar gnus-article-mime-handles)
57 (defvar gnus-newsrc-hashtb)
58 (defvar message-default-charset)
59 (defvar message-deletable-headers)
60 (defvar message-options)
61 (defvar message-posting-charset)
62 (defvar message-required-mail-headers)
63 (defvar message-required-news-headers)
64 (defvar dnd-protocol-alist)
65 (defvar mml-dnd-protocol-alist)
67 (defcustom mml-content-type-parameters
68 '(name access-type expiration size permission format)
69 "*A list of acceptable parameters in MML tag.
70 These parameters are generated in Content-Type header if exists."
72 :type '(repeat (symbol :tag "Parameter"))
75 (defcustom mml-content-disposition-parameters
76 '(filename creation-date modification-date read-date)
77 "*A list of acceptable parameters in MML tag.
78 These parameters are generated in Content-Disposition header if exists."
80 :type '(repeat (symbol :tag "Parameter"))
83 (defcustom mml-content-disposition-alist
84 '((text (rtf . "attachment") (t . "inline"))
86 "Alist of MIME types or regexps matching file names and default dispositions.
87 Each element should be one of the following three forms:
89 (REGEXP . DISPOSITION)
90 (SUPERTYPE (SUBTYPE . DISPOSITION) (SUBTYPE . DISPOSITION)...)
93 Where REGEXP is a string which matches the file name (if any) of an
94 attachment, SUPERTYPE, SUBTYPE and TYPE should be symbols which are a
95 MIME supertype (e.g., text), a MIME subtype (e.g., plain) and a MIME
96 type (e.g., text/plain) respectively, and DISPOSITION should be either
97 the string \"attachment\" or the string \"inline\". The value t for
98 SUPERTYPE, SUBTYPE or TYPE matches any of those types. The first
99 match found will be used."
100 :version "23.1" ;; No Gnus
101 :type (let ((dispositions '(radio :format "DISPOSITION: %v"
103 (const :format "%v " "attachment")
104 (const :format "%v\n" "inline"))))
107 (choice :format "%[Value Menu%]%v"
108 (cons :tag "(REGEXP . DISPOSITION)" :extra-offset 4
109 (regexp :tag "REGEXP" :value ".*")
111 (cons :tag "(SUPERTYPE (SUBTYPE . DISPOSITION)...)"
113 (symbol :tag " SUPERTYPE" :value text)
114 (repeat :format "%v%i\n" :offset 0 :extra-offset 4
115 (cons :format "%v" :extra-offset 5
116 (symbol :tag "SUBTYPE" :value t)
118 (cons :tag "(TYPE . DISPOSITION)" :extra-offset 4
119 (symbol :tag "TYPE" :value t)
123 (defcustom mml-insert-mime-headers-always t
124 "If non-nil, always put Content-Type: text/plain at top of empty parts.
125 It is necessary to work against a bug in certain clients."
130 (defcustom mml-enable-flowed t
131 "If non-nil, enable format=flowed usage when encoding a message.
132 This is only performed when filling on text/plain with hard
133 newlines in the text."
138 (defvar mml-tweak-type-alist nil
139 "A list of (TYPE . FUNCTION) for tweaking MML parts.
140 TYPE is a string containing a regexp to match the MIME type. FUNCTION
141 is a Lisp function which is called with the MML handle to tweak the
142 part. This variable is used only when no TWEAK parameter exists in
145 (defvar mml-tweak-function-alist nil
146 "A list of (NAME . FUNCTION) for tweaking MML parts.
147 NAME is a string containing the name of the TWEAK parameter in the MML
148 handle. FUNCTION is a Lisp function which is called with the MML
149 handle to tweak the part.")
151 (defvar mml-tweak-sexp-alist
152 '((mml-externalize-attachments . mml-tweak-externalize-attachments))
153 "A list of (SEXP . FUNCTION) for tweaking MML parts.
154 SEXP is an s-expression. If the evaluation of SEXP is non-nil, FUNCTION
155 is called. FUNCTION is a Lisp function which is called with the MML
156 handle to tweak the part.")
158 (defvar mml-externalize-attachments nil
159 "*If non-nil, local-file attachments are generated as external parts.")
161 (defvar mml-generate-multipart-alist nil
162 "*Alist of multipart generation functions.
163 Each entry has the form (NAME . FUNCTION), where
164 NAME is a string containing the name of the part (without the
165 leading \"/multipart/\"),
166 FUNCTION is a Lisp function which is called to generate the part.
168 The Lisp function has to supply the appropriate MIME headers and the
169 contents of this part.")
171 (defvar mml-syntax-table
172 (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table)))
173 (modify-syntax-entry ?\\ "/" table)
174 (modify-syntax-entry ?< "(" table)
175 (modify-syntax-entry ?> ")" table)
176 (modify-syntax-entry ?@ "w" table)
177 (modify-syntax-entry ?/ "w" table)
178 (modify-syntax-entry ?= " " table)
179 (modify-syntax-entry ?* " " table)
180 (modify-syntax-entry ?\; " " table)
181 (modify-syntax-entry ?\' " " table)
184 (defvar mml-boundary-function 'mml-make-boundary
185 "A function called to suggest a boundary.
186 The function may be called several times, and should try to make a new
187 suggestion each time. The function is called with one parameter,
188 which is a number that says how many times the function has been
189 called for this message.")
191 (defvar mml-confirmation-set nil
192 "A list of symbols, each of which disables some warning.
193 `unknown-encoding': always send messages contain characters with
194 unknown encoding; `use-ascii': always use ASCII for those characters
195 with unknown encoding; `multipart': always send messages with more than
198 (defvar mml-generate-default-type "text/plain"
199 "Content type by which the Content-Type header can be omitted.
200 The Content-Type header will not be put in the MIME part if the type
201 equals the value and there's no parameter (e.g. charset, format, etc.)
202 and `mml-insert-mime-headers-always' is nil. The value will be bound
203 to \"message/rfc822\" when encoding an article to be forwarded as a MIME
204 part. This is for the internal use, you should never modify the value.")
206 (defvar mml-buffer-list nil)
208 (defun mml-generate-new-buffer (name)
209 (let ((buf (generate-new-buffer name)))
210 (push buf mml-buffer-list)
213 (defun mml-destroy-buffers ()
214 (let (kill-buffer-hook)
215 (mapc 'kill-buffer mml-buffer-list)
216 (setq mml-buffer-list nil)))
219 "Parse the current buffer as an MML document."
221 (goto-char (point-min))
222 (with-syntax-table mml-syntax-table
225 (defun mml-parse-1 ()
226 "Parse the current buffer as an MML document."
227 (let (struct tag point contents charsets warn use-ascii no-markup-p raw)
228 (while (and (not (eobp))
229 (not (looking-at "<#/multipart")))
231 ((looking-at "<#secure")
232 ;; The secure part is essentially a meta-meta tag, which
233 ;; expands to either a part tag if there are no other parts in
234 ;; the document or a multipart tag if there are other parts
235 ;; included in the message
237 (taginfo (mml-read-tag))
238 (keyfile (cdr (assq 'keyfile taginfo)))
239 (certfiles (delq nil (mapcar (lambda (tag)
240 (if (eq (car-safe tag) 'certfile)
243 (recipients (cdr (assq 'recipients taginfo)))
244 (sender (cdr (assq 'sender taginfo)))
245 (location (cdr (assq 'tag-location taginfo)))
246 (mode (cdr (assq 'mode taginfo)))
247 (method (cdr (assq 'method taginfo)))
250 (if (re-search-forward
251 "<#/?\\(multipart\\|part\\|external\\|mml\\)." nil t)
252 (setq secure-mode "multipart")
253 (setq secure-mode "part")))
256 (re-search-forward "<#secure[^\n]*>\n"))
257 (delete-region (match-beginning 0) (match-end 0))
258 (cond ((string= mode "sign")
259 (setq tags (list "sign" method)))
260 ((string= mode "encrypt")
261 (setq tags (list "encrypt" method)))
262 ((string= mode "signencrypt")
263 (setq tags (list "sign" method "encrypt" method))))
264 (eval `(mml-insert-tag ,secure-mode
266 ,(if keyfile "keyfile")
269 (mapcar (lambda (certfile)
270 (list "certfile" certfile))
272 ,(if recipients "recipients")
274 ,(if sender "sender")
277 (goto-char location)))
278 ((looking-at "<#multipart")
279 (push (nconc (mml-read-tag) (mml-parse-1)) struct))
280 ((looking-at "<#external")
281 (push (nconc (mml-read-tag) (list (cons 'contents (mml-read-part))))
284 (if (or (looking-at "<#part") (looking-at "<#mml"))
285 (setq tag (mml-read-tag)
288 (setq tag (list 'part '(type . "text/plain"))
291 (setq raw (cdr (assq 'raw tag))
293 contents (mml-read-part (eq 'mml (car tag)))
298 (intern (downcase (cdr (assq 'charset tag))))))
300 (mm-find-mime-charset-region point (point)
302 (when (and (not raw) (memq nil charsets))
303 (if (or (memq 'unknown-encoding mml-confirmation-set)
304 (message-options-get 'unknown-encoding)
306 Message contains characters with unknown encoding. Really send? ")
307 (message-options-set 'unknown-encoding t)))
309 (or (memq 'use-ascii mml-confirmation-set)
310 (message-options-get 'use-ascii)
311 (and (y-or-n-p "Use ASCII as charset? ")
312 (message-options-set 'use-ascii t))))
313 (setq charsets (delq nil charsets))
315 (error "Edit your message to remove those characters")))
318 (< (length charsets) 2))
319 (if (or (not no-markup-p)
320 (string-match "[^ \t\r\n]" contents))
321 ;; Don't create blank parts.
322 (push (nconc tag (list (cons 'contents contents)))
324 (let ((nstruct (mml-parse-singlepart-with-multiple-charsets
325 tag point (point) use-ascii)))
327 (not (memq 'multipart mml-confirmation-set))
328 (not (message-options-get 'multipart))
329 (not (and (y-or-n-p (format "\
330 A message part needs to be split into %d charset parts. Really send? "
332 (message-options-set 'multipart t))))
333 (error "Edit your message to use only one charset"))
334 (setq struct (nconc nstruct struct)))))))
339 (defun mml-parse-singlepart-with-multiple-charsets
340 (orig-tag beg end &optional use-ascii)
343 (narrow-to-region beg end)
344 (goto-char (point-min))
345 (let ((current (or (mm-mime-charset (mm-charset-after))
346 (and use-ascii 'us-ascii)))
347 charset struct space newline paragraph)
349 (setq charset (mm-mime-charset (mm-charset-after)))
351 ;; The charset remains the same.
352 ((eq charset 'us-ascii))
353 ((or (and use-ascii (not charset))
354 (eq charset current))
358 ;; The initial charset was ascii.
359 ((eq current 'us-ascii)
360 (setq current charset
364 ;; We have a change in charsets.
368 (list (cons 'contents
369 (buffer-substring-no-properties
370 beg (or paragraph newline space (point))))))
372 (setq beg (or paragraph newline space (point))
377 ;; Compute places where it might be nice to break the part.
379 ((memq (following-char) '(? ?\t))
380 (setq space (1+ (point))))
381 ((and (eq (following-char) ?\n)
383 (eq (char-after (1- (point))) ?\n))
384 (setq paragraph (point)))
385 ((eq (following-char) ?\n)
386 (setq newline (1+ (point)))))
388 ;; Do the final part.
389 (unless (= beg (point))
390 (push (append orig-tag
391 (list (cons 'contents
392 (buffer-substring-no-properties
397 (defun mml-read-tag ()
398 "Read a tag and return the contents."
399 (let ((orig-point (point))
400 contents name elem val)
402 (setq name (buffer-substring-no-properties
403 (point) (progn (forward-sexp 1) (point))))
404 (skip-chars-forward " \t\n")
405 (while (not (looking-at ">[ \t]*\n?"))
406 (setq elem (buffer-substring-no-properties
407 (point) (progn (forward-sexp 1) (point))))
408 (skip-chars-forward "= \t\n")
409 (setq val (buffer-substring-no-properties
410 (point) (progn (forward-sexp 1) (point))))
411 (when (string-match "\\`\"" val)
412 (setq val (read val))) ;; inverse of prin1 in mml-insert-tag
413 (push (cons (intern elem) val) contents)
414 (skip-chars-forward " \t\n"))
415 (goto-char (match-end 0))
416 ;; Don't skip the leading space.
417 ;;(skip-chars-forward " \t\n")
418 ;; Put the tag location into the returned contents
419 (setq contents (append (list (cons 'tag-location orig-point)) contents))
420 (cons (intern name) (nreverse contents))))
422 (defun mml-buffer-substring-no-properties-except-hard-newlines (start end)
423 (let ((str (buffer-substring-no-properties start end))
424 (bufstart start) tmp)
425 (while (setq tmp (text-property-any start end 'hard 't))
426 (set-text-properties (- tmp bufstart) (- tmp bufstart -1)
428 (setq start (1+ tmp)))
431 (defun mml-read-part (&optional mml)
432 "Return the buffer up till the next part, multipart or closing part or multipart.
433 If MML is non-nil, return the buffer up till the correspondent mml tag."
434 (let ((beg (point)) (count 1))
435 ;; If the tag ended at the end of the line, we go to the next line.
436 (when (looking-at "[ \t]*\n")
440 (while (and (> count 0) (not (eobp)))
441 (if (re-search-forward "<#\\(/\\)?mml." nil t)
442 (setq count (+ count (if (match-beginning 1) -1 1)))
443 (goto-char (point-max))))
444 (mml-buffer-substring-no-properties-except-hard-newlines
447 (match-beginning 0))))
448 (if (re-search-forward
449 "<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)." nil t)
451 (mml-buffer-substring-no-properties-except-hard-newlines
452 beg (match-beginning 0))
453 (if (or (not (match-beginning 1))
454 (equal (match-string 2) "multipart"))
455 (goto-char (match-beginning 0))
456 (when (looking-at "[ \t]*\n")
458 (mml-buffer-substring-no-properties-except-hard-newlines
459 beg (goto-char (point-max)))))))
461 (defvar mml-boundary nil)
462 (defvar mml-base-boundary "-=-=")
463 (defvar mml-multipart-number 0)
464 (defvar mml-inhibit-compute-boundary nil)
466 (defun mml-generate-mime ()
467 "Generate a MIME message based on the current MML document."
468 (let ((cont (mml-parse))
469 (mml-multipart-number mml-multipart-number)
470 (options message-options))
474 (mm-with-multibyte-buffer
475 (setq message-options options)
476 (if (and (consp (car cont))
478 (mml-generate-mime-1 (car cont))
479 (mml-generate-mime-1 (nconc (list 'multipart '(type . "mixed"))
481 (setq options message-options)
483 (setq message-options options)))))
485 (defun mml-generate-mime-1 (cont)
486 (let ((mm-use-ultra-safe-encoding
487 (or mm-use-ultra-safe-encoding (assq 'sign cont))))
489 (narrow-to-region (point) (point))
490 (mml-tweak-part cont)
492 ((or (eq (car cont) 'part) (eq (car cont) 'mml))
493 (let* ((raw (cdr (assq 'raw cont)))
494 (filename (cdr (assq 'filename cont)))
495 (type (or (cdr (assq 'type cont))
497 (or (mm-default-file-encoding filename)
498 "application/octet-stream")
500 (charset (cdr (assq 'charset cont)))
501 (coding (mm-charset-to-coding-system charset))
502 encoding flowed coded)
503 (cond ((eq coding 'ascii)
507 ;; The value of `charset' might be a bogus alias that
508 ;; `mm-charset-synonym-alist' provides, like `utf8',
509 ;; so we prefer the MIME charset that Emacs knows for
510 ;; the coding system `coding'.
511 (setq charset (or (mm-coding-system-to-mime-charset coding)
512 (intern (downcase charset))))))
514 (member (car (split-string type "/")) '("text" "message")))
518 ((cdr (assq 'buffer cont))
519 (insert-buffer-substring (cdr (assq 'buffer cont))))
521 (not (equal (cdr (assq 'nofile cont)) "yes")))
522 (let ((coding-system-for-read coding))
523 (mm-insert-file-contents filename)))
524 ((eq 'mml (car cont))
525 (insert (cdr (assq 'contents cont))))
528 (narrow-to-region (point) (point))
529 (insert (cdr (assq 'contents cont)))
530 ;; Remove quotes from quoted tags.
531 (goto-char (point-min))
532 (while (re-search-forward
533 "<#!+/?\\(part\\|multipart\\|external\\|mml\\|secure\\)"
535 (delete-region (+ (match-beginning 0) 2)
536 (+ (match-beginning 0) 3))))))
538 ((eq (car cont) 'mml)
539 (let ((mml-boundary (mml-compute-boundary cont))
540 ;; It is necessary for the case where this
541 ;; function is called recursively since
542 ;; `m-g-d-t' will be bound to "message/rfc822"
543 ;; when encoding an article to be forwarded.
544 (mml-generate-default-type "text/plain"))
546 ;; Update handle so mml-compute-boundary can
547 ;; detect collisions with the nested parts.
548 (unless mml-inhibit-compute-boundary
549 (setcdr (assoc 'contents cont) (buffer-string))))
550 (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b")))
551 ;; ignore 0x1b, it is part of iso-2022-jp
552 (setq encoding (mm-body-7-or-8))))
553 ((string= (car (split-string type "/")) "message")
554 (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b")))
555 ;; ignore 0x1b, it is part of iso-2022-jp
556 (setq encoding (mm-body-7-or-8))))
558 ;; Only perform format=flowed filling on text/plain
559 ;; parts where there either isn't a format parameter
560 ;; in the mml tag or it says "flowed" and there
561 ;; actually are hard newlines in the text.
562 (let (use-hard-newlines)
563 (when (and mml-enable-flowed
564 (string= type "text/plain")
565 (not (string= (cdr (assq 'sign cont)) "pgp"))
566 (or (null (assq 'format cont))
567 (string= (cdr (assq 'format cont))
569 (setq use-hard-newlines
571 (point-min) (point-max) 'hard 't)))
573 ;; Indicate that `mml-insert-mime-headers' should
574 ;; insert a "; format=flowed" string unless the
575 ;; user has already specified it.
576 (setq flowed (null (assq 'format cont)))))
577 ;; Prefer `utf-8' for text/calendar parts.
579 (not (string= type "text/calendar")))
580 (setq charset (mm-encode-body charset))
581 (let ((mm-coding-system-priorities
582 (cons 'utf-8 mm-coding-system-priorities)))
583 (setq charset (mm-encode-body))))
584 (setq encoding (mm-body-encoding
585 charset (cdr (assq 'encoding cont))))))
586 (setq coded (buffer-string)))
587 (mml-insert-mime-headers cont type charset encoding flowed)
590 (mm-with-unibyte-buffer
592 ((cdr (assq 'buffer cont))
593 (insert (mm-string-as-unibyte
594 (with-current-buffer (cdr (assq 'buffer cont))
597 (not (equal (cdr (assq 'nofile cont)) "yes")))
598 (let ((coding-system-for-read mm-binary-coding-system))
599 (mm-insert-file-contents filename nil nil nil nil t))
601 (setq charset (mm-coding-system-to-mime-charset
602 (mm-find-buffer-file-coding-system
605 (let ((contents (cdr (assq 'contents cont))))
606 (if (if (featurep 'xemacs)
607 (string-match "[^\000-\377]" contents)
608 (mm-multibyte-string-p contents))
610 (mm-enable-multibyte)
613 (setq charset (mm-encode-body charset))))
614 (insert contents)))))
615 (if (setq encoding (cdr (assq 'encoding cont)))
616 (setq encoding (intern (downcase encoding))))
617 (setq encoding (mm-encode-buffer type encoding)
618 coded (mm-string-as-multibyte (buffer-string))))
619 (mml-insert-mime-headers cont type charset encoding nil)
620 (insert "\n" coded))))
621 ((eq (car cont) 'external)
622 (insert "Content-Type: message/external-body")
623 (let ((parameters (mml-parameter-string
624 cont '(expiration size permission)))
625 (name (cdr (assq 'name cont)))
626 (url (cdr (assq 'url cont))))
628 (setq name (mml-parse-file-name name))
630 (mml-insert-parameter
631 (mail-header-encode-parameter "name" name)
632 "access-type=local-file")
633 (mml-insert-parameter
634 (mail-header-encode-parameter
635 "name" (file-name-nondirectory (nth 2 name)))
636 (mail-header-encode-parameter "site" (nth 1 name))
637 (mail-header-encode-parameter
638 "directory" (file-name-directory (nth 2 name))))
639 (mml-insert-parameter
640 (concat "access-type="
641 (if (member (nth 0 name) '("ftp@" "anonymous@"))
645 (mml-insert-parameter
646 (mail-header-encode-parameter "url" url)
649 (mml-insert-parameter-string
650 cont '(expiration size permission)))
652 (insert "Content-Type: "
653 (or (cdr (assq 'type cont))
655 (or (mm-default-file-encoding name)
656 "application/octet-stream")