1 ;;; mml.el --- A package for parsing and validating MML documents
2 ;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc.
4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5 ;; This file is part of GNU Emacs.
7 ;; GNU Emacs is free software; you can redistribute it and/or modify
8 ;; it under the terms of the GNU General Public License as published by
9 ;; the Free Software Foundation; either version 2, or (at your option)
12 ;; GNU Emacs is distributed in the hope that it will be useful,
13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ;; GNU General Public License for more details.
17 ;; You should have received a copy of the GNU General Public License
18 ;; along with GNU Emacs; see the file COPYING. If not, write to the
19 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 ;; Boston, MA 02111-1307, USA.
30 (eval-when-compile (require 'cl
))
33 (autoload 'message-make-message-id
"message")
34 (autoload 'gnus-setup-posting-charset
"gnus-msg")
35 (autoload 'gnus-add-minor-mode
"gnus-ems")
36 (autoload 'message-fetch-field
"message")
37 (autoload 'message-posting-charset
"message"))
39 (defvar mml-generate-multipart-alist nil
40 "*Alist of multipart generation functions.
41 Each entry has the form (NAME . FUNCTION), where
42 NAME is a string containing the name of the part (without the
43 leading \"/multipart/\"),
44 FUNCTION is a Lisp function which is called to generate the part.
46 The Lisp function has to supply the appropriate MIME headers and the
47 contents of this part.")
49 (defvar mml-syntax-table
50 (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table
)))
51 (modify-syntax-entry ?
\\ "/" table
)
52 (modify-syntax-entry ?
< "(" table
)
53 (modify-syntax-entry ?
> ")" table
)
54 (modify-syntax-entry ?
@ "w" table
)
55 (modify-syntax-entry ?
/ "w" table
)
56 (modify-syntax-entry ?
= " " table
)
57 (modify-syntax-entry ?
* " " table
)
58 (modify-syntax-entry ?\
; " " table)
59 (modify-syntax-entry ?
\' " " table
)
62 (defvar mml-boundary-function
'mml-make-boundary
63 "A function called to suggest a boundary.
64 The function may be called several times, and should try to make a new
65 suggestion each time. The function is called with one parameter,
66 which is a number that says how many times the function has been
67 called for this message.")
69 (defvar mml-confirmation-set nil
70 "A list of symbols, each of which disables some warning.
71 `unknown-encoding': always send messages contain characters with
72 unknown encoding; `use-ascii': always use ASCII for those characters
73 with unknown encoding; `multipart': always send messages with more than
76 (defvar mml-generate-mime-preprocess-function nil
77 "A function called before generating a mime part.
78 The function is called with one parameter, which is the part to be
81 (defvar mml-generate-mime-postprocess-function nil
82 "A function called after generating a mime part.
83 The function is called with one parameter, which is the generated part.")
85 (defvar mml-generate-default-type
"text/plain")
87 (defvar mml-buffer-list nil
)
89 (defun mml-generate-new-buffer (name)
90 (let ((buf (generate-new-buffer name
)))
91 (push buf mml-buffer-list
)
94 (defun mml-destroy-buffers ()
95 (let (kill-buffer-hook)
96 (mapcar 'kill-buffer mml-buffer-list
)
97 (setq mml-buffer-list nil
)))
100 "Parse the current buffer as an MML document."
101 (goto-char (point-min))
102 (let ((table (syntax-table)))
105 (set-syntax-table mml-syntax-table
)
107 (set-syntax-table table
))))
109 (defun mml-parse-1 ()
110 "Parse the current buffer as an MML document."
111 (let (struct tag point contents charsets warn use-ascii no-markup-p raw
)
112 (while (and (not (eobp))
113 (not (looking-at "<#/multipart")))
115 ((looking-at "<#multipart")
116 (push (nconc (mml-read-tag) (mml-parse-1)) struct
))
117 ((looking-at "<#external")
118 (push (nconc (mml-read-tag) (list (cons 'contents
(mml-read-part))))
121 (if (or (looking-at "<#part") (looking-at "<#mml"))
122 (setq tag
(mml-read-tag)
125 (setq tag
(list 'part
'(type .
"text/plain"))
128 (setq raw
(cdr (assq 'raw tag
))
130 contents
(mml-read-part (eq 'mml
(car tag
)))
132 (mm-find-mime-charset-region point
(point))))
133 (when (and (not raw
) (memq nil charsets
))
134 (if (or (memq 'unknown-encoding mml-confirmation-set
)
137 Message contains characters with unknown encoding. Really send?")
138 (set (make-local-variable 'mml-confirmation-set
)
139 (push 'unknown-encoding mml-confirmation-set
))))
141 (or (memq 'use-ascii mml-confirmation-set
)
142 (y-or-n-p "Use ASCII as charset?")))
143 (setq charsets
(delq nil charsets
))
145 (error "Edit your message to remove those characters")))
148 (< (length charsets
) 2))
149 (if (or (not no-markup-p
)
150 (string-match "[^ \t\r\n]" contents
))
151 ;; Don't create blank parts.
152 (push (nconc tag
(list (cons 'contents contents
)))
154 (let ((nstruct (mml-parse-singlepart-with-multiple-charsets
155 tag point
(point) use-ascii
)))
157 (not (memq 'multipart mml-confirmation-set
))
162 A message part needs to be split into %d charset parts. Really send? "
164 (set (make-local-variable 'mml-confirmation-set
)
165 (push 'multipart mml-confirmation-set
)))))
166 (error "Edit your message to use only one charset"))
167 (setq struct
(nconc nstruct struct
)))))))
172 (defun mml-parse-singlepart-with-multiple-charsets
173 (orig-tag beg end
&optional use-ascii
)
176 (narrow-to-region beg end
)
177 (goto-char (point-min))
178 (let ((current (or (mm-mime-charset (mm-charset-after))
179 (and use-ascii
'us-ascii
)))
180 charset struct space newline paragraph
)
182 (setq charset
(mm-mime-charset (mm-charset-after)))
184 ;; The charset remains the same.
185 ((eq charset
'us-ascii
))
186 ((or (and use-ascii
(not charset
))
187 (eq charset current
))
191 ;; The initial charset was ascii.
192 ((eq current
'us-ascii
)
193 (setq current charset
197 ;; We have a change in charsets.
201 (list (cons 'contents
202 (buffer-substring-no-properties
203 beg
(or paragraph newline space
(point))))))
205 (setq beg
(or paragraph newline space
(point))
210 ;; Compute places where it might be nice to break the part.
212 ((memq (following-char) '(? ?
\t))
213 (setq space
(1+ (point))))
214 ((and (eq (following-char) ?
\n)
216 (eq (char-after (1- (point))) ?
\n))
217 (setq paragraph
(point)))
218 ((eq (following-char) ?
\n)
219 (setq newline
(1+ (point)))))
221 ;; Do the final part.
222 (unless (= beg
(point))
223 (push (append orig-tag
224 (list (cons 'contents
225 (buffer-substring-no-properties
230 (defun mml-read-tag ()
231 "Read a tag and return the contents."
232 (let (contents name elem val
)
234 (setq name
(buffer-substring-no-properties
235 (point) (progn (forward-sexp 1) (point))))
236 (skip-chars-forward " \t\n")
237 (while (not (looking-at ">"))
238 (setq elem
(buffer-substring-no-properties
239 (point) (progn (forward-sexp 1) (point))))
240 (skip-chars-forward "= \t\n")
241 (setq val
(buffer-substring-no-properties
242 (point) (progn (forward-sexp 1) (point))))
243 (when (string-match "^\"\\(.*\\)\"$" val
)
244 (setq val
(match-string 1 val
)))
245 (push (cons (intern elem
) val
) contents
)
246 (skip-chars-forward " \t\n"))
248 (skip-chars-forward " \t\n")
249 (cons (intern name
) (nreverse contents
))))
251 (defun mml-read-part (&optional mml
)
252 "Return the buffer up till the next part, multipart or closing part or multipart.
253 If MML is non-nil, return the buffer up till the correspondent mml tag."
254 (let ((beg (point)) (count 1))
255 ;; If the tag ended at the end of the line, we go to the next line.
256 (when (looking-at "[ \t]*\n")
260 (while (and (> count
0) (not (eobp)))
261 (if (re-search-forward "<#\\(/\\)?mml." nil t
)
262 (setq count
(+ count
(if (match-beginning 1) -
1 1)))
263 (goto-char (point-max))))
264 (buffer-substring-no-properties beg
(if (> count
0)
266 (match-beginning 0))))
267 (if (re-search-forward
268 "<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)." nil t
)
270 (buffer-substring-no-properties beg
(match-beginning 0))
271 (if (or (not (match-beginning 1))
272 (equal (match-string 2) "multipart"))
273 (goto-char (match-beginning 0))
274 (when (looking-at "[ \t]*\n")
276 (buffer-substring-no-properties beg
(goto-char (point-max)))))))
278 (defvar mml-boundary nil
)
279 (defvar mml-base-boundary
"-=-=")
280 (defvar mml-multipart-number
0)
282 (defun mml-generate-mime ()
283 "Generate a MIME message based on the current MML document."
284 (let ((cont (mml-parse))
285 (mml-multipart-number mml-multipart-number
))
289 (if (and (consp (car cont
))
291 (mml-generate-mime-1 (car cont
))
292 (mml-generate-mime-1 (nconc (list 'multipart
'(type .
"mixed"))
296 (defun mml-generate-mime-1 (cont)
298 (narrow-to-region (point) (point))
299 (if mml-generate-mime-preprocess-function
300 (funcall mml-generate-mime-preprocess-function cont
))
302 ((or (eq (car cont
) 'part
) (eq (car cont
) 'mml
))
303 (let ((raw (cdr (assq 'raw cont
)))
304 coded encoding charset filename type
)
305 (setq type
(or (cdr (assq 'type cont
)) "text/plain"))
307 (member (car (split-string type
"/")) '("text" "message")))
310 ((cdr (assq 'buffer cont
))
311 (insert-buffer-substring (cdr (assq 'buffer cont
))))
312 ((and (setq filename
(cdr (assq 'filename cont
)))
313 (not (equal (cdr (assq 'nofile cont
)) "yes")))
314 (mm-insert-file-contents filename
))
315 ((eq 'mml
(car cont
))
316 (insert (cdr (assq 'contents cont
))))
319 (narrow-to-region (point) (point))
320 (insert (cdr (assq 'contents cont
)))
321 ;; Remove quotes from quoted tags.
322 (goto-char (point-min))
323 (while (re-search-forward
324 "<#!+/?\\(part\\|multipart\\|external\\|mml\\)" nil t
)
325 (delete-region (+ (match-beginning 0) 2)
326 (+ (match-beginning 0) 3))))))
328 ((eq (car cont
) 'mml
)
329 (let ((mml-boundary (funcall mml-boundary-function
330 (incf mml-multipart-number
)))
331 (mml-generate-default-type "text/plain"))
333 (let ((mm-7bit-chars (concat mm-7bit-chars
"\x1b")))
334 ;; ignore 0x1b, it is part of iso-2022-jp
335 (setq encoding
(mm-body-7-or-8))))
336 ((string= (car (split-string type
"/")) "message")
337 (let ((mm-7bit-chars (concat mm-7bit-chars
"\x1b")))
338 ;; ignore 0x1b, it is part of iso-2022-jp
339 (setq encoding
(mm-body-7-or-8))))
341 (setq charset
(mm-encode-body))
342 (setq encoding
(mm-body-encoding
343 charset
(cdr (assq 'encoding cont
))))))
344 (setq coded
(buffer-string)))
345 (mm-with-unibyte-buffer
347 ((cdr (assq 'buffer cont
))
348 (insert-buffer-substring (cdr (assq 'buffer cont
))))
349 ((and (setq filename
(cdr (assq 'filename cont
)))
350 (not (equal (cdr (assq 'nofile cont
)) "yes")))
351 (let ((coding-system-for-read mm-binary-coding-system
))
352 (mm-insert-file-contents filename nil nil nil nil t
)))
354 (insert (cdr (assq 'contents cont
)))))
355 (setq encoding
(mm-encode-buffer type
)
356 coded
(buffer-string))))
357 (mml-insert-mime-headers cont type charset encoding
)
360 ((eq (car cont
) 'external
)
361 (insert "Content-Type: message/external-body")
362 (let ((parameters (mml-parameter-string
363 cont
'(expiration size permission
)))
364 (name (cdr (assq 'name cont
))))
366 (setq name
(mml-parse-file-name name
))
368 (mml-insert-parameter
369 (mail-header-encode-parameter "name" name
)
370 "access-type=local-file")
371 (mml-insert-parameter
372 (mail-header-encode-parameter
373 "name" (file-name-nondirectory (nth 2 name
)))
374 (mail-header-encode-parameter "site" (nth 1 name
))
375 (mail-header-encode-parameter
376 "directory" (file-name-directory (nth 2 name
))))
377 (mml-insert-parameter
378 (concat "access-type="
379 (if (member (nth 0 name
) '("ftp@" "anonymous@"))
383 (mml-insert-parameter-string
384 cont
'(expiration size permission
))))
386 (insert "Content-Type: " (cdr (assq 'type cont
)) "\n")
387 (insert "Content-ID: " (message-make-message-id) "\n")
388 (insert "Content-Transfer-Encoding: "
389 (or (cdr (assq 'encoding cont
)) "binary"))
391 (insert (or (cdr (assq 'contents cont
))))
393 ((eq (car cont
) 'multipart
)
394 (let* ((type (or (cdr (assq 'type cont
)) "mixed"))
395 (mml-generate-default-type (if (equal type
"digest")
398 (handler (assoc type mml-generate-multipart-alist
)))
400 (funcall (cdr handler
) cont
)
401 ;; No specific handler. Use default one.
402 (let ((mml-boundary (mml-compute-boundary cont
)))
403 (insert (format "Content-Type: multipart/%s; boundary=\"%s\"\n"
405 ;; Skip `multipart' and `type' elements.
406 (setq cont
(cddr cont
))
408 (insert "\n--" mml-boundary
"\n")
409 (mml-generate-mime-1 (pop cont
)))
410 (insert "\n--" mml-boundary
"--\n")))))
412 (error "Invalid element: %S" cont
)))
413 (if mml-generate-mime-postprocess-function
414 (funcall mml-generate-mime-postprocess-function cont
))))
416 (defun mml-compute-boundary (cont)
417 "Return a unique boundary that does not exist in CONT."
418 (let ((mml-boundary (funcall mml-boundary-function
419 (incf mml-multipart-number
))))
420 ;; This function tries again and again until it has found
421 ;; a unique boundary.
422 (while (not (catch 'not-unique
423 (mml-compute-boundary-1 cont
))))
426 (defun mml-compute-boundary-1 (cont)
429 ((eq (car cont
) 'part
)
432 ((cdr (assq 'buffer cont
))
433 (insert-buffer-substring (cdr (assq 'buffer cont
))))
434 ((and (setq filename
(cdr (assq 'filename cont
)))
435 (not (equal (cdr (assq 'nofile cont
)) "yes")))
436 (mm-insert-file-contents filename
))
438 (insert (cdr (assq 'contents cont
)))))
439 (goto-char (point-min))
440 (when (re-search-forward (concat "^--" (regexp-quote mml-boundary
))
442 (setq mml-boundary
(funcall mml-boundary-function
443 (incf mml-multipart-number
)))
444 (throw 'not-unique nil
))))
445 ((eq (car cont
) 'multipart
)
446 (mapcar 'mml-compute-boundary-1
(cddr cont
))))
449 (defun mml-make-boundary (number)
450 (concat (make-string (% number
60) ?
=)
456 (defun mml-insert-mime-headers (cont type charset encoding
)
457 (let (parameters disposition description
)
459 (mml-parameter-string
460 cont
'(name access-type expiration size permission
)))
463 (not (equal type mml-generate-default-type
)))
464 (when (consp charset
)
466 "Can't encode a part with several charsets."))
467 (insert "Content-Type: " type
)
469 (insert "; " (mail-header-encode-parameter
470 "charset" (symbol-name charset
))))
472 (mml-insert-parameter-string
473 cont
'(name access-type expiration size permission
)))
476 (mml-parameter-string
477 cont
'(filename creation-date modification-date read-date
)))
478 (when (or (setq disposition
(cdr (assq 'disposition cont
)))
480 (insert "Content-Disposition: " (or disposition
"inline"))
482 (mml-insert-parameter-string
483 cont
'(filename creation-date modification-date read-date
)))
485 (unless (eq encoding
'7bit
)
486 (insert (format "Content-Transfer-Encoding: %s\n" encoding
)))
487 (when (setq description
(cdr (assq 'description cont
)))
488 (insert "Content-Description: "
489 (mail-encode-encoded-word-string description
) "\n"))))
491 (defun mml-parameter-string (cont types
)
494 (while (setq type
(pop types
))
495 (when (setq value
(cdr (assq type cont
)))
496 ;; Strip directory component from the filename parameter.
497 (when (eq type
'filename
)
498 (setq value
(file-name-nondirectory value
)))
499 (setq string
(concat string
"; "
500 (mail-header-encode-parameter
501 (symbol-name type
) value
)))))
502 (when (not (zerop (length string
)))
505 (defun mml-insert-parameter-string (cont types
)
507 (while (setq type
(pop types
))
508 (when (setq value
(cdr (assq type cont
)))
509 ;; Strip directory component from the filename parameter.
510 (when (eq type
'filename
)
511 (setq value
(file-name-nondirectory value
)))
512 (mml-insert-parameter
513 (mail-header-encode-parameter
514 (symbol-name type
) value
))))))
517 (defvar ange-ftp-name-format
)
518 (defvar efs-path-regexp
))
519 (defun mml-parse-file-name (path)
520 (if (if (boundp 'efs-path-regexp
)
521 (string-match efs-path-regexp path
)
522 (if (boundp 'ange-ftp-name-format
)
523 (string-match (car ange-ftp-name-format
) path
)))
524 (list (match-string 1 path
) (match-string 2 path
)
525 (substring path
(1+ (match-end 2))))
528 (defun mml-insert-buffer (buffer)
529 "Insert BUFFER at point and quote any MML markup."
531 (narrow-to-region (point) (point))
532 (insert-buffer-substring buffer
)
533 (mml-quote-region (point-min) (point-max))
534 (goto-char (point-max))))
537 ;;; Transforming MIME to MML
540 (defun mime-to-mml ()
541 "Translate the current buffer (which should be a message) into MML."
542 ;; First decode the head.
544 (message-narrow-to-head)
545 (mail-decode-encoded-word-region (point-min) (point-max)))
546 (let ((handles (mm-dissect-buffer t
)))
547 (goto-char (point-min))
548 (search-forward "\n\n" nil t
)
549 (delete-region (point) (point-max))
550 (if (stringp (car handles
))
551 (mml-insert-mime handles
)
552 (mml-insert-mime handles t
))
553 (mm-destroy-parts handles
))
555 (message-narrow-to-head)
556 ;; Remove them, they are confusing.
557 (message-remove-header "Content-Type")
558 (message-remove-header "MIME-Version")
559 (message-remove-header "Content-Transfer-Encoding")))
561 (defun mml-to-mime ()
562 "Translate the current buffer from MML to MIME."
563 (message-encode-message-body)
565 (message-narrow-to-headers-or-head)
566 (let ((mail-parse-charset message-default-charset
))
567 (mail-encode-encoded-word-buffer))))
569 (defun mml-insert-mime (handle &optional no-markup
)
570 (let (textp buffer mmlp
)
571 ;; Determine type and stuff.
572 (unless (stringp (car handle
))
573 (unless (setq textp
(equal (mm-handle-media-supertype handle
) "text"))
575 (set-buffer (setq buffer
(mml-generate-new-buffer " *mml*")))
576 (mm-insert-part handle
)
577 (if (setq mmlp
(equal (mm-handle-media-type handle
)
581 (mml-insert-mml-markup handle nil t t
)
582 (unless (and no-markup
583 (equal (mm-handle-media-type handle
) "text/plain"))
584 (mml-insert-mml-markup handle buffer textp
)))
587 (insert-buffer buffer
)
588 (goto-char (point-max))
589 (insert "<#/mml>\n"))
590 ((stringp (car handle
))
591 (mapcar 'mml-insert-mime
(cdr handle
))
592 (insert "<#/multipart>\n"))
594 (let ((text (mm-get-part handle
))
595 (charset (mail-content-type-get
596 (mm-handle-type handle
) 'charset
)))
597 (insert (mm-decode-string text charset
)))
598 (goto-char (point-max)))
600 (insert "<#/part>\n")))))
602 (defun mml-insert-mml-markup (handle &optional buffer nofile mmlp
)
603 "Take a MIME handle and insert an MML tag."
604 (if (stringp (car handle
))
605 (insert "<#multipart type=" (mm-handle-media-subtype handle
)
608 (insert "<#mml type=" (mm-handle-media-type handle
))
609 (insert "<#part type=" (mm-handle-media-type handle
)))
610 (dolist (elem (append (cdr (mm-handle-type handle
))
611 (cdr (mm-handle-disposition handle
))))
612 (insert " " (symbol-name (car elem
)) "=\"" (cdr elem
) "\""))
613 (when (mm-handle-disposition handle
)
614 (insert " disposition=" (car (mm-handle-disposition handle
))))
616 (insert " buffer=\"" (buffer-name buffer
) "\""))
618 (insert " nofile=yes"))
619 (when (mm-handle-description handle
)
620 (insert " description=\"" (mm-handle-description handle
) "\""))
623 (defun mml-insert-parameter (&rest parameters
)
624 "Insert PARAMETERS in a nice way."
625 (dolist (param parameters
)
627 (let ((point (point)))
629 (when (> (current-column) 71)
635 ;;; Mode for inserting and editing MML forms
639 (let ((map (make-sparse-keymap))
640 (main (make-sparse-keymap)))
641 (define-key map
"f" 'mml-attach-file
)
642 (define-key map
"b" 'mml-attach-buffer
)
643 (define-key map
"e" 'mml-attach-external
)
644 (define-key map
"q" 'mml-quote-region
)
645 (define-key map
"m" 'mml-insert-multipart
)
646 (define-key map
"p" 'mml-insert-part
)
647 (define-key map
"v" 'mml-validate
)
648 (define-key map
"P" 'mml-preview
)
649 ;;(define-key map "n" 'mml-narrow-to-part)
650 (define-key main
"\M-m" map
)
654 mml-menu mml-mode-map
""
657 ["File" mml-attach-file t
]
658 ["Buffer" mml-attach-buffer t
]
659 ["External" mml-attach-external t
])
661 ["Multipart" mml-insert-multipart t
]
662 ["Part" mml-insert-part t
])
663 ;;["Narrow" mml-narrow-to-part t]
664 ["Quote" mml-quote-region t
]
665 ["Validate" mml-validate t
]
666 ["Preview" mml-preview t
]))
669 "Minor mode for editing MML.")
671 (defun mml-mode (&optional arg
)
672 "Minor mode for editing MML.
676 (if (not (set (make-local-variable 'mml-mode
)
677 (if (null arg
) (not mml-mode
)
678 (> (prefix-numeric-value arg
) 0))))
680 (set (make-local-variable 'mml-mode
) t
)
681 (unless (assq 'mml-mode minor-mode-alist
)
682 (push `(mml-mode " MML") minor-mode-alist
))
683 (unless (assq 'mml-mode minor-mode-map-alist
)
684 (push (cons 'mml-mode mml-mode-map
)
685 minor-mode-map-alist
)))
686 (run-hooks 'mml-mode-hook
))
689 ;;; Helper functions for reading MIME stuff from the minibuffer and
690 ;;; inserting stuff to the buffer.
693 (defun mml-minibuffer-read-file (prompt)
694 (let ((file (read-file-name prompt nil nil t
)))
695 ;; Prevent some common errors. This is inspired by similar code in
697 (when (file-directory-p file
)
698 (error "%s is a directory, cannot attach" file
))
699 (unless (file-exists-p file
)
700 (error "No such file: %s" file
))
701 (unless (file-readable-p file
)
702 (error "Permission denied: %s" file
))
705 (defun mml-minibuffer-read-type (name &optional default
)
706 (mailcap-parse-mimetypes)
707 (let* ((default (or default
708 (mm-default-file-encoding name
)
709 ;; Perhaps here we should check what the file
710 ;; looks like, and offer text/plain if it looks
712 "application/octet-stream"))
713 (string (completing-read
714 (format "Content type (default %s): " default
)
715 (mapcar 'list
(mailcap-mime-types)))))
716 (if (not (equal string
""))
720 (defun mml-minibuffer-read-description ()
721 (let ((description (read-string "One line description: ")))
722 (when (string-match "\\`[ \t]*\\'" description
)
723 (setq description nil
))
726 (defun mml-quote-region (beg end
)
727 "Quote the MML tags in the region."
731 ;; Temporarily narrow the region to defend from changes
733 (narrow-to-region beg end
)
734 (goto-char (point-min))
736 (while (re-search-forward
737 "<#!*/?\\(multipart\\|part\\|external\\|mml\\)" nil t
)
738 ;; Insert ! after the #.
739 (goto-char (+ (match-beginning 0) 2))
742 (defun mml-insert-tag (name &rest plist
)
743 "Insert an MML tag described by NAME and PLIST."
745 (setq name
(symbol-name name
)))
748 (let ((key (pop plist
))
751 ;; Quote VALUE if it contains suspicious characters.
752 (when (string-match "[\"'\\~/*;() \t\n]" value
)
753 (setq value
(prin1-to-string value
)))
754 (insert (format " %s=%s" key value
)))))
757 (defun mml-insert-empty-tag (name &rest plist
)
758 "Insert an empty MML tag described by NAME and PLIST."
760 (setq name
(symbol-name name
)))
761 (apply #'mml-insert-tag name plist
)
762 (insert "<#/" name
">\n"))
764 ;;; Attachment functions.
766 (defun mml-attach-file (file &optional type description
)
767 "Attach a file to the outgoing MIME message.
768 The file is not inserted or encoded until you send the message with
769 `\\[message-send-and-exit]' or `\\[message-send]'.
771 FILE is the name of the file to attach. TYPE is its content-type, a
772 string of the form \"type/subtype\". DESCRIPTION is a one-line
773 description of the attachment."
775 (let* ((file (mml-minibuffer-read-file "Attach file: "))
776 (type (mml-minibuffer-read-type file
))
777 (description (mml-minibuffer-read-description)))
778 (list file type description
)))
779 (mml-insert-empty-tag 'part
'type type
'filename file
780 'disposition
"attachment" 'description description
))
782 (defun mml-attach-buffer (buffer &optional type description
)
783 "Attach a buffer to the outgoing MIME message.
784 See `mml-attach-file' for details of operation."
786 (let* ((buffer (read-buffer "Attach buffer: "))
787 (type (mml-minibuffer-read-type buffer
"text/plain"))
788 (description (mml-minibuffer-read-description)))
789 (list buffer type description
)))
790 (mml-insert-empty-tag 'part
'type type
'buffer buffer
791 'disposition
"attachment" 'description description
))
793 (defun mml-attach-external (file &optional type description
)
794 "Attach an external file into the buffer.
795 FILE is an ange-ftp/efs specification of the part location.
796 TYPE is the MIME type to use."
798 (let* ((file (mml-minibuffer-read-file "Attach external file: "))
799 (type (mml-minibuffer-read-type file
))
800 (description (mml-minibuffer-read-description)))
801 (list file type description
)))
802 (mml-insert-empty-tag 'external
'type type
'name file
803 'disposition
"attachment" 'description description
))
805 (defun mml-insert-multipart (&optional type
)
806 (interactive (list (completing-read "Multipart type (default mixed): "
807 '(("mixed") ("alternative") ("digest") ("parallel")
808 ("signed") ("encrypted"))
812 (mml-insert-empty-tag "multipart" 'type type
)
815 (defun mml-insert-part (&optional type
)
817 (list (mml-minibuffer-read-type "")))
818 (mml-insert-tag 'part
'type type
'disposition
"inline")
821 (defun mml-preview (&optional raw
)
822 "Display current buffer with Gnus, in a new buffer.
823 If RAW, don't highlight the article."
825 (let ((buf (current-buffer))
826 (message-posting-charset (or (gnus-setup-posting-charset
828 (message-narrow-to-headers-or-head)
829 (message-fetch-field "Newsgroups")))
830 message-posting-charset
)))
831 (switch-to-buffer (get-buffer-create
832 (concat (if raw
"*Raw MIME preview of "
833 "*MIME preview of ") (buffer-name))))
836 (if (re-search-forward
837 (concat "^" (regexp-quote mail-header-separator
) "\n") nil t
)
838 (replace-match "\n"))
841 (when (fboundp 'set-buffer-multibyte
)
842 (let ((s (buffer-string)))
843 ;; Insert the content into unibyte buffer.
845 (mm-disable-multibyte)
847 (let ((gnus-newsgroup-charset (car message-posting-charset
)))
848 (run-hooks 'gnus-article-decode-hook
)
849 (let ((gnus-newsgroup-name "dummy"))
850 (gnus-article-prepare-display))))
852 (setq buffer-read-only t
)
853 (goto-char (point-min))))
855 (defun mml-validate ()
856 "Validate the current MML document."