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-make-local-hook "gnus-util")
38 (autoload 'message-fetch-field "message")
39 (autoload 'message-mark-active-p "message")
40 (autoload 'fill-flowed-encode "flow-fill")
41 (autoload 'message-posting-charset "message"))
44 (autoload 'dnd-get-local-file-name "dnd"))
46 (defcustom mml-content-type-parameters
47 '(name access-type expiration size permission format)
48 "*A list of acceptable parameters in MML tag.
49 These parameters are generated in Content-Type header if exists."
51 :type '(repeat (symbol :tag "Parameter"))
54 (defcustom mml-content-disposition-parameters
55 '(filename creation-date modification-date read-date)
56 "*A list of acceptable parameters in MML tag.
57 These parameters are generated in Content-Disposition header if exists."
59 :type '(repeat (symbol :tag "Parameter"))
62 (defcustom mml-insert-mime-headers-always nil
63 "If non-nil, always put Content-Type: text/plain at top of empty parts.
64 It is necessary to work against a bug in certain clients."
69 (defvar mml-tweak-type-alist nil
70 "A list of (TYPE . FUNCTION) for tweaking MML parts.
71 TYPE is a string containing a regexp to match the MIME type. FUNCTION
72 is a Lisp function which is called with the MML handle to tweak the
73 part. This variable is used only when no TWEAK parameter exists in
76 (defvar mml-tweak-function-alist nil
77 "A list of (NAME . FUNCTION) for tweaking MML parts.
78 NAME is a string containing the name of the TWEAK parameter in the MML
79 handle. FUNCTION is a Lisp function which is called with the MML
80 handle to tweak the part.")
82 (defvar mml-tweak-sexp-alist
83 '((mml-externalize-attachments . mml-tweak-externalize-attachments))
84 "A list of (SEXP . FUNCTION) for tweaking MML parts.
85 SEXP is an s-expression. If the evaluation of SEXP is non-nil, FUNCTION
86 is called. FUNCTION is a Lisp function which is called with the MML
87 handle to tweak the part.")
89 (defvar mml-externalize-attachments nil
90 "*If non-nil, local-file attachments are generated as external parts.")
92 (defvar mml-generate-multipart-alist nil
93 "*Alist of multipart generation functions.
94 Each entry has the form (NAME . FUNCTION), where
95 NAME is a string containing the name of the part (without the
96 leading \"/multipart/\"),
97 FUNCTION is a Lisp function which is called to generate the part.
99 The Lisp function has to supply the appropriate MIME headers and the
100 contents of this part.")
102 (defvar mml-syntax-table
103 (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table)))
104 (modify-syntax-entry ?\\ "/" table)
105 (modify-syntax-entry ?< "(" table)
106 (modify-syntax-entry ?> ")" table)
107 (modify-syntax-entry ?@ "w" table)
108 (modify-syntax-entry ?/ "w" table)
109 (modify-syntax-entry ?= " " table)
110 (modify-syntax-entry ?* " " table)
111 (modify-syntax-entry ?\; " " table)
112 (modify-syntax-entry ?\' " " table)
115 (defvar mml-boundary-function 'mml-make-boundary
116 "A function called to suggest a boundary.
117 The function may be called several times, and should try to make a new
118 suggestion each time. The function is called with one parameter,
119 which is a number that says how many times the function has been
120 called for this message.")
122 (defvar mml-confirmation-set nil
123 "A list of symbols, each of which disables some warning.
124 `unknown-encoding': always send messages contain characters with
125 unknown encoding; `use-ascii': always use ASCII for those characters
126 with unknown encoding; `multipart': always send messages with more than
129 (defvar mml-generate-default-type "text/plain"
130 "Content type by which the Content-Type header can be omitted.
131 The Content-Type header will not be put in the MIME part if the type
132 equals the value and there's no parameter (e.g. charset, format, etc.)
133 and `mml-insert-mime-headers-always' is nil. The value will be bound
134 to \"message/rfc822\" when encoding an article to be forwarded as a MIME
135 part. This is for the internal use, you should never modify the value.")
137 (defvar mml-buffer-list nil)
139 (defun mml-generate-new-buffer (name)
140 (let ((buf (generate-new-buffer name)))
141 (push buf mml-buffer-list)
144 (defun mml-destroy-buffers ()
145 (let (kill-buffer-hook)
146 (mapc 'kill-buffer mml-buffer-list)
147 (setq mml-buffer-list nil)))
150 "Parse the current buffer as an MML document."
152 (goto-char (point-min))
153 (with-syntax-table mml-syntax-table
156 (defun mml-parse-1 ()
157 "Parse the current buffer as an MML document."
158 (let (struct tag point contents charsets warn use-ascii no-markup-p raw)
159 (while (and (not (eobp))
160 (not (looking-at "<#/multipart")))
162 ((looking-at "<#secure")
163 ;; The secure part is essentially a meta-meta tag, which
164 ;; expands to either a part tag if there are no other parts in
165 ;; the document or a multipart tag if there are other parts
166 ;; included in the message
168 (taginfo (mml-read-tag))
169 (keyfile (cdr (assq 'keyfile taginfo)))
170 (certfile (cdr (assq 'certfile taginfo)))
171 (recipients (cdr (assq 'recipients taginfo)))
172 (sender (cdr (assq 'sender taginfo)))
173 (location (cdr (assq 'tag-location taginfo)))
174 (mode (cdr (assq 'mode taginfo)))
175 (method (cdr (assq 'method taginfo)))
178 (if (re-search-forward
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 keyfile "keyfile")
196 ,(if certfile "certfile")
198 ,(if recipients "recipients")
200 ,(if sender "sender")
203 (goto-char location)))
204 ((looking-at "<#multipart")
205 (push (nconc (mml-read-tag) (mml-parse-1)) struct))
206 ((looking-at "<#external")
207 (push (nconc (mml-read-tag) (list (cons 'contents (mml-read-part))))
210 (if (or (looking-at "<#part") (looking-at "<#mml"))
211 (setq tag (mml-read-tag)
214 (setq tag (list 'part '(type . "text/plain"))
217 (setq raw (cdr (assq 'raw tag))
219 contents (mml-read-part (eq 'mml (car tag)))
224 (intern (downcase (cdr (assq 'charset tag))))))
226 (mm-find-mime-charset-region point (point)
228 (when (and (not raw) (memq nil charsets))
229 (if (or (memq 'unknown-encoding mml-confirmation-set)
230 (message-options-get 'unknown-encoding)
232 Message contains characters with unknown encoding. Really send? ")
233 (message-options-set 'unknown-encoding t)))
235 (or (memq 'use-ascii mml-confirmation-set)
236 (message-options-get 'use-ascii)
237 (and (y-or-n-p "Use ASCII as charset? ")
238 (message-options-set 'use-ascii t))))
239 (setq charsets (delq nil charsets))
241 (error "Edit your message to remove those characters")))
244 (< (length charsets) 2))
245 (if (or (not no-markup-p)
246 (string-match "[^ \t\r\n]" contents))
247 ;; Don't create blank parts.
248 (push (nconc tag (list (cons 'contents contents)))
250 (let ((nstruct (mml-parse-singlepart-with-multiple-charsets
251 tag point (point) use-ascii)))
253 (not (memq 'multipart mml-confirmation-set))
254 (not (message-options-get 'multipart))
255 (not (and (y-or-n-p (format "\
256 A message part needs to be split into %d charset parts. Really send? "
258 (message-options-set 'multipart t))))
259 (error "Edit your message to use only one charset"))
260 (setq struct (nconc nstruct struct)))))))
265 (defun mml-parse-singlepart-with-multiple-charsets
266 (orig-tag beg end &optional use-ascii)
269 (narrow-to-region beg end)
270 (goto-char (point-min))
271 (let ((current (or (mm-mime-charset (mm-charset-after))
272 (and use-ascii 'us-ascii)))
273 charset struct space newline paragraph)
275 (setq charset (mm-mime-charset (mm-charset-after)))
277 ;; The charset remains the same.
278 ((eq charset 'us-ascii))
279 ((or (and use-ascii (not charset))
280 (eq charset current))
284 ;; The initial charset was ascii.
285 ((eq current 'us-ascii)
286 (setq current charset
290 ;; We have a change in charsets.
294 (list (cons 'contents
295 (buffer-substring-no-properties
296 beg (or paragraph newline space (point))))))
298 (setq beg (or paragraph newline space (point))
303 ;; Compute places where it might be nice to break the part.
305 ((memq (following-char) '(? ?\t))
306 (setq space (1+ (point))))
307 ((and (eq (following-char) ?\n)
309 (eq (char-after (1- (point))) ?\n))
310 (setq paragraph (point)))
311 ((eq (following-char) ?\n)
312 (setq newline (1+ (point)))))
314 ;; Do the final part.
315 (unless (= beg (point))
316 (push (append orig-tag
317 (list (cons 'contents
318 (buffer-substring-no-properties
323 (defun mml-read-tag ()
324 "Read a tag and return the contents."
325 (let ((orig-point (point))
326 contents name elem val)
328 (setq name (buffer-substring-no-properties
329 (point) (progn (forward-sexp 1) (point))))
330 (skip-chars-forward " \t\n")
331 (while (not (looking-at ">[ \t]*\n?"))
332 (setq elem (buffer-substring-no-properties
333 (point) (progn (forward-sexp 1) (point))))
334 (skip-chars-forward "= \t\n")
335 (setq val (buffer-substring-no-properties
336 (point) (progn (forward-sexp 1) (point))))
337 (when (string-match "^\"\\(.*\\)\"$" val)
338 (setq val (match-string 1 val)))
339 (push (cons (intern elem) val) contents)
340 (skip-chars-forward " \t\n"))
341 (goto-char (match-end 0))
342 ;; Don't skip the leading space.
343 ;;(skip-chars-forward " \t\n")
344 ;; Put the tag location into the returned contents
345 (setq contents (append (list (cons 'tag-location orig-point)) contents))
346 (cons (intern name) (nreverse contents))))
348 (defun mml-buffer-substring-no-properties-except-hard-newlines (start end)
349 (let ((str (buffer-substring-no-properties start end))
350 (bufstart start) tmp)
351 (while (setq tmp (text-property-any start end 'hard 't))
352 (set-text-properties (- tmp bufstart) (- tmp bufstart -1)
354 (setq start (1+ tmp)))
357 (defun mml-read-part (&optional mml)
358 "Return the buffer up till the next part, multipart or closing part or multipart.
359 If MML is non-nil, return the buffer up till the correspondent mml tag."
360 (let ((beg (point)) (count 1))
361 ;; If the tag ended at the end of the line, we go to the next line.
362 (when (looking-at "[ \t]*\n")
366 (while (and (> count 0) (not (eobp)))
367 (if (re-search-forward "<#\\(/\\)?mml." nil t)
368 (setq count (+ count (if (match-beginning 1) -1 1)))
369 (goto-char (point-max))))
370 (mml-buffer-substring-no-properties-except-hard-newlines
373 (match-beginning 0))))
374 (if (re-search-forward
375 "<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)." nil t)
377 (mml-buffer-substring-no-properties-except-hard-newlines
378 beg (match-beginning 0))
379 (if (or (not (match-beginning 1))
380 (equal (match-string 2) "multipart"))
381 (goto-char (match-beginning 0))
382 (when (looking-at "[ \t]*\n")
384 (mml-buffer-substring-no-properties-except-hard-newlines
385 beg (goto-char (point-max)))))))
387 (defvar mml-boundary nil)
388 (defvar mml-base-boundary "-=-=")
389 (defvar mml-multipart-number 0)
391 (defun mml-generate-mime ()
392 "Generate a MIME message based on the current MML document."
393 (let ((cont (mml-parse))
394 (mml-multipart-number mml-multipart-number))
398 (if (and (consp (car cont))
400 (mml-generate-mime-1 (car cont))
401 (mml-generate-mime-1 (nconc (list 'multipart '(type . "mixed"))
405 (defun mml-generate-mime-1 (cont)
406 (let ((mm-use-ultra-safe-encoding
407 (or mm-use-ultra-safe-encoding (assq 'sign cont))))
409 (narrow-to-region (point) (point))
410 (mml-tweak-part cont)
412 ((or (eq (car cont) 'part) (eq (car cont) 'mml))
413 (let* ((raw (cdr (assq 'raw cont)))
414 (filename (cdr (assq 'filename cont)))
415 (type (or (cdr (assq 'type cont))
416 (and filename (mm-default-file-encoding filename))
417 "application/octet-stream"))
418 (charset (cdr (assq 'charset cont)))
419 (coding (mm-charset-to-coding-system charset))
420 encoding flowed coded)
421 (cond ((eq coding 'ascii)
425 (setq charset (intern (downcase charset)))))
427 (member (car (split-string type "/")) '("text" "message")))
431 ((cdr (assq 'buffer cont))
432 (insert-buffer-substring (cdr (assq 'buffer cont))))
434 (not (equal (cdr (assq 'nofile cont)) "yes")))
435 (let ((coding-system-for-read coding))
436 (mm-insert-file-contents filename)))
437 ((eq 'mml (car cont))
438 (insert (cdr (assq 'contents cont))))
441 (narrow-to-region (point) (point))
442 (insert (cdr (assq 'contents cont)))
443 ;; Remove quotes from quoted tags.
444 (goto-char (point-min))
445 (while (re-search-forward
446 "<#!+/?\\(part\\|multipart\\|external\\|mml\\)"
448 (delete-region (+ (match-beginning 0) 2)
449 (+ (match-beginning 0) 3))))))
451 ((eq (car cont) 'mml)
452 (let ((mml-boundary (mml-compute-boundary cont))
453 ;; It is necessary for the case where this
454 ;; function is called recursively since
455 ;; `m-g-d-t' will be bound to "message/rfc822"
456 ;; when encoding an article to be forwarded.
457 (mml-generate-default-type "text/plain"))
459 (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b")))
460 ;; ignore 0x1b, it is part of iso-2022-jp
461 (setq encoding (mm-body-7-or-8))))
462 ((string= (car (split-string type "/")) "message")
463 (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b")))
464 ;; ignore 0x1b, it is part of iso-2022-jp
465 (setq encoding (mm-body-7-or-8))))
467 ;; Only perform format=flowed filling on text/plain
468 ;; parts where there either isn't a format parameter
469 ;; in the mml tag or it says "flowed" and there
470 ;; actually are hard newlines in the text.
471 (let (use-hard-newlines)
472 (when (and (string= type "text/plain")
473 (not (string= (cdr (assq 'sign cont)) "pgp"))
474 (or (null (assq 'format cont))
475 (string= (cdr (assq 'format cont))
477 (setq use-hard-newlines
479 (point-min) (point-max) 'hard 't)))
481 ;; Indicate that `mml-insert-mime-headers' should
482 ;; insert a "; format=flowed" string unless the
483 ;; user has already specified it.
484 (setq flowed (null (assq 'format cont)))))
485 (setq charset (mm-encode-body charset))
486 (setq encoding (mm-body-encoding
487 charset (cdr (assq 'encoding cont))))))
488 (setq coded (buffer-string)))
489 (mml-insert-mime-headers cont type charset encoding flowed)
492 (mm-with-unibyte-buffer
494 ((cdr (assq 'buffer cont))
495 (insert (with-current-buffer (cdr (assq 'buffer cont))
496 (mm-with-unibyte-current-buffer
499 (not (equal (cdr (assq 'nofile cont)) "yes")))
500 (let ((coding-system-for-read mm-binary-coding-system))
501 (mm-insert-file-contents filename nil nil nil nil t))
503 (setq charset (mm-coding-system-to-mime-charset
504 (mm-find-buffer-file-coding-system
507 (insert (cdr (assq 'contents cont)))))
508 (setq encoding (mm-encode-buffer type)
509 coded (mm-string-as-multibyte (buffer-string))))
510 (mml-insert-mime-headers cont type charset encoding nil)
512 (mm-with-unibyte-current-buffer
514 ((eq (car cont) 'external)
515 (insert "Content-Type: message/external-body")
516 (let ((parameters (mml-parameter-string
517 cont '(expiration size permission)))
518 (name (cdr (assq 'name cont)))
519 (url (cdr (assq 'url cont))))
521 (setq name (mml-parse-file-name name))
523 (mml-insert-parameter
524 (mail-header-encode-parameter "name" name)
525 "access-type=local-file")
526 (mml-insert-parameter
527 (mail-header-encode-parameter
528 "name" (file-name-nondirectory (nth 2 name)))
529 (mail-header-encode-parameter "site" (nth 1 name))
530 (mail-header-encode-parameter
531 "directory" (file-name-directory (nth 2 name))))
532 (mml-insert-parameter
533 (concat "access-type="
534 (if (member (nth 0 name) '("ftp@" "anonymous@"))
538 (mml-insert-parameter
539 (mail-header-encode-parameter "url" url)
542 (mml-insert-parameter-string
543 cont '(expiration size permission)))
545 (insert "Content-Type: "
546 (or (cdr (assq 'type cont))
547 (and name (mm-default-file-encoding name))
548 "application/octet-stream")
550 (insert "Content-ID: " (message-make-message-id) "\n")
551 (insert "Content-Transfer-Encoding: "
552 (or (cdr (assq 'encoding cont)) "binary"))
554 (insert (or (cdr (assq 'contents cont))))
556 ((eq (car cont) 'multipart)
557 (let* ((type (or (cdr (assq 'type cont)) "mixed"))
558 (mml-generate-default-type (if (equal type "digest")
561 (handler (assoc type mml-generate-multipart-alist)))
563 (funcall (cdr handler) cont)
564 ;; No specific handler. Use default one.
565 (let ((mml-boundary (mml-compute-boundary cont)))
566 (insert (format "Content-Type: multipart/%s; boundary=\"%s\""
568 (if (cdr (assq 'start cont))
569 (format "; start=\"%s\"\n" (cdr (assq 'start cont)))
571 (let ((cont cont) part)
572 (while (setq part (pop cont))
573 ;; Skip `multipart' and attributes.
574 (when (and (consp part) (consp (cdr part)))
575 (insert "\n--" mml-boundary "\n")
576 (mml-generate-mime-1 part))))
577 (insert "\n--" mml-boundary "--\n")))))
579 (error "Invalid element: %S" cont)))
580 ;; handle sign & encrypt tags in a semi-smart way.
581 (let ((sign-item (assoc (cdr (assq 'sign cont)) mml-sign-alist))
582 (encrypt-item (assoc (cdr (assq 'encrypt cont))
585 (when (or sign-item encrypt-item)
586 (when (setq sender (cdr (assq 'sender cont)))
587 (message-options-set 'mml-sender sender)
588 (message-options-set 'message-sender sender))
589 (if (setq recipients (cdr (assq 'recipients cont)))
590 (message-options-set 'message-recipients recipients))
591 (let ((style (mml-signencrypt-style
592 (first (or sign-item encrypt-item)))))
593 ;; check if: we're both signing & encrypting, both methods
594 ;; are the same (why would they be different?!), and that
595 ;; the signencrypt style allows for combined operation.
596 (if (and sign-item encrypt-item (equal (first sign-item)
597 (first encrypt-item))
598 (equal style 'combined))
599 (funcall (nth 1 encrypt-item) cont t)
600 ;; otherwise, revert to the old behavior.
602 (funcall (nth 1 sign-item) cont))
604 (funcall (nth 1 encrypt-item) cont)))))))))
606 (defun mml-compute-boundary (cont)
607 "Return a unique boundary that does not exist in CONT."
608 (let ((mml-boundary (funcall mml-boundary-function
609 (incf mml-multipart-number))))
610 ;; This function tries again and again until it has found
611 ;; a unique boundary.
612 (while (not (catch 'not-unique
613 (mml-compute-boundary-1 cont))))
616 (defun mml-compute-boundary-1 (cont)
619 ((eq (car cont) 'part)
622 ((cdr (assq 'buffer cont))
623 (insert-buffer-substring (cdr (assq 'buffer cont))))
624 ((and (setq filename (cdr (assq 'filename cont)))
625 (not (equal (cdr (assq 'nofile cont)) "yes")))
626 (mm-insert-file-contents filename nil nil nil nil t))
628 (insert (cdr (assq 'contents cont)))))
629 (goto-char (point-min))
630 (when (re-search-forward (concat "^--" (regexp-quote mml-boundary))
632 (setq mml-boundary (funcall mml-boundary-function
633 (incf mml-multipart-number)))
634 (throw 'not-unique nil))))
635 ((eq (car cont) 'multipart)
636 (mapc 'mml-compute-boundary-1 (cddr cont))))
639 (defun mml-make-boundary (number)
640 (concat (make-string (% number 60) ?=)
646 (defun mml-insert-mime-headers (cont type charset encoding flowed)
647 (let (parameters id disposition description)
649 (mml-parameter-string
650 cont mml-content-type-parameters))
654 (not (equal type mml-generate-default-type))
655 mml-insert-mime-headers-always)
656 (when (consp charset)
658 "Can't encode a part with several charsets"))
659 (insert "Content-Type: " type)
661 (insert "; " (mail-header-encode-parameter
662 "charset" (symbol-name charset))))
664 (insert "; format=flowed"))
666 (mml-insert-parameter-string
667 cont mml-content-type-parameters))
669 (when (setq id (cdr (assq 'id cont)))
670 (insert "Content-ID: " id "\n"))
672 (mml-parameter-string
673 cont mml-content-disposition-parameters))
674 (when (or (setq disposition (cdr (assq 'disposition cont)))
676 (insert "Content-Disposition: " (or disposition "inline"))
678 (mml-insert-parameter-string
679 cont mml-content-disposition-parameters))
681 (unless (eq encoding '7bit)
682 (insert (format "Content-Transfer-Encoding: %s\n" encoding)))
683 (when (setq description (cdr (assq 'description cont)))
684 (insert "Content-Description: "
685 (mail-encode-encoded-word-string description) "\n"))))
687 (defun mml-parameter-string (cont types)
690 (while (setq type (pop types))
691 (when (setq value (cdr (assq type cont)))
692 ;; Strip directory component from the filename parameter.
693 (when (eq type 'filename)
694 (setq value (file-name-nondirectory value)))
695 (setq string (concat string "; "
696 (mail-header-encode-parameter
697 (symbol-name type) value)))))
698 (when (not (zerop (length string)))
701 (defun mml-insert-parameter-string (cont types)
703 (while (setq type (pop types))
704 (when (setq value (cdr (assq type cont)))
705 ;; Strip directory component from the filename parameter.
706 (when (eq type 'filename)
707 (setq value (file-name-nondirectory value)))
708 (mml-insert-parameter
709 (mail-header-encode-parameter
710 (symbol-name type) value))))))
713 (defvar ange-ftp-name-format)
714 (defvar efs-path-regexp))
715 (defun mml-parse-file-name (path)
716 (if (if (boundp 'efs-path-regexp)
717 (string-match efs-path-regexp path)
718 (if (boundp 'ange-ftp-name-format)
719 (string-match (car ange-ftp-name-format) path)))
720 (list (match-string 1 path) (match-string 2 path)
721 (substring path (1+ (match-end 2))))
724 (defun mml-insert-buffer (buffer)
725 "Insert BUFFER at point and quote any MML markup."
727 (narrow-to-region (point) (point))
728 (insert-buffer-substring buffer)
729 (mml-quote-region (point-min) (point-max))
730 (goto-char (point-max))))
733 ;;; Transforming MIME to MML
736 (defun mime-to-mml (&optional handles)
737 "Translate the current buffer (which should be a message) into MML.
738 If HANDLES is non-nil, use it instead reparsing the buffer."
739 ;; First decode the head.
741 (message-narrow-to-head)
742 (let ((rfc2047-quote-decoded-words-containing-tspecials t))
743 (mail-decode-encoded-word-region (point-min) (point-max))))
745 (setq handles (mm-dissect-buffer t)))
746 (goto-char (point-min))
747 (search-forward "\n\n" nil t)
748 (delete-region (point) (point-max))
749 (if (stringp (car handles))
750 (mml-insert-mime handles)
751 (mml-insert-mime handles t))
752 (mm-destroy-parts handles)
754 (message-narrow-to-head)
755 ;; Remove them, they are confusing.
756 (message-remove-header "Content-Type")
757 (message-remove-header "MIME-Version")
758 (message-remove-header "Content-Disposition")
759 (message-remove-header "Content-Transfer-Encoding")))
761 (defun mml-to-mime ()
762 "Translate the current buffer from MML to MIME."
763 (message-encode-message-body)
765 (message-narrow-to-headers-or-head)
766 ;; Skip past any From_ headers.
767 (while (looking-at "From ")
769 (let ((mail-parse-charset message-default-charset))
770 (mail-encode-encoded-word-buffer))))
772 (defun mml-insert-mime (handle &optional no-markup)
773 (let (textp buffer mmlp)
774 ;; Determine type and stuff.
775 (unless (stringp (car handle))
776 (unless (setq textp (equal (mm-handle-media-supertype handle) "text"))
778 (set-buffer (setq buffer (mml-generate-new-buffer " *mml*")))
779 (mm-insert-part handle)
780 (if (setq mmlp (equal (mm-handle-media-type handle)
784 (mml-insert-mml-markup handle nil t t)
785 (unless (and no-markup
786 (equal (mm-handle-media-type handle) "text/plain"))
787 (mml-insert-mml-markup handle buffer textp)))
790 (insert-buffer-substring buffer)
791 (goto-char (point-max))
792 (insert "<#/mml>\n"))
793 ((stringp (car handle))
794 (mapcar 'mml-insert-mime (cdr handle))
795 (insert "<#/multipart>\n"))
797 (let ((charset (mail-content-type-get
798 (mm-handle-type handle) 'charset))
800 (if (eq charset 'gnus-decoded)
801 (mm-insert-part handle)
802 (insert (mm-decode-string (mm-get-part handle) charset)))
803 (mml-quote-region start (point)))
804 (goto-char (point-max)))
806 (insert "<#/part>\n")))))
808 (defun mml-insert-mml-markup (handle &optional buffer nofile mmlp)
809 "Take a MIME handle and insert an MML tag."
810 (if (stringp (car handle))
812 (insert "<#multipart type=" (mm-handle-media-subtype handle))
813 (let ((start (mm-handle-multipart-ctl-parameter handle 'start)))
815 (insert " start=\"" start "\"")))
818 (insert "<#mml type=" (mm-handle-media-type handle))
819 (insert "<#part type=" (mm-handle-media-type handle)))
820 (dolist (elem (append (cdr (mm-handle-type handle))
821 (cdr (mm-handle-disposition handle))))
822 (unless (symbolp (cdr elem))
823 (insert " " (symbol-name (car elem)) "=\"" (cdr elem) "\"")))
824 (when (mm-handle-id handle)
825 (insert " id=\"" (mm-handle-id handle) "\""))
826 (when (mm-handle-disposition handle)
827 (insert " disposition=" (car (mm-handle-disposition handle))))
829 (insert " buffer=\"" (buffer-name buffer) "\""))
831 (insert " nofile=yes"))
832 (when (mm-handle-description handle)
833 (insert " description=\"" (mm-handle-description handle) "\""))
836 (defun mml-insert-parameter (&rest parameters)
837 "Insert PARAMETERS in a nice way."
838 (dolist (param parameters)
840 (let ((point (point)))
842 (when (> (current-column) 71)
848 ;;; Mode for inserting and editing MML forms
852 (let ((sign (make-sparse-keymap))
853 (encrypt (make-sparse-keymap))
854 (signpart (make-sparse-keymap))
855 (encryptpart (make-sparse-keymap))
856 (map (make-sparse-keymap))
857 (main (make-sparse-keymap)))
858 (define-key sign "p" 'mml-secure-message-sign-pgpmime)
859 (define-key sign "o" 'mml-secure-message-sign-pgp)
860 (define-key sign "s" 'mml-secure-message-sign-smime)
861 (define-key signpart "p" 'mml-secure-sign-pgpmime)
862 (define-key signpart "o" 'mml-secure-sign-pgp)
863 (define-key signpart "s" 'mml-secure-sign-smime)
864 (define-key encrypt "p" 'mml-secure-message-encrypt-pgpmime)
865 (define-key encrypt "o" 'mml-secure-message-encrypt-pgp)
866 (define-key encrypt "s" 'mml-secure-message-encrypt-smime)
867 (define-key encryptpart "p" 'mml-secure-encrypt-pgpmime)
868 (define-key encryptpart "o" 'mml-secure-encrypt-pgp)
869 (define-key encryptpart "s" 'mml-secure-encrypt-smime)
870 (define-key map "\C-n" 'mml-unsecure-message)
871 (define-key map "f" 'mml-attach-file)
872 (define-key map "b" 'mml-attach-buffer)
873 (define-key map "e" 'mml-attach-external)
874 (define-key map "q" 'mml-quote-region)
875 (define-key map "m" 'mml-insert-multipart)
876 (define-key map "p" 'mml-insert-part)
877 (define-key map "v" 'mml-validate)
878 (define-key map "P" 'mml-preview)
879 (define-key map "s" sign)
880 (define-key map "S" signpart)
881 (define-key map "c" encrypt)
882 (define-key map "C" encryptpart)
883 ;;(define-key map "n" 'mml-narrow-to-part)
884 ;; `M-m' conflicts with `back-to-indentation'.
885 ;; (define-key main "\M-m" map)
886 (define-key main "\C-c\C-m" map)
890 mml-menu mml-mode-map ""
892 ["Attach File..." mml-attach-file
893 ,@(if (featurep 'xemacs) '(t)
894 '(:help "Attach a file at point"))]
895 ["Attach Buffer..." mml-attach-buffer t]
896 ["Attach External..." mml-attach-external t]
897 ["Insert Part..." mml-insert-part t]
898 ["Insert Multipart..." mml-insert-multipart t]
899 ["PGP/MIME Sign" mml-secure-message-sign-pgpmime t]
900 ["PGP/MIME Encrypt" mml-secure-message-encrypt-pgpmime t]
901 ["PGP Sign" mml-secure-message-sign-pgp t]
902 ["PGP Encrypt" mml-secure-message-encrypt-pgp t]
903 ["S/MIME Sign" mml-secure-message-sign-smime t]
904 ["S/MIME Encrypt" mml-secure-message-encrypt-smime t]
906 ["PGP/MIME Sign Part" mml-secure-sign-pgpmime t]
907 ["PGP/MIME Encrypt Part" mml-secure-encrypt-pgpmime t]
908 ["PGP Sign Part" mml-secure-sign-pgp t]
909 ["PGP Encrypt Part" mml-secure-encrypt-pgp t]
910 ["S/MIME Sign Part" mml-secure-sign-smime t]
911 ["S/MIME Encrypt Part" mml-secure-encrypt-smime t])
912 ["Encrypt/Sign off" mml-unsecure-message t]
913 ;;["Narrow" mml-narrow-to-part t]
914 ["Quote MML" mml-quote-region
915 :active (message-mark-active-p)
916 ,@(if (featurep 'xemacs) nil
917 '(:help "Quote MML tags in region"))]
918 ["Validate MML" mml-validate t]
919 ["Preview" mml-preview t]))
922 "Minor mode for editing MML.")
924 (defun mml-mode (&optional arg)
925 "Minor mode for editing MML.
926 MML is the MIME Meta Language, a minor mode for composing MIME articles.
927 See Info node `(emacs-mime)Composing'.
931 (when (set (make-local-variable 'mml-mode)
932 (if (null arg) (not mml-mode)
933 (> (prefix-numeric-value arg) 0)))
934 (add-minor-mode 'mml-mode " MML" mml-mode-map)
935 (easy-menu-add mml-menu mml-mode-map)
936 (when (boundp 'dnd-protocol-alist)
937 (set (make-local-variable 'dnd-protocol-alist)
938 '(("^file:///" . mml-dnd-attach-file)
939 ("^file://" . dnd-open-file)
940 ("^file:" . mml-dnd-attach-file))))
941 (run-hooks 'mml-mode-hook)))
944 ;;; Helper functions for reading MIME stuff from the minibuffer and
945 ;;; inserting stuff to the buffer.
948 (defun mml-minibuffer-read-file (prompt)
949 (let* ((completion-ignored-extensions nil)
950 (file (read-file-name prompt nil nil t)))
951 ;; Prevent some common errors. This is inspired by similar code in
953 (when (file-directory-p file)
954 (error "%s is a directory, cannot attach" file))
955 (unless (file-exists-p file)
956 (error "No such file: %s" file))
957 (unless (file-readable-p file)
958 (error "Permission denied: %s" file))
961 (defun mml-minibuffer-read-type (name &optional default)
962 (mailcap-parse-mimetypes)
963 (let* ((default (or default
964 (mm-default-file-encoding name)
965 ;; Perhaps here we should check what the file
966 ;; looks like, and offer text/plain if it looks
968 "application/octet-stream"))
969 (string (completing-read
970 (format "Content type (default %s): " default)
971 (mapcar 'list (mailcap-mime-types)))))
972 (if (not (equal string ""))
976 (defun mml-minibuffer-read-description ()
977 (let ((description (read-string "One line description: ")))
978 (when (string-match "\\`[ \t]*\\'" description)
979 (setq description nil))
982 (defun mml-minibuffer-read-disposition (type &optional default)
983 (unless default (setq default
984 (if (and (string-match "\\`text/" type)
985 (not (string-match "\\`text/rtf\\'" type)))
988 (let ((disposition (completing-read
989 (format "Disposition (default %s): " default)
990 '(("attachment") ("inline") (""))
991 nil t nil nil default)))
992 (if (not (equal disposition ""))
996 (defun mml-quote-region (beg end)
997 "Quote the MML tags in the region."
1001 ;; Temporarily narrow the region to defend from changes
1002 ;; invalidating END.
1003 (narrow-to-region beg end)
1004 (goto-char (point-min))
1006 (while (re-search-forward
1007 "<#!*/?\\(multipart\\|part\\|external\\|mml\\)" nil t)
1008 ;; Insert ! after the #.
1009 (goto-char (+ (match-beginning 0) 2))
1012 (defun mml-insert-tag (name &rest plist)
1013 "Insert an MML tag described by NAME and PLIST."
1014 (when (symbolp name)
1015 (setq name (symbol-name name)))
1018 (let ((key (pop plist))
1019 (value (pop plist)))
1021 ;; Quote VALUE if it contains suspicious characters.
1022 (when (string-match "[\"'\\~/*;() \t\n]" value)
1023 (setq value (with-output-to-string
1024 (let (print-escape-nonascii)
1026 (insert (format " %s=%s" key value)))))
1029 (defun mml-insert-empty-tag (name &rest plist)
1030 "Insert an empty MML tag described by NAME and PLIST."
1031 (when (symbolp name)
1032 (setq name (symbol-name name)))
1033 (apply #'mml-insert-tag name plist)
1034 (insert "<#/" name ">\n"))
1036 ;;; Attachment functions.
1038 (defun mml-attach-file (file &optional type description disposition)
1039 "Attach a file to the outgoing MIME message.
1040 The file is not inserted or encoded until you send the message with
1041 `\\[message-send-and-exit]' or `\\[message-send]'.
1043 FILE is the name of the file to attach. TYPE is its content-type, a
1044 string of the form \"type/subtype\". DESCRIPTION is a one-line
1045 description of the attachment."
1047 (let* ((file (mml-minibuffer-read-file "Attach file: "))
1048 (type (mml-minibuffer-read-type file))
1049 (description (mml-minibuffer-read-description))
1050 (disposition (mml-minibuffer-read-disposition type)))
1051 (list file type description disposition)))
1052 (mml-insert-empty-tag 'part
1055 'disposition (or disposition "attachment")
1056 'description description))
1058 (defun mml-dnd-attach-file (uri action)
1059 "Attach a drag and drop file."
1060 (let ((file (dnd-get-local-file-name uri t)))
1061 (when (and file (file-regular-p file))
1062 (let* ((type (mml-minibuffer-read-type file))
1063 (description (mml-minibuffer-read-description))
1064 (disposition (mml-minibuffer-read-disposition type)))
1065 (mml-attach-file file type description disposition)))))
1067 (defun mml-attach-buffer (buffer &optional type description)
1068 "Attach a buffer to the outgoing MIME message.
1069 See `mml-attach-file' for details of operation."
1071 (let* ((buffer (read-buffer "Attach buffer: "))
1072 (type (mml-minibuffer-read-type buffer "text/plain"))
1073 (description (mml-minibuffer-read-description)))
1074 (list buffer type description)))
1075 (mml-insert-empty-tag 'part 'type type 'buffer buffer
1076 'disposition "attachment" 'description description))
1078 (defun mml-attach-external (file &optional type description)
1079 "Attach an external file into the buffer.
1080 FILE is an ange-ftp/efs specification of the part location.
1081 TYPE is the MIME type to use."
1083 (let* ((file (mml-minibuffer-read-file "Attach external file: "))
1084 (type (mml-minibuffer-read-type file))
1085 (description (mml-minibuffer-read-description)))
1086 (list file type description)))
1087 (mml-insert-empty-tag 'external 'type type 'name file
1088 'disposition "attachment" 'description description))
1090 (defun mml-insert-multipart (&optional type)
1091 (interactive (list (completing-read "Multipart type (default mixed): "
1092 '(("mixed") ("alternative") ("digest") ("parallel")
1093 ("signed") ("encrypted"))
1096 (setq type "mixed"))
1097 (mml-insert-empty-tag "multipart" 'type type)
1100 (defun mml-insert-part (&optional type)
1102 (list (mml-minibuffer-read-type "")))
1103 (mml-insert-tag 'part 'type type 'disposition "inline")
1106 (defun mml-preview-insert-mail-followup-to ()
1107 "Insert a Mail-Followup-To header before previewing an article.
1108 Should be adopted if code in `message-send-mail' is changed."
1109 (when (and (message-mail-p)
1110 (message-subscribed-p)
1111 (not (mail-fetch-field "mail-followup-to"))
1112 (message-make-mail-followup-to))
1113 (message-position-on-field "Mail-Followup-To" "X-Draft-From")
1114 (insert (message-make-mail-followup-to))))
1116 (defvar mml-preview-buffer nil)
1118 (defun mml-preview (&optional raw)
1119 "Display current buffer with Gnus, in a new buffer.
1120 If RAW, don't highlight the article."
1122 (setq mml-preview-buffer (generate-new-buffer
1123 (concat (if raw "*Raw MIME preview of "
1124 "*MIME preview of ") (buffer-name))))
1126 (let* ((buf (current-buffer))
1127 (message-options message-options)
1128 (message-this-is-mail (message-mail-p))
1129 (message-this-is-news (message-news-p))
1130 (message-posting-charset (or (gnus-setup-posting-charset
1132 (message-narrow-to-headers-or-head)
1133 (message-fetch-field "Newsgroups")))
1134 message-posting-charset)))
1135 (message-options-set-recipient)
1136 (when (boundp 'gnus-buffers)
1137 (push mml-preview-buffer gnus-buffers))
1140 (set-buffer mml-preview-buffer)
1142 (insert-buffer-substring buf))
1143 (mml-preview-insert-mail-followup-to)
1144 (let ((message-deletable-headers (if (message-news-p)
1146 message-deletable-headers)))
1147 (message-generate-headers
1148 (copy-sequence (if (message-news-p)
1149 message-required-news-headers
1150 message-required-mail-headers))))
1151 (if (re-search-forward
1152 (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
1153 (replace-match "\n"))
1154 (let ((mail-header-separator ""));; mail-header-separator is removed.
1155 (message-sort-headers)
1158 (when (fboundp 'set-buffer-multibyte)
1159 (let ((s (buffer-string)))
1160 ;; Insert the content into unibyte buffer.
1162 (mm-disable-multibyte)
1164 (let ((gnus-newsgroup-charset (car message-posting-charset))
1165 gnus-article-prepare-hook gnus-original-article-buffer)
1166 (run-hooks 'gnus-article-decode-hook)
1167 (let ((gnus-newsgroup-name "dummy")
1168 (gnus-newsrc-hashtb (or gnus-newsrc-hashtb
1169 (gnus-make-hashtable 5))))
1170 (gnus-article-prepare-display))))
1171 ;; Disable article-mode-map.
1173 (gnus-make-local-hook 'kill-buffer-hook)
1174 (add-hook 'kill-buffer-hook
1176 (mm-destroy-parts gnus-article-mime-handles)) nil t)
1177 (setq buffer-read-only t)
1178 (local-set-key "q" (lambda () (interactive) (kill-buffer nil)))
1179 (local-set-key "=" (lambda () (interactive) (delete-other-windows)))
1183 (widget-button-press (point))))
1184 (local-set-key gnus-mouse-2
1187 (widget-button-press (widget-event-point event) event)))
1188 (goto-char (point-min))))
1189 (if (and (boundp 'gnus-buffer-configuration)
1190 (assq 'mml-preview gnus-buffer-configuration))
1191 (let ((gnus-message-buffer (current-buffer)))
1192 (gnus-configure-windows 'mml-preview))
1193 (pop-to-buffer mml-preview-buffer)))
1195 (defun mml-validate ()
1196 "Validate the current MML document."
1200 (defun mml-tweak-part (cont)
1202 (let ((tweak (cdr (assq 'tweak cont)))
1207 (or (cdr (assoc tweak mml-tweak-function-alist))
1209 (mml-tweak-type-alist
1210 (let ((alist mml-tweak-type-alist)
1211 (type (or (cdr (assq 'type cont)) "text/plain")))
1213 (if (string-match (caar alist) type)
1214 (setq func (cdar alist)
1216 (setq alist (cdr alist)))))))
1220 (let ((alist mml-tweak-sexp-alist))
1222 (if (eval (caar alist))
1223 (funcall (cdar alist) cont))
1224 (setq alist (cdr alist)))))
1227 (defun mml-tweak-externalize-attachments (cont)
1228 "Tweak attached files as external parts."
1229 (let (filename-cons)
1230 (when (and (eq (car cont) 'part)
1231 (not (cdr (assq 'buffer cont)))
1232 (and (setq filename-cons (assq 'filename cont))
1233 (not (equal (cdr (assq 'nofile cont)) "yes"))))
1234 (setcar cont 'external)
1235 (setcar filename-cons 'name))))
1239 ;;; arch-tag: 583c96cf-1ffe-451b-a5e5-4733ae9ddd12
1240 ;;; mml.el ends here