1 ;;; mml.el --- A package for parsing and validating MML documents
3 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
4 ;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
7 ;; This file is part of GNU Emacs.
9 ;; GNU Emacs is free software: you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation, either version 3 of the License, or
12 ;; (at your option) any later version.
14 ;; GNU Emacs is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details.
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
26 ;; For Emacs <22.2 and XEmacs.
28 (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
35 (eval-when-compile (require 'cl))
37 (when (featurep 'xemacs)
38 (require 'easy-mmode))) ; for `define-minor-mode'
40 (autoload 'message-make-message-id "message")
41 (declare-function gnus-setup-posting-charset "gnus-msg" (group))
42 (autoload 'gnus-make-local-hook "gnus-util")
43 (autoload 'gnus-completing-read "gnus-util")
44 (autoload 'message-fetch-field "message")
45 (autoload 'message-mark-active-p "message")
46 (autoload 'message-info "message")
47 (autoload 'fill-flowed-encode "flow-fill")
48 (autoload 'message-posting-charset "message")
49 (autoload 'dnd-get-local-file-name "dnd")
51 (autoload 'message-options-set "message")
52 (autoload 'message-narrow-to-head "message")
53 (autoload 'message-in-body-p "message")
54 (autoload 'message-mail-p "message")
56 (defvar gnus-article-mime-handles)
58 (defvar gnus-newsrc-hashtb)
59 (defvar message-default-charset)
60 (defvar message-deletable-headers)
61 (defvar message-options)
62 (defvar message-posting-charset)
63 (defvar message-required-mail-headers)
64 (defvar message-required-news-headers)
65 (defvar dnd-protocol-alist)
66 (defvar mml-dnd-protocol-alist)
68 (defcustom mml-content-type-parameters
69 '(name access-type expiration size permission format)
70 "*A list of acceptable parameters in MML tag.
71 These parameters are generated in Content-Type header if exists."
73 :type '(repeat (symbol :tag "Parameter"))
76 (defcustom mml-content-disposition-parameters
77 '(filename creation-date modification-date read-date)
78 "*A list of acceptable parameters in MML tag.
79 These parameters are generated in Content-Disposition header if exists."
81 :type '(repeat (symbol :tag "Parameter"))
84 (defcustom mml-content-disposition-alist
85 '((text (rtf . "attachment") (t . "inline"))
87 "Alist of MIME types or regexps matching file names and default dispositions.
88 Each element should be one of the following three forms:
90 (REGEXP . DISPOSITION)
91 (SUPERTYPE (SUBTYPE . DISPOSITION) (SUBTYPE . DISPOSITION)...)
94 Where REGEXP is a string which matches the file name (if any) of an
95 attachment, SUPERTYPE, SUBTYPE and TYPE should be symbols which are a
96 MIME supertype (e.g., text), a MIME subtype (e.g., plain) and a MIME
97 type (e.g., text/plain) respectively, and DISPOSITION should be either
98 the string \"attachment\" or the string \"inline\". The value t for
99 SUPERTYPE, SUBTYPE or TYPE matches any of those types. The first
100 match found will be used."
101 :version "23.1" ;; No Gnus
102 :type (let ((dispositions '(radio :format "DISPOSITION: %v"
104 (const :format "%v " "attachment")
105 (const :format "%v\n" "inline"))))
108 (choice :format "%[Value Menu%]%v"
109 (cons :tag "(REGEXP . DISPOSITION)" :extra-offset 4
110 (regexp :tag "REGEXP" :value ".*")
112 (cons :tag "(SUPERTYPE (SUBTYPE . DISPOSITION)...)"
114 (symbol :tag " SUPERTYPE" :value text)
115 (repeat :format "%v%i\n" :offset 0 :extra-offset 4
116 (cons :format "%v" :extra-offset 5
117 (symbol :tag "SUBTYPE" :value t)
119 (cons :tag "(TYPE . DISPOSITION)" :extra-offset 4
120 (symbol :tag "TYPE" :value t)
124 (defcustom mml-insert-mime-headers-always t
125 "If non-nil, always put Content-Type: text/plain at top of empty parts.
126 It is necessary to work against a bug in certain clients."
131 (defcustom mml-enable-flowed t
132 "If non-nil, enable format=flowed usage when encoding a message.
133 This is only performed when filling on text/plain with hard
134 newlines in the text."
139 (defvar mml-tweak-type-alist nil
140 "A list of (TYPE . FUNCTION) for tweaking MML parts.
141 TYPE is a string containing a regexp to match the MIME type. FUNCTION
142 is a Lisp function which is called with the MML handle to tweak the
143 part. This variable is used only when no TWEAK parameter exists in
146 (defvar mml-tweak-function-alist nil
147 "A list of (NAME . FUNCTION) for tweaking MML parts.
148 NAME is a string containing the name of the TWEAK parameter in the MML
149 handle. FUNCTION is a Lisp function which is called with the MML
150 handle to tweak the part.")
152 (defvar mml-tweak-sexp-alist
153 '((mml-externalize-attachments . mml-tweak-externalize-attachments))
154 "A list of (SEXP . FUNCTION) for tweaking MML parts.
155 SEXP is an s-expression. If the evaluation of SEXP is non-nil, FUNCTION
156 is called. FUNCTION is a Lisp function which is called with the MML
157 handle to tweak the part.")
159 (defvar mml-externalize-attachments nil
160 "*If non-nil, local-file attachments are generated as external parts.")
162 (defvar mml-generate-multipart-alist nil
163 "*Alist of multipart generation functions.
164 Each entry has the form (NAME . FUNCTION), where
165 NAME is a string containing the name of the part (without the
166 leading \"/multipart/\"),
167 FUNCTION is a Lisp function which is called to generate the part.
169 The Lisp function has to supply the appropriate MIME headers and the
170 contents of this part.")
172 (defvar mml-syntax-table
173 (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table)))
174 (modify-syntax-entry ?\\ "/" table)
175 (modify-syntax-entry ?< "(" table)
176 (modify-syntax-entry ?> ")" table)
177 (modify-syntax-entry ?@ "w" table)
178 (modify-syntax-entry ?/ "w" table)
179 (modify-syntax-entry ?= " " table)
180 (modify-syntax-entry ?* " " table)
181 (modify-syntax-entry ?\; " " table)
182 (modify-syntax-entry ?\' " " table)
185 (defvar mml-boundary-function 'mml-make-boundary
186 "A function called to suggest a boundary.
187 The function may be called several times, and should try to make a new
188 suggestion each time. The function is called with one parameter,
189 which is a number that says how many times the function has been
190 called for this message.")
192 (defvar mml-confirmation-set nil
193 "A list of symbols, each of which disables some warning.
194 `unknown-encoding': always send messages contain characters with
195 unknown encoding; `use-ascii': always use ASCII for those characters
196 with unknown encoding; `multipart': always send messages with more than
199 (defvar mml-generate-default-type "text/plain"
200 "Content type by which the Content-Type header can be omitted.
201 The Content-Type header will not be put in the MIME part if the type
202 equals the value and there's no parameter (e.g. charset, format, etc.)
203 and `mml-insert-mime-headers-always' is nil. The value will be bound
204 to \"message/rfc822\" when encoding an article to be forwarded as a MIME
205 part. This is for the internal use, you should never modify the value.")
207 (defvar mml-buffer-list nil)
209 (defun mml-generate-new-buffer (name)
210 (let ((buf (generate-new-buffer name)))
211 (push buf mml-buffer-list)
214 (defun mml-destroy-buffers ()
215 (let (kill-buffer-hook)
216 (mapc 'kill-buffer mml-buffer-list)
217 (setq mml-buffer-list nil)))
220 "Parse the current buffer as an MML document."
222 (goto-char (point-min))
223 (with-syntax-table mml-syntax-table
226 (defun mml-parse-1 ()
227 "Parse the current buffer as an MML document."
228 (let (struct tag point contents charsets warn use-ascii no-markup-p raw)
229 (while (and (not (eobp))
230 (not (looking-at "<#/multipart")))
232 ((looking-at "<#secure")
233 ;; The secure part is essentially a meta-meta tag, which
234 ;; expands to either a part tag if there are no other parts in
235 ;; the document or a multipart tag if there are other parts
236 ;; included in the message
238 (taginfo (mml-read-tag))
239 (keyfile (cdr (assq 'keyfile taginfo)))
240 (certfiles (delq nil (mapcar (lambda (tag)
241 (if (eq (car-safe tag) 'certfile)
244 (recipients (cdr (assq 'recipients taginfo)))
245 (sender (cdr (assq 'sender taginfo)))
246 (location (cdr (assq 'tag-location taginfo)))
247 (mode (cdr (assq 'mode taginfo)))
248 (method (cdr (assq 'method taginfo)))
251 (if (re-search-forward
252 "<#/?\\(multipart\\|part\\|external\\|mml\\)." nil t)
253 (setq secure-mode "multipart")
254 (setq secure-mode "part")))
257 (re-search-forward "<#secure[^\n]*>\n"))
258 (delete-region (match-beginning 0) (match-end 0))
259 (cond ((string= mode "sign")
260 (setq tags (list "sign" method)))
261 ((string= mode "encrypt")
262 (setq tags (list "encrypt" method)))
263 ((string= mode "signencrypt")
264 (setq tags (list "sign" method "encrypt" method))))
265 (eval `(mml-insert-tag ,secure-mode
267 ,(if keyfile "keyfile")
270 (mapcar (lambda (certfile)
271 (list "certfile" certfile))
273 ,(if recipients "recipients")
275 ,(if sender "sender")
278 (goto-char location)))
279 ((looking-at "<#multipart")
280 (push (nconc (mml-read-tag) (mml-parse-1)) struct))
281 ((looking-at "<#external")
282 (push (nconc (mml-read-tag) (list (cons 'contents (mml-read-part))))
285 (if (or (looking-at "<#part") (looking-at "<#mml"))
286 (setq tag (mml-read-tag)
289 (setq tag (list 'part '(type . "text/plain"))
292 (setq raw (cdr (assq 'raw tag))
294 contents (mml-read-part (eq 'mml (car tag)))
299 (intern (downcase (cdr (assq 'charset tag))))))
301 (mm-find-mime-charset-region point (point)
303 (when (and (not raw) (memq nil charsets))
304 (if (or (memq 'unknown-encoding mml-confirmation-set)
305 (message-options-get 'unknown-encoding)
307 Message contains characters with unknown encoding. Really send? ")
308 (message-options-set 'unknown-encoding t)))
310 (or (memq 'use-ascii mml-confirmation-set)
311 (message-options-get 'use-ascii)
312 (and (y-or-n-p "Use ASCII as charset? ")
313 (message-options-set 'use-ascii t))))
314 (setq charsets (delq nil charsets))
316 (error "Edit your message to remove those characters")))
319 (< (length charsets) 2))
320 (if (or (not no-markup-p)
321 (string-match "[^ \t\r\n]" contents))
322 ;; Don't create blank parts.
323 (push (nconc tag (list (cons 'contents contents)))
325 (let ((nstruct (mml-parse-singlepart-with-multiple-charsets
326 tag point (point) use-ascii)))
328 (not (memq 'multipart mml-confirmation-set))
329 (not (message-options-get 'multipart))
330 (not (and (y-or-n-p (format "\
331 A message part needs to be split into %d charset parts. Really send? "
333 (message-options-set 'multipart t))))
334 (error "Edit your message to use only one charset"))
335 (setq struct (nconc nstruct struct)))))))
340 (defun mml-parse-singlepart-with-multiple-charsets
341 (orig-tag beg end &optional use-ascii)
344 (narrow-to-region beg end)
345 (goto-char (point-min))
346 (let ((current (or (mm-mime-charset (mm-charset-after))
347 (and use-ascii 'us-ascii)))
348 charset struct space newline paragraph)
350 (setq charset (mm-mime-charset (mm-charset-after)))
352 ;; The charset remains the same.
353 ((eq charset 'us-ascii))
354 ((or (and use-ascii (not charset))
355 (eq charset current))
359 ;; The initial charset was ascii.
360 ((eq current 'us-ascii)
361 (setq current charset
365 ;; We have a change in charsets.
369 (list (cons 'contents
370 (buffer-substring-no-properties
371 beg (or paragraph newline space (point))))))
373 (setq beg (or paragraph newline space (point))
378 ;; Compute places where it might be nice to break the part.
380 ((memq (following-char) '(? ?\t))
381 (setq space (1+ (point))))
382 ((and (eq (following-char) ?\n)
384 (eq (char-after (1- (point))) ?\n))
385 (setq paragraph (point)))
386 ((eq (following-char) ?\n)
387 (setq newline (1+ (point)))))
389 ;; Do the final part.
390 (unless (= beg (point))
391 (push (append orig-tag
392 (list (cons 'contents
393 (buffer-substring-no-properties
398 (defun mml-read-tag ()
399 "Read a tag and return the contents."
400 (let ((orig-point (point))
401 contents name elem val)
403 (setq name (buffer-substring-no-properties
404 (point) (progn (forward-sexp 1) (point))))
405 (skip-chars-forward " \t\n")
406 (while (not (looking-at ">[ \t]*\n?"))
407 (setq elem (buffer-substring-no-properties
408 (point) (progn (forward-sexp 1) (point))))
409 (skip-chars-forward "= \t\n")
410 (setq val (buffer-substring-no-properties
411 (point) (progn (forward-sexp 1) (point))))
412 (when (string-match "\\`\"" val)
413 (setq val (read val))) ;; inverse of prin1 in mml-insert-tag
414 (push (cons (intern elem) val) contents)
415 (skip-chars-forward " \t\n"))
416 (goto-char (match-end 0))
417 ;; Don't skip the leading space.
418 ;;(skip-chars-forward " \t\n")
419 ;; Put the tag location into the returned contents
420 (setq contents (append (list (cons 'tag-location orig-point)) contents))
421 (cons (intern name) (nreverse contents))))
423 (defun mml-buffer-substring-no-properties-except-hard-newlines (start end)
424 (let ((str (buffer-substring-no-properties start end))
425 (bufstart start) tmp)
426 (while (setq tmp (text-property-any start end 'hard 't))
427 (set-text-properties (- tmp bufstart) (- tmp bufstart -1)
429 (setq start (1+ tmp)))
432 (defun mml-read-part (&optional mml)
433 "Return the buffer up till the next part, multipart or closing part or multipart.
434 If MML is non-nil, return the buffer up till the correspondent mml tag."
435 (let ((beg (point)) (count 1))
436 ;; If the tag ended at the end of the line, we go to the next line.
437 (when (looking-at "[ \t]*\n")
441 (while (and (> count 0) (not (eobp)))
442 (if (re-search-forward "<#\\(/\\)?mml." nil t)
443 (setq count (+ count (if (match-beginning 1) -1 1)))
444 (goto-char (point-max))))
445 (mml-buffer-substring-no-properties-except-hard-newlines
448 (match-beginning 0))))
449 (if (re-search-forward
450 "<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)." nil t)
452 (mml-buffer-substring-no-properties-except-hard-newlines
453 beg (match-beginning 0))
454 (if (or (not (match-beginning 1))
455 (equal (match-string 2) "multipart"))
456 (goto-char (match-beginning 0))
457 (when (looking-at "[ \t]*\n")
459 (mml-buffer-substring-no-properties-except-hard-newlines
460 beg (goto-char (point-max)))))))
462 (defvar mml-boundary nil)
463 (defvar mml-base-boundary "-=-=")
464 (defvar mml-multipart-number 0)
466 (defun mml-generate-mime ()
467 "Generate a MIME message based on the current MML document."
468 (let ((cont (mml-parse))
469 (mml-multipart-number mml-multipart-number))
472 (mm-with-multibyte-buffer
473 (if (and (consp (car cont))
475 (mml-generate-mime-1 (car cont))
476 (mml-generate-mime-1 (nconc (list 'multipart '(type . "mixed"))
480 (defun mml-generate-mime-1 (cont)
481 (let ((mm-use-ultra-safe-encoding
482 (or mm-use-ultra-safe-encoding (assq 'sign cont))))
484 (narrow-to-region (point) (point))
485 (mml-tweak-part cont)
487 ((or (eq (car cont) 'part) (eq (car cont) 'mml))
488 (let* ((raw (cdr (assq 'raw cont)))
489 (filename (cdr (assq 'filename cont)))
490 (type (or (cdr (assq 'type cont))
492 (or (mm-default-file-encoding filename)
493 "application/octet-stream")
495 (charset (cdr (assq 'charset cont)))
496 (coding (mm-charset-to-coding-system charset))
497 encoding flowed coded)
498 (cond ((eq coding 'ascii)
502 ;; The value of `charset' might be a bogus alias that
503 ;; `mm-charset-synonym-alist' provides, like `utf8',
504 ;; so we prefer the MIME charset that Emacs knows for
505 ;; the coding system `coding'.
506 (setq charset (or (mm-coding-system-to-mime-charset coding)
507 (intern (downcase charset))))))
509 (member (car (split-string type "/")) '("text" "message")))
513 ((cdr (assq 'buffer cont))
514 (insert-buffer-substring (cdr (assq 'buffer cont))))
516 (not (equal (cdr (assq 'nofile cont)) "yes")))
517 (let ((coding-system-for-read coding))
518 (mm-insert-file-contents filename)))
519 ((eq 'mml (car cont))
520 (insert (cdr (assq 'contents cont))))
523 (narrow-to-region (point) (point))
524 (insert (cdr (assq 'contents cont)))
525 ;; Remove quotes from quoted tags.
526 (goto-char (point-min))
527 (while (re-search-forward
528 "<#!+/?\\(part\\|multipart\\|external\\|mml\\)"
530 (delete-region (+ (match-beginning 0) 2)
531 (+ (match-beginning 0) 3))))))
533 ((eq (car cont) 'mml)
534 (let ((mml-boundary (mml-compute-boundary cont))
535 ;; It is necessary for the case where this
536 ;; function is called recursively since
537 ;; `m-g-d-t' will be bound to "message/rfc822"
538 ;; when encoding an article to be forwarded.
539 (mml-generate-default-type "text/plain"))
541 ;; Update handle so mml-compute-boundary can
542 ;; detect collisions with the nested parts.
543 (setcdr (assoc 'contents cont) (buffer-string)))
544 (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b")))
545 ;; ignore 0x1b, it is part of iso-2022-jp
546 (setq encoding (mm-body-7-or-8))))
547 ((string= (car (split-string type "/")) "message")
548 (let ((mm-7bit-chars (concat mm-7bit-chars "\x1b")))
549 ;; ignore 0x1b, it is part of iso-2022-jp
550 (setq encoding (mm-body-7-or-8))))
552 ;; Only perform format=flowed filling on text/plain
553 ;; parts where there either isn't a format parameter
554 ;; in the mml tag or it says "flowed" and there
555 ;; actually are hard newlines in the text.
556 (let (use-hard-newlines)
557 (when (and mml-enable-flowed
558 (string= type "text/plain")
559 (not (string= (cdr (assq 'sign cont)) "pgp"))
560 (or (null (assq 'format cont))
561 (string= (cdr (assq 'format cont))
563 (setq use-hard-newlines
565 (point-min) (point-max) 'hard 't)))
567 ;; Indicate that `mml-insert-mime-headers' should
568 ;; insert a "; format=flowed" string unless the
569 ;; user has already specified it.
570 (setq flowed (null (assq 'format cont)))))
571 ;; Prefer `utf-8' for text/calendar parts.
573 (not (string= type "text/calendar")))
574 (setq charset (mm-encode-body charset))
575 (let ((mm-coding-system-priorities
576 (cons 'utf-8 mm-coding-system-priorities)))
577 (setq charset (mm-encode-body))))
578 (setq encoding (mm-body-encoding
579 charset (cdr (assq 'encoding cont))))))
580 (setq coded (buffer-string)))
581 (mml-insert-mime-headers cont type charset encoding flowed)
584 (mm-with-unibyte-buffer
586 ((cdr (assq 'buffer cont))
587 (insert (mm-string-as-unibyte
588 (with-current-buffer (cdr (assq 'buffer cont))
591 (not (equal (cdr (assq 'nofile cont)) "yes")))
592 (let ((coding-system-for-read mm-binary-coding-system))
593 (mm-insert-file-contents filename nil nil nil nil t))
595 (setq charset (mm-coding-system-to-mime-charset
596 (mm-find-buffer-file-coding-system
599 (let ((contents (cdr (assq 'contents cont))))
600 (if (if (featurep 'xemacs)
601 (string-match "[^\000-\377]" contents)
602 (mm-multibyte-string-p contents))
604 (mm-enable-multibyte)
607 (setq charset (mm-encode-body charset))))
608 (insert contents)))))
609 (if (setq encoding (cdr (assq 'encoding cont)))
610 (setq encoding (intern (downcase encoding))))
611 (setq encoding (mm-encode-buffer type encoding)
612 coded (mm-string-as-multibyte (buffer-string))))
613 (mml-insert-mime-headers cont type charset encoding nil)
614 (insert "\n" coded))))
615 ((eq (car cont) 'external)
616 (insert "Content-Type: message/external-body")
617 (let ((parameters (mml-parameter-string
618 cont '(expiration size permission)))
619 (name (cdr (assq 'name cont)))
620 (url (cdr (assq 'url cont))))
622 (setq name (mml-parse-file-name name))
624 (mml-insert-parameter
625 (mail-header-encode-parameter "name" name)
626 "access-type=local-file")
627 (mml-insert-parameter
628 (mail-header-encode-parameter
629 "name" (file-name-nondirectory (nth 2 name)))
630 (mail-header-encode-parameter "site" (nth 1 name))
631 (mail-header-encode-parameter
632 "directory" (file-name-directory (nth 2 name))))
633 (mml-insert-parameter
634 (concat "access-type="
635 (if (member (nth 0 name) '("ftp@" "anonymous@"))
639 (mml-insert-parameter
640 (mail-header-encode-parameter "url" url)
643 (mml-insert-parameter-string
644 cont '(expiration size permission)))
646 (insert "Content-Type: "
647 (or (cdr (assq 'type cont))
649 (or (mm-default-file-encoding name)
650 "application/octet-stream")
653 (insert "Content-ID: " (message-make-message-id) "\n")
654 (insert "Content-Transfer-Encoding: "
655 (or (cdr (assq 'encoding cont)) "binary"))
657 (insert (or (cdr (assq 'contents cont))))
659 ((eq (car cont) 'multipart)
660 (let* ((type (or (cdr (assq 'type cont)) "mixed"))
661 (mml-generate-default-type (if (equal type "digest")
664 (handler (assoc type mml-generate-multipart-alist)))
666 (funcall (cdr handler) cont)
667 ;; No specific handler. Use default one.
668 (let ((mml-boundary (mml-compute-boundary cont)))
669 (insert (format "Content-Type: multipart/%s; boundary=\"%s\""
671 (if (cdr (assq 'start cont))
672 (format "; start=\"%s\"\n" (cdr (assq 'start cont)))
674 (let ((cont cont) part)
675 (while (setq part (pop cont))
676 ;; Skip `multipart' and attributes.
677 (when (and (consp part) (consp (cdr part)))
678 (insert "\n--" mml-boundary "\n")
679 (mml-generate-mime-1 part)
680 (goto-char (point-max)))))
681 (insert "\n--" mml-boundary "--\n")))))
683 (error "Invalid element: %S" cont)))
684 ;; handle sign & encrypt tags in a semi-smart way.
685 (let ((sign-item (assoc (cdr (assq 'sign cont)) mml-sign-alist))
686 (encrypt-item (assoc (cdr (assq 'encrypt cont))
689 (when (or sign-item encrypt-item)
690 (when (setq sender (cdr (assq 'sender cont)))
691 (message-options-set 'mml-sender sender)
692 (message-options-set 'message-sender sender))
693 (if (setq recipients (cdr (assq 'recipients cont)))
694 (message-options-set 'message-recipients recipients))
695 (let ((style (mml-signencrypt-style
696 (first (or sign-item encrypt-item)))))
697 ;; check if: we're both signing & encrypting, both methods
698 ;; are the same (why would they be different?!), and that
699 ;; the signencrypt style allows for combined operation.
700 (if (and sign-item encrypt-item (equal (first sign-item)
701 (first encrypt-item))
702 (equal style 'combined))
703 (funcall (nth 1 encrypt-item) cont t)
704 ;; otherwise, revert to the old behavior.
706 (funcall (nth 1 sign-item) cont))
708 (funcall (nth 1 encrypt-item) cont)))))))))
710 (defun mml-compute-boundary (cont)
711 "Return a unique boundary that does not exist in CONT."
712 (let ((mml-boundary (funcall mml-boundary-function
713 (incf mml-multipart-number))))
714 ;; This function tries again and again until it has found
715 ;; a unique boundary.
716 (while (not (catch 'not-unique
717 (mml-compute-boundary-1 cont))))
720 (defun mml-compute-boundary-1 (cont)
723 ((member (car cont) '(part mml))
726 ((cdr (assq 'buffer cont))
727 (insert-buffer-substring (cdr (assq 'buffer cont))))
728 ((and (setq filename (cdr (assq 'filename cont)))
729 (not (equal (cdr (assq 'nofile cont)) "yes")))
730 (mm-insert-file-contents filename nil nil nil nil t))
732 (insert (cdr (assq 'contents cont)))))
733 (goto-char (point-min))
734 (when (re-search-forward (concat "^--" (regexp-quote mml-boundary))
736 (setq mml-boundary (funcall mml-boundary-function
737 (incf mml-multipart-number)))
738 (throw 'not-unique nil))))
739 ((eq (car cont) 'multipart)
740 (mapc 'mml-compute-boundary-1 (cddr cont))))
743 (defun mml-make-boundary (number)
744 (concat (make-string (% number 60) ?=)
750 (defun mml-content-disposition (type &optional filename)
751 "Return a default disposition name suitable to TYPE or FILENAME."
752 (let ((defs mml-content-disposition-alist)
753 disposition def types)
754 (while (and (not disposition) defs)
755 (setq def (pop defs))
756 (cond ((stringp (car def))
758 (string-match (car def) filename))
759 (setq disposition (cdr def))))
761 (when (string= (car (setq types (split-string type "/")))
763 (setq type (cadr types)
765 (while (and (not disposition) types)
766 (setq def (pop types))
767 (when (or (eq (car def) t) (string= type (car def)))
768 (setq disposition (cdr def))))))
770 (when (or (eq (car def) t) (string= type (car def)))
771 (setq disposition (cdr def))))))
772 (or disposition "attachment")))
774 (defun mml-insert-mime-headers (cont type charset encoding flowed)
775 (let (parameters id disposition description)
777 (mml-parameter-string
778 cont mml-content-type-parameters))
782 (not (equal type mml-generate-default-type))
783 mml-insert-mime-headers-always)
784 (when (consp charset)
786 "Can't encode a part with several charsets"))
787 (insert "Content-Type: " type)
789 (mml-insert-parameter
790 (mail-header-encode-parameter "charset" (symbol-name charset))))
792 (mml-insert-parameter "format=flowed"))
794 (mml-insert-parameter-string
795 cont mml-content-type-parameters))
797 (when (setq id (cdr (assq 'id cont)))
798 (insert "Content-ID: " id "\n"))
800 (mml-parameter-string
801 cont mml-content-disposition-parameters))
802 (when (or (setq disposition (cdr (assq 'disposition cont)))
804 (insert "Content-Disposition: "
806 (mml-content-disposition type (cdr (assq 'filename cont)))))
808 (mml-insert-parameter-string
809 cont mml-content-disposition-parameters))
811 (unless (eq encoding '7bit)
812 (insert (format "Content-Transfer-Encoding: %s\n" encoding)))
813 (when (setq description (cdr (assq 'description cont)))
814 (insert "Content-Description: ")
815 (setq description (prog1
817 (insert description "\n")))