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)