1 ;;; mml.el --- A package for parsing and validating MML documents
3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 ;; 2005 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 'fill-flowed-encode "flow-fill")
42 (autoload 'message-posting-charset "message"))
45 (autoload 'dnd-get-local-file-name "dnd"))
47 (defvar gnus-article-mime-handles)
49 (defvar gnus-newsrc-hashtb)
50 (defvar message-default-charset)
51 (defvar message-deletable-headers)
52 (defvar message-options)
53 (defvar message-posting-charset)
54 (defvar message-required-mail-headers)
55 (defvar message-required-news-headers)
57 (defcustom mml-content-type-parameters
58 '(name access-type expiration size permission format)
59 "*A list of acceptable parameters in MML tag.
60 These parameters are generated in Content-Type header if exists."
62 :type '(repeat (symbol :tag "Parameter"))
65 (defcustom mml-content-disposition-parameters
66 '(filename creation-date modification-date read-date)
67 "*A list of acceptable parameters in MML tag.
68 These parameters are generated in Content-Disposition header if exists."
70 :type '(repeat (symbol :tag "Parameter"))
73 (defcustom mml-insert-mime-headers-always nil
74 "If non-nil, always put Content-Type: text/plain at top of empty parts.
75 It is necessary to work against a bug in certain clients."
80 (defvar mml-tweak-type-alist nil
81 "A list of (TYPE . FUNCTION) for tweaking MML parts.
82 TYPE is a string containing a regexp to match the MIME type. FUNCTION
83 is a Lisp function which is called with the MML handle to tweak the
84 part. This variable is used only when no TWEAK parameter exists in
87 (defvar mml-tweak-function-alist nil
88 "A list of (NAME . FUNCTION) for tweaking MML parts.
89 NAME is a string containing the name of the TWEAK parameter in the MML
90 handle. FUNCTION is a Lisp function which is called with the MML
91 handle to tweak the part.")
93 (defvar mml-tweak-sexp-alist
94 '((mml-externalize-attachments . mml-tweak-externalize-attachments))
95 "A list of (SEXP . FUNCTION) for tweaking MML parts.
96 SEXP is an s-expression. If the evaluation of SEXP is non-nil, FUNCTION
97 is called. FUNCTION is a Lisp function which is called with the MML
98 handle to tweak the part.")
100 (defvar mml-externalize-attachments nil
101 "*If non-nil, local-file attachments are generated as external parts.")
103 (defvar mml-generate-multipart-alist nil
104 "*Alist of multipart generation functions.
105 Each entry has the form (NAME . FUNCTION), where
106 NAME is a string containing the name of the part (without the
107 leading \"/multipart/\"),
108 FUNCTION is a Lisp function which is called to generate the part.
110 The Lisp function has to supply the appropriate MIME headers and the
111 contents of this part.")
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)
126 (defvar mml-boundary-function 'mml-make-boundary
127 "A function called to suggest a boundary.
128 The function may be called several times, and should try to make a new
129 suggestion each time. The function is called with one parameter,
130 which is a number that says how many times the function has been
131 called for this message.")
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
136 unknown encoding; `use-ascii': always use ASCII for those characters
137 with unknown encoding; `multipart': always send messages with more than
140 (defvar mml-generate-default-type "text/plain"
141 "Content type by which the Content-Type header can be omitted.
142 The Content-Type header will not be put in the MIME part if the type
143 equals the value and there's no parameter (e.g. charset, format, etc.)
144 and `mml-insert-mime-headers-always' is nil. The value will be bound
145 to \"message/rfc822\" when encoding an article to be forwarded as a MIME
146 part. This is for the internal use, you should never modify the value.")
148 (defvar mml-buffer-list nil)
150 (defun mml-generate-new-buffer (name)
151 (let ((buf (generate-new-buffer name)))
152 (push buf mml-buffer-list)
155 (defun mml-destroy-buffers ()
156 (let (kill-buffer-hook)
157 (mapc 'kill-buffer mml-buffer-list)
158 (setq mml-buffer-list nil)))
161 "Parse the current buffer as an MML document."
163 (goto-char (point-min))
164 (with-syntax-table mml-syntax-table
167 (defun mml-parse-1 ()
168 "Parse the current buffer as an MML document."
169 (let (struct tag point contents charsets warn use-ascii no-markup-p raw)
170 (while (and (not (eobp))
171 (not (looking-at "<#/multipart")))
173 ((looking-at "<#secure")
174 ;; The secure part is essentially a meta-meta tag, which
175 ;; expands to either a part tag if there are no other parts in
176 ;; the document or a multipart tag if there are other parts
177 ;; included in the message
179 (taginfo (mml-read-tag))
180 (keyfile (cdr (assq 'keyfile taginfo)))
181 (certfile (cdr (assq 'certfile taginfo)))
182 (recipients (cdr (assq 'recipients taginfo)))
183 (sender (cdr (assq 'sender taginfo)))
184 (location (cdr (assq 'tag-location taginfo)))
185 (mode (cdr (assq 'mode taginfo)))
186 (method (cdr (assq 'method taginfo)))
189 (if (re-search-forward
190 "<#/?\\(multipart\\|part\\|external\\|mml\\)." nil t)
191 (setq secure-mode "multipart")
192 (setq secure-mode "part")))
195 (re-search-forward "<#secure[^\n]*>\n"))
196 (delete-region (match-beginning 0) (match-end 0))
197 (cond ((string= mode "sign")
198 (setq tags (list "sign" method)))
199 ((string= mode "encrypt")
200 (setq tags (list "encrypt" method)))
201 ((string= mode "signencrypt")
202 (setq tags (list "sign" method "encrypt" method))))
203 (eval `(mml-insert-tag ,secure-mode
205 ,(if keyfile "keyfile")
207 ,(if certfile "certfile")
209 ,(if recipients "recipients")
211 ,(if sender "sender")
214 (goto-char location)))
215 ((looking-at "<#multipart")
216 (push (nconc (mml-read-tag) (mml-parse-1)) struct))
217 ((looking-at "<#external")
218 (push (nconc (mml-read-tag) (list (cons 'contents (mml-read-part))))
221 (if (or (looking-at "<#part") (looking-at "<#mml"))
222 (setq tag (mml-read-tag)
225 (setq tag (list 'part '(type . "text/plain"))
228 (setq raw (cdr (assq 'raw tag))
230 contents (mml-read-part (eq 'mml (car tag)))
235 (intern (downcase (cdr (assq 'charset tag))))))
237 (mm-find-mime-charset-region point (point)
239 (when (and (not raw) (memq nil charsets))
240 (if (or (memq 'unknown-encoding mml-confirmation-set)
241 (message-options-get 'unknown-encoding)
243 Message contains characters with unknown encoding. Really send? ")
244 (message-options-set 'unknown-encoding t)))
246 (or (memq 'use-ascii mml-confirmation-set)
247 (message-options-get 'use-ascii)
248 (and (y-or-n-p "Use ASCII as charset? ")
249 (message-options-set 'use-ascii t))))
250 (setq charsets (delq nil charsets))
252 (error "Edit your message to remove those characters")))
255 (< (length charsets) 2))
256 (if (or (not no-markup-p)
257 (string-match "[^ \t\r\n]" contents))
258 ;; Don't create blank parts.
259 (push (nconc tag (list (cons 'contents contents)))
261 (let ((nstruct (mml-parse-singlepart-with-multiple-charsets
262 tag point (point) use-ascii)))
264 (not (memq 'multipart mml-confirmation-set))
265 (not (message-options-get 'multipart))
266 (not (and (y-or-n-p (format "\
267 A message part needs to be split into %d charset parts. Really send? "
269 (message-options-set 'multipart t))))
270 (error "Edit your message to use only one charset"))
271 (setq struct (nconc nstruct struct)))))))
276 (defun mml-parse-singlepart-with-multiple-charsets
277 (orig-tag beg end &optional use-ascii)
280 (narrow-to-region beg end)
281 (goto-char (point-min))
282 (let ((current (or (mm-mime-charset (mm-charset-after))
283 (and use-ascii 'us-ascii)))
284 charset struct space newline paragraph)
286 (setq charset (mm-mime-charset (mm-charset-after)))
288 ;; The charset remains the same.
289 ((eq charset 'us-ascii))
290 ((or (and use-ascii (not charset))
291 (eq charset current))
295 ;; The initial charset was ascii.
296 ((eq current 'us-ascii)
297 (setq current charset
301 ;; We have a change in charsets.
305 (list (cons 'contents
306 (buffer-substring-no-properties
307 beg (or paragraph newline space (point))))))
309 (setq beg (or paragraph newline space (point))
314 ;; Compute places where it might be nice to break the part.
316 ((memq (following-char) '(? ?\t))
317 (setq space (1+ (point))))
318 ((and (eq (following-char) ?\n)
320 (eq (char-after (1- (point))) ?\n))
321 (setq paragraph (point)))
322 ((eq (following-char) ?\n)
323 (setq newline (1+ (point)))))
325 ;; Do the final part.
326 (unless (= beg (point))
327 (push (append orig-tag
328 (list (cons 'contents
329 (buffer-substring-no-properties
334 (defun mml-read-tag ()
335 "Read a tag and return the contents."
336 (let ((orig-point (point))
337 contents name elem val)
339 (setq name (buffer-substring-no-properties
340 (point) (progn (forward-sexp 1) (point))))
341 (skip-chars-forward " \t\n")
342 (while (not (looking-at ">[ \t]*\n?"))
343 (setq elem (buffer-substring-no-properties
344 (point) (progn (forward-sexp 1) (point))))
345 (skip-chars-forward "= \t\n")
346 (setq val (buffer-substring-no-properties
347 (point) (progn (forward-sexp 1) (point))))
348 (when (string-match "^\"\\(.*\\)\"$" val)
349 (setq val (match-string 1 val)))
350 (push (cons (intern elem) val) contents)
351 (skip-chars-forward " \t\n"))
352 (goto-char (match-end 0))
353 ;; Don't skip the leading space.
354 ;;(skip-chars-forward " \t\n")
355 ;; Put the tag location into the returned contents
356 (setq contents (append (list (cons 'tag-location orig-point)) contents))
357 (cons (intern name) (nreverse contents))))
359 (defun mml-buffer-substring-no-properties-except-hard-newlines (start end)
360 (let ((str (buffer-substring-no-properties start end))
361 (bufstart start) tmp)
362 (while (setq tmp (text-property-any start end 'hard 't))
363 (set-text-properties (- tmp bufstart) (- tmp bufstart -1)
365 (setq start (1+ tmp)))
368 (defun mml-read-part (&optional mml)
369 "Return the buffer up till the next part, multipart or closing part or multipart.
370 If MML is non-nil, return the buffer up till the correspondent mml tag."
371 (let ((beg (point)) (count 1))
372 ;; If the tag ended at the end of the line, we go to the next line.
373 (when (looking-at "[ \t]*\n")
377 (while (and (> count 0) (not (eobp)))
378 (if (re-search-forward "<#\\(/\\)?mml." nil t)
379 (setq count (+ count (if (match-beginning 1) -1 1)))
380 (goto-char (point-max))))
381 (mml-buffer-substring-no-properties-except-hard-newlines
384 (match-beginning 0))))
385 (if (re-search-forward
386 "<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)." nil t)
388 (mml-buffer-substring-no-properties-except-hard-newlines
389 beg (match-beginning 0))
390 (if (or (not (match-beginning 1))
391 (equal (match-string 2) "multipart"))
392 (goto-char (match-beginning 0))
393 (when (looking-at "[ \t]*\n")
395 (mml-buffer-substring-no-properties-except-hard-newlines
396 beg (goto-char (point-max)))))))
398 (defvar mml-boundary nil)
399 (defvar mml-base-boundary "-=-=")
400 (defvar mml-multipart-number 0)
402 (defun mml-generate-mime ()
403 "Generate a MIME message based on the current MML document."
404 (let ((cont (mml-parse))
405 (mml-multipart-number mml-multipart-number))
409 (if (and (consp (car cont))
411 (mml-generate-mime-1 (car cont))
412 (mml-generate-mime-1 (nconc (list 'multipart '(type . "mixed"))
416 (defun mml-generate-mime-1 (cont)
417 (let ((mm-use-ultra-safe-encoding
418 (or mm-use-ultra-safe-encoding (assq 'sign cont))))
420 (narrow-to-region (point) (point))
421 (mml-tweak-part cont)
423 ((or (eq (car cont) 'part) (eq (car cont) 'mml))
424 (let* ((raw (cdr (assq 'raw cont)))
425 (filename (cdr (assq 'filename cont)))
426 (type (or (cdr (assq 'type cont))
428 (or (mm-default-file-encoding filename)
429 "application/octet-stream")
431 (charset (cdr (assq 'charset cont)))
432 (coding (mm-charset-to-coding-system charset))
433 encoding flowed coded)
434 (cond ((eq coding 'ascii)
438 (setq charset (intern (downcase charset)))))
440 (member (car (split-string type "/")) '("text" "message")))
444 ((cdr (assq 'buffer cont))
445 (insert-buffer-substring (cdr (assq 'buffer cont))))
447 (not (equal (cdr (assq 'nofile cont)) "yes")))
448 (let ((coding-system-for-read coding))
449 (mm-insert-file-contents filename)))
450 ((eq 'mml (car cont))
451 (insert (cdr (assq 'contents cont))))
454 (narrow-to-region (point) (point))
455 (insert (cdr (assq 'contents cont)))
456 ;; Remove quotes from quoted tags.
457 (goto-char (point-min))
458 (while (re-search-forward
459 "<#!+/?\\(part\\|multipart\\|external\\|mml\\)"
461 (delete-region (+ (match-beginning 0) 2)
462 (+ (match-beginning 0) 3))))))
464 ((eq (car cont) 'mml)
465 (let ((mml-boundary (mml-compute-boundary cont))
466 ;; It is necessary for the case where this
467 ;; function is called recursively since
468 ;; `m-g-d-t' will be bound to "message/rfc822"
469 ;; when encoding an article to be forwarded.
470 (mml-generate-default-type "text/plain"))
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 ((string= (car (split-string type "/")) "message")
476 (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b")))
477 ;; ignore 0x1b, it is part of iso-2022-jp
478 (setq encoding (mm-body-7-or-8))))
480 ;; Only perform format=flowed filling on text/plain
481 ;; parts where there either isn't a format parameter
482 ;; in the mml tag or it says "flowed" and there
483 ;; actually are hard newlines in the text.
484 (let (use-hard-newlines)
485 (when (and (string= type "text/plain")
486 (not (string= (cdr (assq 'sign cont)) "pgp"))
487 (or (null (assq 'format cont))
488 (string= (cdr (assq 'format cont))
490 (setq use-hard-newlines
492 (point-min) (point-max) 'hard 't)))
494 ;; Indicate that `mml-insert-mime-headers' should
495 ;; insert a "; format=flowed" string unless the
496 ;; user has already specified it.
497 (setq flowed (null (assq 'format cont)))))
498 (setq charset (mm-encode-body charset))
499 (setq encoding (mm-body-encoding
500 charset (cdr (assq 'encoding cont))))))
501 (setq coded (buffer-string)))
502 (mml-insert-mime-headers cont type charset encoding flowed)
505 (mm-with-unibyte-buffer
507 ((cdr (assq 'buffer cont))
508 (insert (with-current-buffer (cdr (assq 'buffer cont))
509 (mm-with-unibyte-current-buffer
512 (not (equal (cdr (assq 'nofile cont)) "yes")))
513 (let ((coding-system-for-read mm-binary-coding-system))
514 (mm-insert-file-contents filename nil nil nil nil t))
516 (setq charset (mm-coding-system-to-mime-charset
517 (mm-find-buffer-file-coding-system
520 (insert (cdr (assq 'contents cont)))))
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)
525 (mm-with-unibyte-current-buffer
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))))
534 (setq name (mml-parse-file-name 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@"))
551 (mml-insert-parameter
552 (mail-header-encode-parameter "url" url)
555 (mml-insert-parameter-string
556 cont '(expiration size permission)))
558 (insert "Content-Type: "
559 (or (cdr (assq 'type cont))
561 (or (mm-default-file-encoding name)
562 "application/octet-stream")
565 (insert "Content-ID: " (message-make-message-id) "\n")
566 (insert "Content-Transfer-Encoding: "
567 (or (cdr (assq 'encoding cont)) "binary"))
569 (insert (or (cdr (assq 'contents cont))))
571 ((eq (car cont) 'multipart)
572 (let* ((type (or (cdr (assq 'type cont)) "mixed"))
573 (mml-generate-default-type (if (equal type "digest")
576 (handler (assoc type mml-generate-multipart-alist)))
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\""
583 (if (cdr (assq 'start cont))
584 (format "; start=\"%s\"\n" (cdr (assq 'start cont)))
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 (insert "\n--" mml-boundary "--\n")))))
594 (error "Invalid element: %S" cont)))
595 ;; handle sign & encrypt tags in a semi-smart way.
596 (let ((sign-item (assoc (cdr (assq 'sign cont)) mml-sign-alist))
597 (encrypt-item (assoc (cdr (assq 'encrypt cont))
600 (when (or sign-item encrypt-item)
601 (when (setq sender (cdr (assq 'sender cont)))
602 (message-options-set 'mml-sender sender)
603 (message-options-set 'message-sender sender))
604 (if (setq recipients (cdr (assq 'recipients cont)))
605 (message-options-set 'message-recipients recipients))
606 (let ((style (mml-signencrypt-style
607 (first (or sign-item encrypt-item)))))
608 ;; check if: we're both signing & encrypting, both methods
609 ;; are the same (why would they be different?!), and that
610 ;; the signencrypt style allows for combined operation.
611 (if (and sign-item encrypt-item (equal (first sign-item)
612 (first encrypt-item))
613 (equal style 'combined))
614 (funcall (nth 1 encrypt-item) cont t)
615 ;; otherwise, revert to the old behavior.
617 (funcall (nth 1 sign-item) cont))
619 (funcall (nth 1 encrypt-item) cont)))))))))
621 (defun mml-compute-boundary (cont)
622 "Return a unique boundary that does not exist in CONT."
623 (let ((mml-boundary (funcall mml-boundary-function
624 (incf mml-multipart-number))))
625 ;; This function tries again and again until it has found
626 ;; a unique boundary.
627 (while (not (catch 'not-unique
628 (mml-compute-boundary-1 cont))))
631 (defun mml-compute-boundary-1 (cont)
634 ((eq (car cont) 'part)
637 ((cdr (assq 'buffer cont))
638 (insert-buffer-substring (cdr (assq 'buffer cont))))
639 ((and (setq filename (cdr (assq 'filename cont)))
640 (not (equal (cdr (assq 'nofile cont)) "yes")))
641 (mm-insert-file-contents filename nil nil nil nil t))
643 (insert (cdr (assq 'contents cont)))))
644 (goto-char (point-min))
645 (when (re-search-forward (concat "^--" (regexp-quote mml-boundary))
647 (setq mml-boundary (funcall mml-boundary-function
648 (incf mml-multipart-number)))
649 (throw 'not-unique nil))))
650 ((eq (car cont) 'multipart)
651 (mapc 'mml-compute-boundary-1 (cddr cont))))
654 (defun mml-make-boundary (number)
655 (concat (make-string (% number 60) ?=)
661 (defun mml-insert-mime-headers (cont type charset encoding flowed)
662 (let (parameters id disposition description)
664 (mml-parameter-string
665 cont mml-content-type-parameters))
669 (not (equal type mml-generate-default-type))
670 mml-insert-mime-headers-always)
671 (when (consp charset)
673 "Can't encode a part with several charsets"))
674 (insert "Content-Type: " type)
676 (insert "; " (mail-header-encode-parameter
677 "charset" (symbol-name charset))))
679 (insert "; format=flowed"))
681 (mml-insert-parameter-string
682 cont mml-content-type-parameters))
684 (when (setq id (cdr (assq 'id cont)))
685 (insert "Content-ID: " id "\n"))
687 (mml-parameter-string
688 cont mml-content-disposition-parameters))
689 (when (or (setq disposition (cdr (assq 'disposition cont)))
691 (insert "Content-Disposition: " (or disposition "inline"))
693 (mml-insert-parameter-string
694 cont mml-content-disposition-parameters))
696 (unless (eq encoding '7bit)
697 (insert (format "Content-Transfer-Encoding: %s\n" encoding)))
698 (when (setq description (cdr (assq 'description cont)))
699 (insert "Content-Description: "
700 (mail-encode-encoded-word-string description) "\n"))))
702 (defun mml-parameter-string (cont types)
705 (while (setq type (pop types))
706 (when (setq value (cdr (assq type cont)))
707 ;; Strip directory component from the filename parameter.
708 (when (eq type 'filename)
709 (setq value (file-name-nondirectory value)))
710 (setq string (concat string "; "
711 (mail-header-encode-parameter
712 (symbol-name type) value)))))
713 (when (not (zerop (length string)))
716 (defun mml-insert-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 (mml-insert-parameter
724 (mail-header-encode-parameter
725 (symbol-name type) value))))))
728 (defvar ange-ftp-name-format)
729 (defvar efs-path-regexp))
730 (defun mml-parse-file-name (path)
731 (if (if (boundp 'efs-path-regexp)
732 (string-match efs-path-regexp path)
733 (if (boundp 'ange-ftp-name-format)
734 (string-match (car ange-ftp-name-format) path)))
735 (list (match-string 1 path) (match-string 2 path)
736 (substring path (1+ (match-end 2))))
739 (defun mml-insert-buffer (buffer)
740 "Insert BUFFER at point and quote any MML markup."
742 (narrow-to-region (point) (point))
743 (insert-buffer-substring buffer)
744 (mml-quote-region (point-min) (point-max))
745 (goto-char (point-max))))
748 ;;; Transforming MIME to MML
751 (defun mime-to-mml (&optional handles)
752 "Translate the current buffer (which should be a message) into MML.
753 If HANDLES is non-nil, use it instead reparsing the buffer."
754 ;; First decode the head.
756 (message-narrow-to-head)
757 (let ((rfc2047-quote-decoded-words-containing-tspecials t))
758 (mail-decode-encoded-word-region (point-min) (point-max))))
760 (setq handles (mm-dissect-buffer t)))
761 (goto-char (point-min))
762 (search-forward "\n\n" nil t)
763 (delete-region (point) (point-max))
764 (if (stringp (car handles))
765 (mml-insert-mime handles)
766 (mml-insert-mime handles t))
767 (mm-destroy-parts handles)
769 (message-narrow-to-head)
770 ;; Remove them, they are confusing.
771 (message-remove-header "Content-Type")
772 (message-remove-header "MIME-Version")
773 (message-remove-header "Content-Disposition")
774 (message-remove-header "Content-Transfer-Encoding")))
776 (defun mml-to-mime ()
777 "Translate the current buffer from MML to MIME."
778 (message-encode-message-body)
780 (message-narrow-to-headers-or-head)
781 ;; Skip past any From_ headers.
782 (while (looking-at "From ")
784 (let ((mail-parse-charset message-default-charset))
785 (mail-encode-encoded-word-buffer))))
787 (defun mml-insert-mime (handle &optional no-markup)
788 (let (textp buffer mmlp)
789 ;; Determine type and stuff.
790 (unless (stringp (car handle))
791 (unless (setq textp (equal (mm-handle-media-supertype handle) "text"))
793 (set-buffer (setq buffer (mml-generate-new-buffer " *mml*")))
794 (mm-insert-part handle)
795 (if (setq mmlp (equal (mm-handle-media-type handle)
799 (mml-insert-mml-markup handle nil t t)
800 (unless (and no-markup
801 (equal (mm-handle-media-type handle) "text/plain"))
802 (mml-insert-mml-markup handle buffer textp)))
805 (insert-buffer-substring buffer)
806 (goto-char (point-max))
807 (insert "<#/mml>\n"))
808 ((stringp (car handle))
809 (mapcar 'mml-insert-mime (cdr handle))
810 (insert "<#/multipart>\n"))
812 (let ((charset (mail-content-type-get
813 (mm-handle-type handle) 'charset))
815 (if (eq charset 'gnus-decoded)
816 (mm-insert-part handle)
817 (insert (mm-decode-string (mm-get-part handle) charset)))
818 (mml-quote-region start (point)))
819 (goto-char (point-max)))
821 (insert "<#/part>\n")))))
823 (defun mml-insert-mml-markup (handle &optional buffer nofile mmlp)
824 "Take a MIME handle and insert an MML tag."
825 (if (stringp (car handle))
827 (insert "<#multipart type=" (mm-handle-media-subtype handle))
828 (let ((start (mm-handle-multipart-ctl-parameter handle 'start)))
830 (insert " start=\"" start "\"")))
833 (insert "<#mml type=" (mm-handle-media-type handle))
834 (insert "<#part type=" (mm-handle-media-type handle)))
835 (dolist (elem (append (cdr (mm-handle-type handle))
836 (cdr (mm-handle-disposition handle))))
837 (unless (symbolp (cdr elem))
838 (insert " " (symbol-name (car elem)) "=\"" (cdr elem) "\"")))
839 (when (mm-handle-id handle)
840 (insert " id=\"" (mm-handle-id handle) "\""))
841 (when (mm-handle-disposition handle)
842 (insert " disposition=" (car (mm-handle-disposition handle))))
844 (insert " buffer=\"" (buffer-name buffer) "\""))
846 (insert " nofile=yes"))
847 (when (mm-handle-description handle)
848 (insert " description=\"" (mm-handle-description handle) "\""))
851 (defun mml-insert-parameter (&rest parameters)
852 "Insert PARAMETERS in a nice way."
853 (dolist (param parameters)
855 (let ((point (point)))
857 (when (> (current-column) 71)
863 ;;; Mode for inserting and editing MML forms
867 (let ((sign (make-sparse-keymap))
868 (encrypt (make-sparse-keymap))
869 (signpart (make-sparse-keymap))
870 (encryptpart (make-sparse-keymap))
871 (map (make-sparse-keymap))
872 (main (make-sparse-keymap)))
873 (define-key map "\C-s" 'mml-secure-message-sign)
874 (define-key map "\C-c" 'mml-secure-message-encrypt)
875 (define-key map "\C-e" 'mml-secure-message-sign-encrypt)
876 (define-key map "\C-p\C-s" 'mml-secure-sign)
877 (define-key map "\C-p\C-c" 'mml-secure-encrypt)
878 (define-key sign "p" 'mml-secure-message-sign-pgpmime)
879 (define-key sign "o" 'mml-secure-message-sign-pgp)
880 (define-key sign "s" 'mml-secure-message-sign-smime)
881 (define-key signpart "p" 'mml-secure-sign-pgpmime)
882 (define-key signpart "o" 'mml-secure-sign-pgp)
883 (define-key signpart "s" 'mml-secure-sign-smime)
884 (define-key encrypt "p" 'mml-secure-message-encrypt-pgpmime)
885 (define-key encrypt "o" 'mml-secure-message-encrypt-pgp)
886 (define-key encrypt "s" 'mml-secure-message-encrypt-smime)
887 (define-key encryptpart "p" 'mml-secure-encrypt-pgpmime)
888 (define-key encryptpart "o" 'mml-secure-encrypt-pgp)
889 (define-key encryptpart "s" 'mml-secure-encrypt-smime)
890 (define-key map "\C-n" 'mml-unsecure-message)
891 (define-key map "f" 'mml-attach-file)
892 (define-key map "b" 'mml-attach-buffer)
893 (define-key map "e" 'mml-attach-external)
894 (define-key map "q" 'mml-quote-region)
895 (define-key map "m" 'mml-insert-multipart)
896 (define-key map "p" 'mml-insert-part)
897 (define-key map "v" 'mml-validate)
898 (define-key map "P" 'mml-preview)
899 (define-key map "s" sign)
900 (define-key map "S" signpart)
901 (define-key map "c" encrypt)
902 (define-key map "C" encryptpart)
903 ;;(define-key map "n" 'mml-narrow-to-part)
904 ;; `M-m' conflicts with `back-to-indentation'.
905 ;; (define-key main "\M-m" map)
906 (define-key main "\C-c\C-m" map)
910 mml-menu mml-mode-map ""
912 ["Attach File..." mml-attach-file
913 ,@(if (featurep 'xemacs) '(t)
914 '(:help "Attach a file at point"))]
915 ["Attach Buffer..." mml-attach-buffer
916 ,@(if (featurep 'xemacs) '(t)
917 '(:help "Attach a buffer to the outgoing MIME message"))]
918 ["Attach External..." mml-attach-external
919 ,@(if (featurep 'xemacs) '(t)
920 '(:help "Attach reference to file"))]
922 ("Change Security Method"
924 (lambda () (interactive) (setq mml-secure-method "pgpmime"))
925 ,@(if (featurep 'xemacs) nil
926 '(:help "Set Security Method to PGP/MIME"))
928 :selected (equal mml-secure-method "pgpmime") ]
930 (lambda () (interactive) (setq mml-secure-method "smime"))
931 ,@(if (featurep 'xemacs) nil
932 '(:help "Set Security Method to S/MIME"))
934 :selected (equal mml-secure-method "smime") ]
936 (lambda () (interactive) (setq mml-secure-method "pgp"))
937 ,@(if (featurep 'xemacs) nil
938 '(:help "Set Security Method to inline PGP"))
940 :selected (equal mml-secure-method "pgp") ] )
942 ["Sign Message" mml-secure-message-sign t]
943 ["Encrypt Message" mml-secure-message-encrypt t]
944 ["Sign and Encrypt Message" mml-secure-message-sign-encrypt t]
945 ["Encrypt/Sign off" mml-unsecure-message
946 ,@(if (featurep 'xemacs) '(t)
947 '(:help "Don't Encrypt/Sign Message"))]
948 ;; Maybe we could remove these, because people who write MML most probably
949 ;; don't use the menu:
950 ["Insert Part..." mml-insert-part
951 :active (message-in-body-p)]
952 ["Insert Multipart..." mml-insert-multipart
953 :active (message-in-body-p)]
955 ;; Do we have separate encrypt and encrypt/sign commands for parts?
956 ["Sign Part" mml-secure-sign t]
957 ["Encrypt Part" mml-secure-encrypt t]
958 ;;["Narrow" mml-narrow-to-part t]
959 ["Quote MML in region" mml-quote-region
960 :active (message-mark-active-p)
961 ,@(if (featurep 'xemacs) nil
962 '(:help "Quote MML tags in region"))]
963 ["Validate MML" mml-validate t]
964 ["Preview" mml-preview t]))
967 "Minor mode for editing MML.")
969 (defun mml-mode (&optional arg)
970 "Minor mode for editing MML.
971 MML is the MIME Meta Language, a minor mode for composing MIME articles.
972 See Info node `(emacs-mime)Composing'.
976 (when (set (make-local-variable 'mml-mode)
977 (if (null arg) (not mml-mode)
978 (> (prefix-numeric-value arg) 0)))
979 (add-minor-mode 'mml-mode " MML" mml-mode-map)
980 (easy-menu-add mml-menu mml-mode-map)
981 (when (boundp 'dnd-protocol-alist)
982 (set (make-local-variable 'dnd-protocol-alist)
983 (append mml-dnd-protocol-alist
984 (symbol-value 'dnd-protocol-alist))))
985 (run-hooks 'mml-mode-hook)))
988 ;;; Helper functions for reading MIME stuff from the minibuffer and
989 ;;; inserting stuff to the buffer.
992 (defun mml-minibuffer-read-file (prompt)
993 (let* ((completion-ignored-extensions nil)
994 (file (read-file-name prompt nil nil t)))
995 ;; Prevent some common errors. This is inspired by similar code in
997 (when (file-directory-p file)
998 (error "%s is a directory, cannot attach" file))
999 (unless (file-exists-p file)
1000 (error "No such file: %s" file))
1001 (unless (file-readable-p file)
1002 (error "Permission denied: %s" file))
1005 (defun mml-minibuffer-read-type (name &optional default)
1006 (mailcap-parse-mimetypes)
1007 (let* ((default (or default
1008 (mm-default-file-encoding name)
1009 ;; Perhaps here we should check what the file
1010 ;; looks like, and offer text/plain if it looks
1012 "application/octet-stream"))
1013 (string (completing-read
1014 (format "Content type (default %s): " default)
1015 (mapcar 'list (mailcap-mime-types)))))
1016 (if (not (equal string ""))
1020 (defun mml-minibuffer-read-description ()
1021 (let ((description (read-string "One line description: ")))
1022 (when (string-match "\\`[ \t]*\\'" description)
1023 (setq description nil))
1026 (defun mml-minibuffer-read-disposition (type &optional default)
1027 (unless default (setq default
1028 (if (and (string-match "\\`text/" type)
1029 (not (string-match "\\`text/rtf\\'" type)))
1032 (let ((disposition (completing-read
1033 (format "Disposition (default %s): " default)
1034 '(("attachment") ("inline") (""))
1035 nil t nil nil default)))
1036 (if (not (equal disposition ""))
1040 (defun mml-quote-region (beg end)
1041 "Quote the MML tags in the region."
1045 ;; Temporarily narrow the region to defend from changes
1046 ;; invalidating END.
1047 (narrow-to-region beg end)
1048 (goto-char (point-min))
1050 (while (re-search-forward
1051 "<#!*/?\\(multipart\\|part\\|external\\|mml\\)" nil t)
1052 ;; Insert ! after the #.
1053 (goto-char (+ (match-beginning 0) 2))
1056 (defun mml-insert-tag (name &rest plist)
1057 "Insert an MML tag described by NAME and PLIST."
1058 (when (symbolp name)
1059 (setq name (symbol-name name)))
1062 (let ((key (pop plist))
1063 (value (pop plist)))
1065 ;; Quote VALUE if it contains suspicious characters.
1066 (when (string-match "[\"'\\~/*;() \t\n]" value)
1067 (setq value (with-output-to-string
1068 (let (print-escape-nonascii)
1070 (insert (format " %s=%s" key value)))))
1073 (defun mml-insert-empty-tag (name &rest plist)
1074 "Insert an empty MML tag described by NAME and PLIST."
1075 (when (symbolp name)
1076 (setq name (symbol-name name)))
1077 (apply #'mml-insert-tag name plist)
1078 (insert "<#/" name ">\n"))
1080 ;;; Attachment functions.
1082 (defcustom mml-dnd-protocol-alist
1083 '(("^file:///" . mml-dnd-attach-file)
1084 ("^file://" . dnd-open-file)
1085 ("^file:" . mml-dnd-attach-file))
1086 "The functions to call when a drop in `mml-mode' is made.
1087 See `dnd-protocol-alist' for more information. When nil, behave
1088 as in other buffers."
1089 :type '(choice (repeat (cons (regexp) (function)))
1090 (const :tag "Behave as in other buffers" nil))
1091 :version "23.0" ;; No Gnus
1094 (defcustom mml-dnd-attach-options nil
1095 "Which options should be queried when attaching a file via drag and drop.
1097 If it is a list, valid members are `type', `description' and
1098 `disposition'. `disposition' implies `type'. If it is nil,
1099 don't ask for options. If it is t, ask the user whether or not
1100 to specify options."
1102 (const :tag "Non" nil)
1103 (const :tag "Query" t)
1104 (list :value (type description disposition)
1108 (const disposition))))
1109 :version "23.0" ;; No Gnus
1112 (defun mml-attach-file (file &optional type description disposition)
1113 "Attach a file to the outgoing MIME message.
1114 The file is not inserted or encoded until you send the message with
1115 `\\[message-send-and-exit]' or `\\[message-send]'.
1117 FILE is the name of the file to attach. TYPE is its content-type, a
1118 string of the form \"type/subtype\". DESCRIPTION is a one-line
1119 description of the attachment."
1121 (let* ((file (mml-minibuffer-read-file "Attach file: "))
1122 (type (mml-minibuffer-read-type file))
1123 (description (mml-minibuffer-read-description))
1124 (disposition (mml-minibuffer-read-disposition type)))
1125 (list file type description disposition)))
1127 (unless (message-in-body-p) (goto-char (point-max)))
1128 (mml-insert-empty-tag 'part
1131 'disposition (or disposition "attachment")
1132 'description description)))
1134 (defun mml-dnd-attach-file (uri action)
1135 "Attach a drag and drop file.
1137 Ask for type, description or disposition according to
1138 `mml-dnd-attach-options'."
1139 (let ((file (dnd-get-local-file-name uri t)))
1140 (when (and file (file-regular-p file))
1141 (let ((mml-dnd-attach-options mml-dnd-attach-options)
1142 type description disposition)
1143 (setq mml-dnd-attach-options
1144 (when (and (eq mml-dnd-attach-options t)
1147 "Use default type, disposition and description? ")))
1148 '(type description disposition)))
1149 (when (or (memq 'type mml-dnd-attach-options)
1150 (memq 'disposition mml-dnd-attach-options))
1151 (setq type (mml-minibuffer-read-type file)))
1152 (when (memq 'description mml-dnd-attach-options)
1153 (setq description (mml-minibuffer-read-description)))
1154 (when (memq 'disposition mml-dnd-attach-options)
1155 (setq disposition (mml-minibuffer-read-disposition type)))
1156 (mml-attach-file file type description disposition)))))
1158 (defun mml-attach-buffer (buffer &optional type description)
1159 "Attach a buffer to the outgoing MIME message.
1160 See `mml-attach-file' for details of operation."
1162 (let* ((buffer (read-buffer "Attach buffer: "))
1163 (type (mml-minibuffer-read-type buffer "text/plain"))
1164 (description (mml-minibuffer-read-description)))
1165 (list buffer type description)))
1167 (unless (message-in-body-p) (goto-char (point-max)))
1168 (mml-insert-empty-tag 'part 'type type 'buffer buffer
1169 'disposition "attachment"
1170 'description description)))
1172 (defun mml-attach-external (file &optional type description)
1173 "Attach an external file into the buffer.
1174 FILE is an ange-ftp/efs specification of the part location.
1175 TYPE is the MIME type to use."
1177 (let* ((file (mml-minibuffer-read-file "Attach external file: "))
1178 (type (mml-minibuffer-read-type file))
1179 (description (mml-minibuffer-read-description)))
1180 (list file type description)))
1182 (unless (message-in-body-p) (goto-char (point-max)))
1183 (mml-insert-empty-tag 'external 'type type 'name file
1184 'disposition "attachment" 'description description)))
1186 (defun mml-insert-multipart (&optional type)
1187 (interactive (list (completing-read "Multipart type (default mixed): "
1188 '(("mixed") ("alternative") ("digest") ("parallel")
1189 ("signed") ("encrypted"))
1192 (setq type "mixed"))
1193 (mml-insert-empty-tag "multipart" 'type type)
1196 (defun mml-insert-part (&optional type)
1198 (list (mml-minibuffer-read-type "")))
1199 (mml-insert-tag 'part 'type type 'disposition "inline")
1202 (defun mml-preview-insert-mail-followup-to ()
1203 "Insert a Mail-Followup-To header before previewing an article.
1204 Should be adopted if code in `message-send-mail' is changed."
1205 (when (and (message-mail-p)
1206 (message-subscribed-p)
1207 (not (mail-fetch-field "mail-followup-to"))
1208 (message-make-mail-followup-to))
1209 (message-position-on-field "Mail-Followup-To" "X-Draft-From")
1210 (insert (message-make-mail-followup-to))))
1212 (defvar mml-preview-buffer nil)
1214 (defun mml-preview (&optional raw)
1215 "Display current buffer with Gnus, in a new buffer.
1216 If RAW, display a raw encoded MIME message.
1218 The window layout for the preview buffer is controled by the variables
1219 `special-display-buffer-names', `special-display-regexps', or
1220 `gnus-buffer-configuration' (the first match made will be used),
1221 or the `pop-to-buffer' function."
1223 (setq mml-preview-buffer (generate-new-buffer
1224 (concat (if raw "*Raw MIME preview of "
1225 "*MIME preview of ") (buffer-name))))
1227 (let* ((buf (current-buffer))
1228 (message-options message-options)
1229 (message-this-is-mail (message-mail-p))
1230 (message-this-is-news (message-news-p))
1231 (message-posting-charset (or (gnus-setup-posting-charset
1233 (message-narrow-to-headers-or-head)
1234 (message-fetch-field "Newsgroups")))
1235 message-posting-charset)))
1236 (message-options-set-recipient)
1237 (when (boundp 'gnus-buffers)
1238 (push mml-preview-buffer gnus-buffers))
1241 (set-buffer mml-preview-buffer)
1243 (insert-buffer-substring buf))
1244 (mml-preview-insert-mail-followup-to)
1245 (let ((message-deletable-headers (if (message-news-p)
1247 message-deletable-headers)))
1248 (message-generate-headers
1249 (copy-sequence (if (message-news-p)
1250 message-required-news-headers
1251 message-required-mail-headers))))
1252 (if (re-search-forward
1253 (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
1254 (replace-match "\n"))
1255 (let ((mail-header-separator ""));; mail-header-separator is removed.
1256 (message-sort-headers)
1259 (when (fboundp 'set-buffer-multibyte)
1260 (let ((s (buffer-string)))
1261 ;; Insert the content into unibyte buffer.
1263 (mm-disable-multibyte)
1265 (let ((gnus-newsgroup-charset (car message-posting-charset))
1266 gnus-article-prepare-hook gnus-original-article-buffer)
1267 (run-hooks 'gnus-article-decode-hook)
1268 (let ((gnus-newsgroup-name "dummy")
1269 (gnus-newsrc-hashtb (or gnus-newsrc-hashtb
1270 (gnus-make-hashtable 5))))
1271 (gnus-article-prepare-display))))
1272 ;; Disable article-mode-map.
1274 (gnus-make-local-hook 'kill-buffer-hook)
1275 (add-hook 'kill-buffer-hook
1277 (mm-destroy-parts gnus-article-mime-handles)) nil t)
1278 (setq buffer-read-only t)
1279 (local-set-key "q" (lambda () (interactive) (kill-buffer nil)))
1280 (local-set-key "=" (lambda () (interactive) (delete-other-windows)))
1284 (widget-button-press (point))))
1285 (local-set-key gnus-mouse-2
1288 (widget-button-press (widget-event-point event) event)))
1289 (goto-char (point-min))))
1290 (if (and (not (mm-special-display-p (buffer-name mml-preview-buffer)))
1291 (boundp 'gnus-buffer-configuration)
1292 (assq 'mml-preview gnus-buffer-configuration))
1293 (let ((gnus-message-buffer (current-buffer)))
1294 (gnus-configure-windows 'mml-preview))
1295 (pop-to-buffer mml-preview-buffer)))
1297 (defun mml-validate ()
1298 "Validate the current MML document."
1302 (defun mml-tweak-part (cont)
1304 (let ((tweak (cdr (assq 'tweak cont)))
1309 (or (cdr (assoc tweak mml-tweak-function-alist))
1311 (mml-tweak-type-alist
1312 (let ((alist mml-tweak-type-alist)
1313 (type (or (cdr (assq 'type cont)) "text/plain")))
1315 (if (string-match (caar alist) type)
1316 (setq func (cdar alist)
1318 (setq alist (cdr alist)))))))
1322 (let ((alist mml-tweak-sexp-alist))
1324 (if (eval (caar alist))
1325 (funcall (cdar alist) cont))
1326 (setq alist (cdr alist)))))
1329 (defun mml-tweak-externalize-attachments (cont)
1330 "Tweak attached files as external parts."
1331 (let (filename-cons)
1332 (when (and (eq (car cont) 'part)
1333 (not (cdr (assq 'buffer cont)))
1334 (and (setq filename-cons (assq 'filename cont))
1335 (not (equal (cdr (assq 'nofile cont)) "yes"))))
1336 (setcar cont 'external)
1337 (setcar filename-cons 'name))))
1341 ;;; mml.el ends here