1 ;;; mml.el --- A package for parsing and validating MML documents
2 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005
3 ;; 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 2, or (at your option)
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; see the file COPYING. If not, write to the
20 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
21 ;; Boston, MA 02110-1301, USA.
32 (eval-when-compile (require 'cl))
35 (autoload 'message-make-message-id "message")
36 (autoload 'gnus-setup-posting-charset "gnus-msg")
37 (autoload 'gnus-add-minor-mode "gnus-ems")
38 (autoload 'gnus-make-local-hook "gnus-util")
39 (autoload 'message-fetch-field "message")
40 (autoload 'fill-flowed-encode "flow-fill")
41 (autoload 'message-posting-charset "message"))
43 (defcustom mml-content-type-parameters
44 '(name access-type expiration size permission format)
45 "*A list of acceptable parameters in MML tag.
46 These parameters are generated in Content-Type header if exists."
48 :type '(repeat (symbol :tag "Parameter"))
51 (defcustom mml-content-disposition-parameters
52 '(filename creation-date modification-date read-date)
53 "*A list of acceptable parameters in MML tag.
54 These parameters are generated in Content-Disposition header if exists."
56 :type '(repeat (symbol :tag "Parameter"))
59 (defcustom mml-insert-mime-headers-always nil
60 "If non-nil, always put Content-Type: text/plain at top of empty parts.
61 It is necessary to work against a bug in certain clients."
66 (defvar mml-tweak-type-alist nil
67 "A list of (TYPE . FUNCTION) for tweaking MML parts.
68 TYPE is a string containing a regexp to match the MIME type. FUNCTION
69 is a Lisp function which is called with the MML handle to tweak the
70 part. This variable is used only when no TWEAK parameter exists in
73 (defvar mml-tweak-function-alist nil
74 "A list of (NAME . FUNCTION) for tweaking MML parts.
75 NAME is a string containing the name of the TWEAK parameter in the MML
76 handle. FUNCTION is a Lisp function which is called with the MML
77 handle to tweak the part.")
79 (defvar mml-tweak-sexp-alist
80 '((mml-externalize-attachments . mml-tweak-externalize-attachments))
81 "A list of (SEXP . FUNCTION) for tweaking MML parts.
82 SEXP is an s-expression. If the evaluation of SEXP is non-nil, FUNCTION
83 is called. FUNCTION is a Lisp function which is called with the MML
84 handle to tweak the part.")
86 (defvar mml-externalize-attachments nil
87 "*If non-nil, local-file attachments are generated as external parts.")
89 (defvar mml-generate-multipart-alist nil
90 "*Alist of multipart generation functions.
91 Each entry has the form (NAME . FUNCTION), where
92 NAME is a string containing the name of the part (without the
93 leading \"/multipart/\"),
94 FUNCTION is a Lisp function which is called to generate the part.
96 The Lisp function has to supply the appropriate MIME headers and the
97 contents of this part.")
99 (defvar mml-syntax-table
100 (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table)))
101 (modify-syntax-entry ?\\ "/" table)
102 (modify-syntax-entry ?< "(" table)
103 (modify-syntax-entry ?> ")" table)
104 (modify-syntax-entry ?@ "w" table)
105 (modify-syntax-entry ?/ "w" table)
106 (modify-syntax-entry ?= " " table)
107 (modify-syntax-entry ?* " " table)
108 (modify-syntax-entry ?\; " " table)
109 (modify-syntax-entry ?\' " " table)
112 (defvar mml-boundary-function 'mml-make-boundary
113 "A function called to suggest a boundary.
114 The function may be called several times, and should try to make a new
115 suggestion each time. The function is called with one parameter,
116 which is a number that says how many times the function has been
117 called for this message.")
119 (defvar mml-confirmation-set nil
120 "A list of symbols, each of which disables some warning.
121 `unknown-encoding': always send messages contain characters with
122 unknown encoding; `use-ascii': always use ASCII for those characters
123 with unknown encoding; `multipart': always send messages with more than
126 (defvar mml-generate-default-type "text/plain"
127 "Content type by which the Content-Type header can be omitted.
128 The Content-Type header will not be put in the MIME part if the type
129 equals the value and there's no parameter (e.g. charset, format, etc.)
130 and `mml-insert-mime-headers-always' is nil. The value will be bound
131 to \"message/rfc822\" when encoding an article to be forwarded as a MIME
132 part. This is for the internal use, you should never modify the value.")
134 (defvar mml-buffer-list nil)
136 (defun mml-generate-new-buffer (name)
137 (let ((buf (generate-new-buffer name)))
138 (push buf mml-buffer-list)
141 (defun mml-destroy-buffers ()
142 (let (kill-buffer-hook)
143 (mapcar 'kill-buffer mml-buffer-list)
144 (setq mml-buffer-list nil)))
147 "Parse the current buffer as an MML document."
149 (goto-char (point-min))
150 (let ((table (syntax-table)))
153 (set-syntax-table mml-syntax-table)
155 (set-syntax-table table)))))
157 (defun mml-parse-1 ()
158 "Parse the current buffer as an MML document."
159 (let (struct tag point contents charsets warn use-ascii no-markup-p raw)
160 (while (and (not (eobp))
161 (not (looking-at "<#/multipart")))
163 ((looking-at "<#secure")
164 ;; The secure part is essentially a meta-meta tag, which
165 ;; expands to either a part tag if there are no other parts in
166 ;; the document or a multipart tag if there are other parts
167 ;; included in the message
169 (taginfo (mml-read-tag))
170 (recipients (cdr (assq 'recipients taginfo)))
171 (sender (cdr (assq 'sender taginfo)))
172 (location (cdr (assq 'tag-location taginfo)))
173 (mode (cdr (assq 'mode taginfo)))
174 (method (cdr (assq 'method taginfo)))
179 "<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)." nil t)
180 (setq secure-mode "multipart")
181 (setq secure-mode "part")))
184 (re-search-forward "<#secure[^\n]*>\n"))
185 (delete-region (match-beginning 0) (match-end 0))
186 (cond ((string= mode "sign")
187 (setq tags (list "sign" method)))
188 ((string= mode "encrypt")
189 (setq tags (list "encrypt" method)))
190 ((string= mode "signencrypt")
191 (setq tags (list "sign" method "encrypt" method))))
192 (eval `(mml-insert-tag ,secure-mode
194 ,(if recipients "recipients")
196 ,(if sender "sender")
199 (goto-char location)))
200 ((looking-at "<#multipart")
201 (push (nconc (mml-read-tag) (mml-parse-1)) struct))
202 ((looking-at "<#external")
203 (push (nconc (mml-read-tag) (list (cons 'contents (mml-read-part))))
206 (if (or (looking-at "<#part") (looking-at "<#mml"))
207 (setq tag (mml-read-tag)
210 (setq tag (list 'part '(type . "text/plain"))
213 (setq raw (cdr (assq 'raw tag))
215 contents (mml-read-part (eq 'mml (car tag)))
220 (intern (downcase (cdr (assq 'charset tag))))))
222 (mm-find-mime-charset-region point (point)
224 (when (and (not raw) (memq nil charsets))
225 (if (or (memq 'unknown-encoding mml-confirmation-set)
226 (message-options-get 'unknown-encoding)
228 Message contains characters with unknown encoding. Really send? ")
229 (message-options-set 'unknown-encoding t)))
231 (or (memq 'use-ascii mml-confirmation-set)
232 (message-options-get 'use-ascii)
233 (and (y-or-n-p "Use ASCII as charset? ")
234 (message-options-set 'use-ascii t))))
235 (setq charsets (delq nil charsets))
237 (error "Edit your message to remove those characters")))
240 (< (length charsets) 2))
241 (if (or (not no-markup-p)
242 (string-match "[^ \t\r\n]" contents))
243 ;; Don't create blank parts.
244 (push (nconc tag (list (cons 'contents contents)))
246 (let ((nstruct (mml-parse-singlepart-with-multiple-charsets
247 tag point (point) use-ascii)))
249 (not (memq 'multipart mml-confirmation-set))
250 (not (message-options-get 'multipart))
251 (not (and (y-or-n-p (format "\
252 A message part needs to be split into %d charset parts. Really send? "
254 (message-options-set 'multipart t))))
255 (error "Edit your message to use only one charset"))
256 (setq struct (nconc nstruct struct)))))))
261 (defun mml-parse-singlepart-with-multiple-charsets
262 (orig-tag beg end &optional use-ascii)
265 (narrow-to-region beg end)
266 (goto-char (point-min))
267 (let ((current (or (mm-mime-charset (mm-charset-after))
268 (and use-ascii 'us-ascii)))
269 charset struct space newline paragraph)
271 (setq charset (mm-mime-charset (mm-charset-after)))
273 ;; The charset remains the same.
274 ((eq charset 'us-ascii))
275 ((or (and use-ascii (not charset))
276 (eq charset current))
280 ;; The initial charset was ascii.
281 ((eq current 'us-ascii)
282 (setq current charset
286 ;; We have a change in charsets.
290 (list (cons 'contents
291 (buffer-substring-no-properties
292 beg (or paragraph newline space (point))))))
294 (setq beg (or paragraph newline space (point))
299 ;; Compute places where it might be nice to break the part.
301 ((memq (following-char) '(? ?\t))
302 (setq space (1+ (point))))
303 ((and (eq (following-char) ?\n)
305 (eq (char-after (1- (point))) ?\n))
306 (setq paragraph (point)))
307 ((eq (following-char) ?\n)
308 (setq newline (1+ (point)))))
310 ;; Do the final part.
311 (unless (= beg (point))
312 (push (append orig-tag
313 (list (cons 'contents
314 (buffer-substring-no-properties
319 (defun mml-read-tag ()
320 "Read a tag and return the contents."
321 (let ((orig-point (point))
322 contents name elem val)
324 (setq name (buffer-substring-no-properties
325 (point) (progn (forward-sexp 1) (point))))
326 (skip-chars-forward " \t\n")
327 (while (not (looking-at ">[ \t]*\n?"))
328 (setq elem (buffer-substring-no-properties
329 (point) (progn (forward-sexp 1) (point))))
330 (skip-chars-forward "= \t\n")
331 (setq val (buffer-substring-no-properties
332 (point) (progn (forward-sexp 1) (point))))
333 (when (string-match "^\"\\(.*\\)\"$" val)
334 (setq val (match-string 1 val)))
335 (push (cons (intern elem) val) contents)
336 (skip-chars-forward " \t\n"))
337 (goto-char (match-end 0))
338 ;; Don't skip the leading space.
339 ;;(skip-chars-forward " \t\n")
340 ;; Put the tag location into the returned contents
341 (setq contents (append (list (cons 'tag-location orig-point)) contents))
342 (cons (intern name) (nreverse contents))))
344 (defun mml-buffer-substring-no-properties-except-hard-newlines (start end)
345 (let ((str (buffer-substring-no-properties start end))
346 (bufstart start) tmp)
347 (while (setq tmp (text-property-any start end 'hard 't))
348 (set-text-properties (- tmp bufstart) (- tmp bufstart -1)
350 (setq start (1+ tmp)))
353 (defun mml-read-part (&optional mml)
354 "Return the buffer up till the next part, multipart or closing part or multipart.
355 If MML is non-nil, return the buffer up till the correspondent mml tag."
356 (let ((beg (point)) (count 1))
357 ;; If the tag ended at the end of the line, we go to the next line.
358 (when (looking-at "[ \t]*\n")
362 (while (and (> count 0) (not (eobp)))
363 (if (re-search-forward "<#\\(/\\)?mml." nil t)
364 (setq count (+ count (if (match-beginning 1) -1 1)))
365 (goto-char (point-max))))
366 (mml-buffer-substring-no-properties-except-hard-newlines
369 (match-beginning 0))))
370 (if (re-search-forward
371 "<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)." nil t)
373 (mml-buffer-substring-no-properties-except-hard-newlines
374 beg (match-beginning 0))
375 (if (or (not (match-beginning 1))
376 (equal (match-string 2) "multipart"))
377 (goto-char (match-beginning 0))
378 (when (looking-at "[ \t]*\n")
380 (mml-buffer-substring-no-properties-except-hard-newlines
381 beg (goto-char (point-max)))))))
383 (defvar mml-boundary nil)
384 (defvar mml-base-boundary "-=-=")
385 (defvar mml-multipart-number 0)
387 (defun mml-generate-mime ()
388 "Generate a MIME message based on the current MML document."
389 (let ((cont (mml-parse))
390 (mml-multipart-number mml-multipart-number))
394 (if (and (consp (car cont))
396 (mml-generate-mime-1 (car cont))
397 (mml-generate-mime-1 (nconc (list 'multipart '(type . "mixed"))
401 (defun mml-generate-mime-1 (cont)
402 (let ((mm-use-ultra-safe-encoding
403 (or mm-use-ultra-safe-encoding (assq 'sign cont))))
405 (narrow-to-region (point) (point))
406 (mml-tweak-part cont)
408 ((or (eq (car cont) 'part) (eq (car cont) 'mml))
409 (let* ((raw (cdr (assq 'raw cont)))
410 (filename (cdr (assq 'filename cont)))
411 (type (or (cdr (assq 'type cont))
413 (or (mm-default-file-encoding filename)
414 "application/octet-stream")
416 coded encoding charset flowed)
418 (member (car (split-string type "/")) '("text" "message")))
421 (setq charset (mm-charset-to-coding-system
422 (cdr (assq 'charset cont))))
423 (when (eq charset 'ascii)
426 ((cdr (assq 'buffer cont))
427 (insert-buffer-substring (cdr (assq 'buffer cont))))
429 (not (equal (cdr (assq 'nofile cont)) "yes")))
430 (let ((coding-system-for-read charset))
431 (mm-insert-file-contents filename)))
432 ((eq 'mml (car cont))
433 (insert (cdr (assq 'contents cont))))
436 (narrow-to-region (point) (point))
437 (insert (cdr (assq 'contents cont)))
438 ;; Remove quotes from quoted tags.
439 (goto-char (point-min))
440 (while (re-search-forward
441 "<#!+/?\\(part\\|multipart\\|external\\|mml\\)"
443 (delete-region (+ (match-beginning 0) 2)
444 (+ (match-beginning 0) 3))))))
446 ((eq (car cont) 'mml)
447 (let ((mml-boundary (mml-compute-boundary cont))
448 ;; It is necessary for the case where this
449 ;; function is called recursively since
450 ;; `m-g-d-t' will be bound to "message/rfc822"
451 ;; when encoding an article to be forwarded.
452 (mml-generate-default-type "text/plain"))
454 (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b")))
455 ;; ignore 0x1b, it is part of iso-2022-jp
456 (setq encoding (mm-body-7-or-8))))
457 ((string= (car (split-string type "/")) "message")
458 (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b")))
459 ;; ignore 0x1b, it is part of iso-2022-jp
460 (setq encoding (mm-body-7-or-8))))
462 ;; Only perform format=flowed filling on text/plain
463 ;; parts where there either isn't a format parameter
464 ;; in the mml tag or it says "flowed" and there
465 ;; actually are hard newlines in the text.
466 (let (use-hard-newlines)
467 (when (and (string= type "text/plain")
468 (not (string= (cdr (assq 'sign cont)) "pgp"))
469 (or (null (assq 'format cont))
470 (string= (cdr (assq 'format cont))
472 (setq use-hard-newlines
474 (point-min) (point-max) 'hard 't)))
476 ;; Indicate that `mml-insert-mime-headers' should
477 ;; insert a "; format=flowed" string unless the
478 ;; user has already specified it.
479 (setq flowed (null (assq 'format cont)))))
480 (setq charset (mm-encode-body charset))
481 (setq encoding (mm-body-encoding
482 charset (cdr (assq 'encoding cont))))))
483 (setq coded (buffer-string)))
484 (mml-insert-mime-headers cont type charset encoding flowed)
487 (mm-with-unibyte-buffer
489 ((cdr (assq 'buffer cont))
490 (insert (with-current-buffer (cdr (assq 'buffer cont))
491 (mm-with-unibyte-current-buffer
494 (not (equal (cdr (assq 'nofile cont)) "yes")))
495 (let ((coding-system-for-read mm-binary-coding-system))
496 (mm-insert-file-contents filename nil nil nil nil t)))
498 (insert (cdr (assq 'contents cont)))))
499 (setq encoding (mm-encode-buffer type)
500 coded (mm-string-as-multibyte (buffer-string))))
501 (mml-insert-mime-headers cont type charset encoding nil)
503 (mm-with-unibyte-current-buffer
505 ((eq (car cont) 'external)
506 (insert "Content-Type: message/external-body")
507 (let ((parameters (mml-parameter-string
508 cont '(expiration size permission)))
509 (name (cdr (assq 'name cont)))
510 (url (cdr (assq 'url cont))))
512 (setq name (mml-parse-file-name name))
514 (mml-insert-parameter
515 (mail-header-encode-parameter "name" name)
516 "access-type=local-file")
517 (mml-insert-parameter
518 (mail-header-encode-parameter
519 "name" (file-name-nondirectory (nth 2 name)))
520 (mail-header-encode-parameter "site" (nth 1 name))
521 (mail-header-encode-parameter
522 "directory" (file-name-directory (nth 2 name))))
523 (mml-insert-parameter
524 (concat "access-type="
525 (if (member (nth 0 name) '("ftp@" "anonymous@"))
529 (mml-insert-parameter
530 (mail-header-encode-parameter "url" url)
533 (mml-insert-parameter-string
534 cont '(expiration size permission)))
536 (insert "Content-Type: "
537 (or (cdr (assq 'type cont))
539 (or (mm-default-file-encoding name)
540 "application/octet-stream")
543 (insert "Content-ID: " (message-make-message-id) "\n")
544 (insert "Content-Transfer-Encoding: "
545 (or (cdr (assq 'encoding cont)) "binary"))
547 (insert (or (cdr (assq 'contents cont))))
549 ((eq (car cont) 'multipart)
550 (let* ((type (or (cdr (assq 'type cont)) "mixed"))
551 (mml-generate-default-type (if (equal type "digest")
554 (handler (assoc type mml-generate-multipart-alist)))
556 (funcall (cdr handler) cont)
557 ;; No specific handler. Use default one.
558 (let ((mml-boundary (mml-compute-boundary cont)))
559 (insert (format "Content-Type: multipart/%s; boundary=\"%s\""
561 (if (cdr (assq 'start cont))
562 (format "; start=\"%s\"\n" (cdr (assq 'start cont)))
564 (let ((cont cont) part)
565 (while (setq part (pop cont))
566 ;; Skip `multipart' and attributes.
567 (when (and (consp part) (consp (cdr part)))
568 (insert "\n--" mml-boundary "\n")
569 (mml-generate-mime-1 part))))
570 (insert "\n--" mml-boundary "--\n")))))
572 (error "Invalid element: %S" cont)))
573 ;; handle sign & encrypt tags in a semi-smart way.
574 (let ((sign-item (assoc (cdr (assq 'sign cont)) mml-sign-alist))
575 (encrypt-item (assoc (cdr (assq 'encrypt cont))
578 (when (or sign-item encrypt-item)
579 (when (setq sender (cdr (assq 'sender cont)))
580 (message-options-set 'mml-sender sender)
581 (message-options-set 'message-sender sender))
582 (if (setq recipients (cdr (assq 'recipients cont)))
583 (message-options-set 'message-recipients recipients))
584 (let ((style (mml-signencrypt-style
585 (first (or sign-item encrypt-item)))))
586 ;; check if: we're both signing & encrypting, both methods
587 ;; are the same (why would they be different?!), and that
588 ;; the signencrypt style allows for combined operation.
589 (if (and sign-item encrypt-item (equal (first sign-item)
590 (first encrypt-item))
591 (equal style 'combined))
592 (funcall (nth 1 encrypt-item) cont t)
593 ;; otherwise, revert to the old behavior.
595 (funcall (nth 1 sign-item) cont))
597 (funcall (nth 1 encrypt-item) cont)))))))))
599 (defun mml-compute-boundary (cont)
600 "Return a unique boundary that does not exist in CONT."
601 (let ((mml-boundary (funcall mml-boundary-function
602 (incf mml-multipart-number))))
603 ;; This function tries again and again until it has found
604 ;; a unique boundary.
605 (while (not (catch 'not-unique
606 (mml-compute-boundary-1 cont))))
609 (defun mml-compute-boundary-1 (cont)
612 ((eq (car cont) 'part)
615 ((cdr (assq 'buffer cont))
616 (insert-buffer-substring (cdr (assq 'buffer cont))))
617 ((and (setq filename (cdr (assq 'filename cont)))
618 (not (equal (cdr (assq 'nofile cont)) "yes")))
619 (mm-insert-file-contents filename nil nil nil nil t))
621 (insert (cdr (assq 'contents cont)))))
622 (goto-char (point-min))
623 (when (re-search-forward (concat "^--" (regexp-quote mml-boundary))
625 (setq mml-boundary (funcall mml-boundary-function
626 (incf mml-multipart-number)))
627 (throw 'not-unique nil))))
628 ((eq (car cont) 'multipart)
629 (mapcar 'mml-compute-boundary-1 (cddr cont))))
632 (defun mml-make-boundary (number)
633 (concat (make-string (% number 60) ?=)
639 (defun mml-insert-mime-headers (cont type charset encoding flowed)
640 (let (parameters id disposition description)
642 (mml-parameter-string
643 cont mml-content-type-parameters))
647 (not (equal type mml-generate-default-type))
648 mml-insert-mime-headers-always)
649 (when (consp charset)
651 "Can't encode a part with several charsets"))
652 (insert "Content-Type: " type)
654 (insert "; " (mail-header-encode-parameter
655 "charset" (symbol-name charset))))
657 (insert "; format=flowed"))
659 (mml-insert-parameter-string
660 cont mml-content-type-parameters))
662 (when (setq id (cdr (assq 'id cont)))
663 (insert "Content-ID: " id "\n"))
665 (mml-parameter-string
666 cont mml-content-disposition-parameters))
667 (when (or (setq disposition (cdr (assq 'disposition cont)))
669 (insert "Content-Disposition: " (or disposition "inline"))
671 (mml-insert-parameter-string
672 cont mml-content-disposition-parameters))
674 (unless (eq encoding '7bit)
675 (insert (format "Content-Transfer-Encoding: %s\n" encoding)))
676 (when (setq description (cdr (assq 'description cont)))
677 (insert "Content-Description: "
678 (mail-encode-encoded-word-string description) "\n"))))
680 (defun mml-parameter-string (cont types)
683 (while (setq type (pop types))
684 (when (setq value (cdr (assq type cont)))
685 ;; Strip directory component from the filename parameter.
686 (when (eq type 'filename)
687 (setq value (file-name-nondirectory value)))
688 (setq string (concat string "; "
689 (mail-header-encode-parameter
690 (symbol-name type) value)))))
691 (when (not (zerop (length string)))
694 (defun mml-insert-parameter-string (cont types)
696 (while (setq type (pop types))
697 (when (setq value (cdr (assq type cont)))
698 ;; Strip directory component from the filename parameter.
699 (when (eq type 'filename)
700 (setq value (file-name-nondirectory value)))
701 (mml-insert-parameter
702 (mail-header-encode-parameter
703 (symbol-name type) value))))))
706 (defvar ange-ftp-name-format)
707 (defvar efs-path-regexp))
708 (defun mml-parse-file-name (path)
709 (if (if (boundp 'efs-path-regexp)
710 (string-match efs-path-regexp path)
711 (if (boundp 'ange-ftp-name-format)
712 (string-match (car ange-ftp-name-format) path)))
713 (list (match-string 1 path) (match-string 2 path)
714 (substring path (1+ (match-end 2))))
717 (defun mml-insert-buffer (buffer)
718 "Insert BUFFER at point and quote any MML markup."
720 (narrow-to-region (point) (point))
721 (insert-buffer-substring buffer)
722 (mml-quote-region (point-min) (point-max))
723 (goto-char (point-max))))
726 ;;; Transforming MIME to MML
729 (defun mime-to-mml (&optional handles)
730 "Translate the current buffer (which should be a message) into MML.
731 If HANDLES is non-nil, use it instead reparsing the buffer."
732 ;; First decode the head.
734 (message-narrow-to-head)
735 (let ((rfc2047-quote-decoded-words-containing-tspecials t))
736 (mail-decode-encoded-word-region (point-min) (point-max))))
738 (setq handles (mm-dissect-buffer t)))
739 (goto-char (point-min))
740 (search-forward "\n\n" nil t)
741 (delete-region (point) (point-max))
742 (if (stringp (car handles))
743 (mml-insert-mime handles)
744 (mml-insert-mime handles t))
745 (mm-destroy-parts handles)
747 (message-narrow-to-head)
748 ;; Remove them, they are confusing.
749 (message-remove-header "Content-Type")
750 (message-remove-header "MIME-Version")
751 (message-remove-header "Content-Disposition")
752 (message-remove-header "Content-Transfer-Encoding")))
754 (defun mml-to-mime ()
755 "Translate the current buffer from MML to MIME."
756 (message-encode-message-body)
758 (message-narrow-to-headers-or-head)
759 ;; Skip past any From_ headers.
760 (while (looking-at "From ")
762 (let ((mail-parse-charset message-default-charset))
763 (mail-encode-encoded-word-buffer))))
765 (defun mml-insert-mime (handle &optional no-markup)
766 (let (textp buffer mmlp)
767 ;; Determine type and stuff.
768 (unless (stringp (car handle))
769 (unless (setq textp (equal (mm-handle-media-supertype handle) "text"))
771 (set-buffer (setq buffer (mml-generate-new-buffer " *mml*")))
772 (mm-insert-part handle)
773 (if (setq mmlp (equal (mm-handle-media-type handle)
777 (mml-insert-mml-markup handle nil t t)
778 (unless (and no-markup
779 (equal (mm-handle-media-type handle) "text/plain"))
780 (mml-insert-mml-markup handle buffer textp)))
783 (insert-buffer-substring buffer)
784 (goto-char (point-max))
785 (insert "<#/mml>\n"))
786 ((stringp (car handle))
787 (mapcar 'mml-insert-mime (cdr handle))
788 (insert "<#/multipart>\n"))
790 (let ((charset (mail-content-type-get
791 (mm-handle-type handle) 'charset))
793 (if (eq charset 'gnus-decoded)
794 (mm-insert-part handle)
795 (insert (mm-decode-string (mm-get-part handle) charset)))
796 (mml-quote-region start (point)))
797 (goto-char (point-max)))
799 (insert "<#/part>\n")))))
801 (defun mml-insert-mml-markup (handle &optional buffer nofile mmlp)
802 "Take a MIME handle and insert an MML tag."
803 (if (stringp (car handle))
805 (insert "<#multipart type=" (mm-handle-media-subtype handle))
806 (let ((start (mm-handle-multipart-ctl-parameter handle 'start)))
808 (insert " start=\"" start "\"")))
811 (insert "<#mml type=" (mm-handle-media-type handle))
812 (insert "<#part type=" (mm-handle-media-type handle)))
813 (dolist (elem (append (cdr (mm-handle-type handle))
814 (cdr (mm-handle-disposition handle))))
815 (unless (symbolp (cdr elem))
816 (insert " " (symbol-name (car elem)) "=\"" (cdr elem) "\"")))
817 (when (mm-handle-id handle)
818 (insert " id=\"" (mm-handle-id handle) "\""))
819 (when (mm-handle-disposition handle)
820 (insert " disposition=" (car (mm-handle-disposition handle))))
822 (insert " buffer=\"" (buffer-name buffer) "\""))
824 (insert " nofile=yes"))
825 (when (mm-handle-description handle)
826 (insert " description=\"" (mm-handle-description handle) "\""))
829 (defun mml-insert-parameter (&rest parameters)
830 "Insert PARAMETERS in a nice way."
831 (dolist (param parameters)
833 (let ((point (point)))
835 (when (> (current-column) 71)
841 ;;; Mode for inserting and editing MML forms
845 (let ((sign (make-sparse-keymap))
846 (encrypt (make-sparse-keymap))
847 (signpart (make-sparse-keymap))
848 (encryptpart (make-sparse-keymap))
849 (map (make-sparse-keymap))
850 (main (make-sparse-keymap)))
851 (define-key sign "p" 'mml-secure-message-sign-pgpmime)
852 (define-key sign "o" 'mml-secure-message-sign-pgp)
853 (define-key sign "s" 'mml-secure-message-sign-smime)
854 (define-key signpart "p" 'mml-secure-sign-pgpmime)
855 (define-key signpart "o" 'mml-secure-sign-pgp)
856 (define-key signpart "s" 'mml-secure-sign-smime)
857 (define-key encrypt "p" 'mml-secure-message-encrypt-pgpmime)
858 (define-key encrypt "o" 'mml-secure-message-encrypt-pgp)
859 (define-key encrypt "s" 'mml-secure-message-encrypt-smime)
860 (define-key encryptpart "p" 'mml-secure-encrypt-pgpmime)
861 (define-key encryptpart "o" 'mml-secure-encrypt-pgp)
862 (define-key encryptpart "s" 'mml-secure-encrypt-smime)
863 (define-key map "\C-n" 'mml-unsecure-message)
864 (define-key map "f" 'mml-attach-file)
865 (define-key map "b" 'mml-attach-buffer)
866 (define-key map "e" 'mml-attach-external)
867 (define-key map "q" 'mml-quote-region)
868 (define-key map "m" 'mml-insert-multipart)
869 (define-key map "p" 'mml-insert-part)
870 (define-key map "v" 'mml-validate)
871 (define-key map "P" 'mml-preview)
872 (define-key map "s" sign)
873 (define-key map "S" signpart)
874 (define-key map "c" encrypt)
875 (define-key map "C" encryptpart)
876 ;;(define-key map "n" 'mml-narrow-to-part)
877 ;; `M-m' conflicts with `back-to-indentation'.
878 ;; (define-key main "\M-m" map)
879 (define-key main "\C-c\C-m" map)
883 mml-menu mml-mode-map ""
885 ["Attach File..." mml-attach-file
886 ,@(if (featurep 'xemacs) '(t)
887 '(:help "Attach a file at point"))]
888 ["Attach Buffer..." mml-attach-buffer t]
889 ["Attach External..." mml-attach-external t]
890 ["Insert Part..." mml-insert-part t]
891 ["Insert Multipart..." mml-insert-multipart t]
892 ["PGP/MIME Sign" mml-secure-message-sign-pgpmime t]
893 ["PGP/MIME Encrypt" mml-secure-message-encrypt-pgpmime t]
894 ["PGP Sign" mml-secure-message-sign-pgp t]
895 ["PGP Encrypt" mml-secure-message-encrypt-pgp t]
896 ["S/MIME Sign" mml-secure-message-sign-smime t]
897 ["S/MIME Encrypt" mml-secure-message-encrypt-smime t]
899 ["PGP/MIME Sign Part" mml-secure-sign-pgpmime t]
900 ["PGP/MIME Encrypt Part" mml-secure-encrypt-pgpmime t]
901 ["PGP Sign Part" mml-secure-sign-pgp t]
902 ["PGP Encrypt Part" mml-secure-encrypt-pgp t]
903 ["S/MIME Sign Part" mml-secure-sign-smime t]
904 ["S/MIME Encrypt Part" mml-secure-encrypt-smime t])
905 ["Encrypt/Sign off" mml-unsecure-message t]
906 ;;["Narrow" mml-narrow-to-part t]
907 ["Quote MML" mml-quote-region t]
908 ["Validate MML" mml-validate t]
909 ["Preview" mml-preview t]))
912 "Minor mode for editing MML.")
914 (defun mml-mode (&optional arg)
915 "Minor mode for editing MML.
916 MML is the MIME Meta Language, a minor mode for composing MIME articles.
917 See Info node `(emacs-mime)Composing'.
921 (when (set (make-local-variable 'mml-mode)
922 (if (null arg) (not mml-mode)
923 (> (prefix-numeric-value arg) 0)))
924 (gnus-add-minor-mode 'mml-mode " MML" mml-mode-map)
925 (easy-menu-add mml-menu mml-mode-map)
926 (run-hooks 'mml-mode-hook)))
929 ;;; Helper functions for reading MIME stuff from the minibuffer and
930 ;;; inserting stuff to the buffer.
933 (defun mml-minibuffer-read-file (prompt)
934 (let* ((completion-ignored-extensions nil)
935 (file (read-file-name prompt nil nil t)))
936 ;; Prevent some common errors. This is inspired by similar code in
938 (when (file-directory-p file)
939 (error "%s is a directory, cannot attach" file))
940 (unless (file-exists-p file)
941 (error "No such file: %s" file))
942 (unless (file-readable-p file)
943 (error "Permission denied: %s" file))
946 (defun mml-minibuffer-read-type (name &optional default)
947 (mailcap-parse-mimetypes)
948 (let* ((default (or default
949 (mm-default-file-encoding name)
950 ;; Perhaps here we should check what the file
951 ;; looks like, and offer text/plain if it looks
953 "application/octet-stream"))
954 (string (completing-read
955 (format "Content type (default %s): " default)
956 (mapcar 'list (mailcap-mime-types)))))
957 (if (not (equal string ""))
961 (defun mml-minibuffer-read-description ()
962 (let ((description (read-string "One line description: ")))
963 (when (string-match "\\`[ \t]*\\'" description)
964 (setq description nil))
967 (defun mml-minibuffer-read-disposition (type &optional default)
968 (unless default (setq default
969 (if (and (string-match "\\`text/" type)
970 (not (string-match "\\`text/rtf\\'" type)))
973 (let ((disposition (completing-read
974 (format "Disposition (default %s): " default)
975 '(("attachment") ("inline") (""))
976 nil t nil nil default)))
977 (if (not (equal disposition ""))
981 (defun mml-quote-region (beg end)
982 "Quote the MML tags in the region."
986 ;; Temporarily narrow the region to defend from changes
988 (narrow-to-region beg end)
989 (goto-char (point-min))
991 (while (re-search-forward
992 "<#!*/?\\(multipart\\|part\\|external\\|mml\\)" nil t)
993 ;; Insert ! after the #.
994 (goto-char (+ (match-beginning 0) 2))
997 (defun mml-insert-tag (name &rest plist)
998 "Insert an MML tag described by NAME and PLIST."
1000 (setq name (symbol-name name)))
1003 (let ((key (pop plist))
1004 (value (pop plist)))
1006 ;; Quote VALUE if it contains suspicious characters.
1007 (when (string-match "[\"'\\~/*;() \t\n]" value)
1008 (setq value (with-output-to-string
1009 (let (print-escape-nonascii)
1011 (insert (format " %s=%s" key value)))))
1014 (defun mml-insert-empty-tag (name &rest plist)
1015 "Insert an empty MML tag described by NAME and PLIST."
1016 (when (symbolp name)
1017 (setq name (symbol-name name)))
1018 (apply #'mml-insert-tag name plist)
1019 (insert "<#/" name ">\n"))
1021 ;;; Attachment functions.
1023 (defun mml-attach-file (file &optional type description disposition)
1024 "Attach a file to the outgoing MIME message.
1025 The file is not inserted or encoded until you send the message with
1026 `\\[message-send-and-exit]' or `\\[message-send]'.
1028 FILE is the name of the file to attach. TYPE is its content-type, a
1029 string of the form \"type/subtype\". DESCRIPTION is a one-line
1030 description of the attachment."
1032 (let* ((file (mml-minibuffer-read-file "Attach file: "))
1033 (type (mml-minibuffer-read-type file))
1034 (description (mml-minibuffer-read-description))
1035 (disposition (mml-minibuffer-read-disposition type)))
1036 (list file type description disposition)))
1037 (mml-insert-empty-tag 'part
1040 'disposition (or disposition "attachment")
1041 'description description))
1043 (defun mml-attach-buffer (buffer &optional type description)
1044 "Attach a buffer to the outgoing MIME message.
1045 See `mml-attach-file' for details of operation."
1047 (let* ((buffer (read-buffer "Attach buffer: "))
1048 (type (mml-minibuffer-read-type buffer "text/plain"))
1049 (description (mml-minibuffer-read-description)))
1050 (list buffer type description)))
1051 (mml-insert-empty-tag 'part 'type type 'buffer buffer
1052 'disposition "attachment" 'description description))
1054 (defun mml-attach-external (file &optional type description)
1055 "Attach an external file into the buffer.
1056 FILE is an ange-ftp/efs specification of the part location.
1057 TYPE is the MIME type to use."
1059 (let* ((file (mml-minibuffer-read-file "Attach external file: "))
1060 (type (mml-minibuffer-read-type file))
1061 (description (mml-minibuffer-read-description)))
1062 (list file type description)))
1063 (mml-insert-empty-tag 'external 'type type 'name file
1064 'disposition "attachment" 'description description))
1066 (defun mml-insert-multipart (&optional type)
1067 (interactive (list (completing-read "Multipart type (default mixed): "
1068 '(("mixed") ("alternative") ("digest") ("parallel")
1069 ("signed") ("encrypted"))
1072 (setq type "mixed"))
1073 (mml-insert-empty-tag "multipart" 'type type)
1076 (defun mml-insert-part (&optional type)
1078 (list (mml-minibuffer-read-type "")))
1079 (mml-insert-tag 'part 'type type 'disposition "inline")
1082 (defun mml-preview-insert-mail-followup-to ()
1083 "Insert a Mail-Followup-To header before previewing an article.
1084 Should be adopted if code in `message-send-mail' is changed."
1085 (when (and (message-mail-p)
1086 (message-subscribed-p)
1087 (not (mail-fetch-field "mail-followup-to"))
1088 (message-make-mail-followup-to))
1089 (message-position-on-field "Mail-Followup-To" "X-Draft-From")
1090 (insert (message-make-mail-followup-to))))
1092 (defun mml-preview (&optional raw)
1093 "Display current buffer with Gnus, in a new buffer.
1094 If RAW, don't highlight the article."
1097 (let* ((buf (current-buffer))
1098 (message-options message-options)
1099 (message-this-is-mail (message-mail-p))
1100 (message-this-is-news (message-news-p))
1101 (message-posting-charset (or (gnus-setup-posting-charset
1103 (message-narrow-to-headers-or-head)
1104 (message-fetch-field "Newsgroups")))
1105 message-posting-charset)))
1106 (message-options-set-recipient)
1107 (pop-to-buffer (generate-new-buffer
1108 (concat (if raw "*Raw MIME preview of "
1109 "*MIME preview of ") (buffer-name))))
1110 (when (boundp 'gnus-buffers)
1111 (push (current-buffer) gnus-buffers))
1113 (insert-buffer-substring buf)
1114 (mml-preview-insert-mail-followup-to)
1115 (let ((message-deletable-headers (if (message-news-p)
1117 message-deletable-headers)))
1118 (message-generate-headers
1119 (copy-sequence (if (message-news-p)
1120 message-required-news-headers
1121 message-required-mail-headers))))
1122 (if (re-search-forward
1123 (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
1124 (replace-match "\n"))
1125 (let ((mail-header-separator ""));; mail-header-separator is removed.
1128 (when (fboundp 'set-buffer-multibyte)
1129 (let ((s (buffer-string)))
1130 ;; Insert the content into unibyte buffer.
1132 (mm-disable-multibyte)
1134 (let ((gnus-newsgroup-charset (car message-posting-charset))
1135 gnus-article-prepare-hook gnus-original-article-buffer)
1136 (run-hooks 'gnus-article-decode-hook)
1137 (let ((gnus-newsgroup-name "dummy")
1138 (gnus-newsrc-hashtb (or gnus-newsrc-hashtb
1139 (gnus-make-hashtable 5))))
1140 (gnus-article-prepare-display))))
1141 ;; Disable article-mode-map.
1143 (gnus-make-local-hook 'kill-buffer-hook)
1144 (add-hook 'kill-buffer-hook
1146 (mm-destroy-parts gnus-article-mime-handles)) nil t)
1147 (setq buffer-read-only t)
1148 (local-set-key "q" (lambda () (interactive) (kill-buffer nil)))
1149 (local-set-key "=" (lambda () (interactive) (delete-other-windows)))
1153 (widget-button-press (point))))
1154 (local-set-key gnus-mouse-2
1157 (widget-button-press (widget-event-point event) event)))
1158 (goto-char (point-min)))))
1160 (defun mml-validate ()
1161 "Validate the current MML document."
1165 (defun mml-tweak-part (cont)
1167 (let ((tweak (cdr (assq 'tweak cont)))
1172 (or (cdr (assoc tweak mml-tweak-function-alist))
1174 (mml-tweak-type-alist
1175 (let ((alist mml-tweak-type-alist)
1176 (type (or (cdr (assq 'type cont)) "text/plain")))
1178 (if (string-match (caar alist) type)
1179 (setq func (cdar alist)
1181 (setq alist (cdr alist)))))))
1185 (let ((alist mml-tweak-sexp-alist))
1187 (if (eval (caar alist))
1188 (funcall (cdar alist) cont))
1189 (setq alist (cdr alist)))))
1192 (defun mml-tweak-externalize-attachments (cont)
1193 "Tweak attached files as external parts."
1194 (let (filename-cons)
1195 (when (and (eq (car cont) 'part)
1196 (not (cdr (assq 'buffer cont)))
1197 (and (setq filename-cons (assq 'filename cont))
1198 (not (equal (cdr (assq 'nofile cont)) "yes"))))
1199 (setcar cont 'external)
1200 (setcar filename-cons 'name))))
1204 ;;; arch-tag: 583c96cf-1ffe-451b-a5e5-4733ae9ddd12
1205 ;;; mml.el ends here