Function: mml-generate-mime-1
mml-generate-mime-1 is a byte-compiled function defined in mml.el.gz.
Signature
(mml-generate-mime-1 CONT)
Source Code
;; Defined in /usr/src/emacs/lisp/gnus/mml.el.gz
(defun mml-generate-mime-1 (cont)
(let ((mm-use-ultra-safe-encoding
(or mm-use-ultra-safe-encoding (assq 'sign cont))))
(save-restriction
(narrow-to-region (point) (point))
(mml-tweak-part cont)
(cond
((or (eq (car cont) 'part) (eq (car cont) 'mml))
(let* ((raw (cdr (assq 'raw cont)))
(filename (cdr (assq 'filename cont)))
(type (or (cdr (assq 'type cont))
(if filename
(or (mm-default-file-type filename)
"application/octet-stream")
"text/plain")))
(charset (cdr (assq 'charset cont)))
(coding (mm-charset-to-coding-system charset))
encoding flowed coded)
(cond ((eq coding 'ascii)
(setq charset nil
coding nil))
(charset
;; The value of `charset' might be a bogus alias that
;; `mm-charset-synonym-alist' provides, like `utf8',
;; so we prefer the MIME charset that Emacs knows for
;; the coding system `coding'.
(setq charset (or (mm-coding-system-to-mime-charset coding)
(intern (downcase charset))))))
(if (and (not raw)
(member (car (split-string type "/")) '("text" "message")))
(progn
(with-temp-buffer
(cond
((cdr (assq 'buffer cont))
(insert-buffer-substring (cdr (assq 'buffer cont))))
((and filename
(not (equal (cdr (assq 'nofile cont)) "yes")))
(let ((coding-system-for-read coding))
(mm-insert-file-contents filename)))
((eq 'mml (car cont))
(insert (cdr (assq 'contents cont))))
(t
(save-restriction
(narrow-to-region (point) (point))
(insert (cdr (assq 'contents cont)))
;; Remove quotes from quoted tags.
(goto-char (point-min))
(while (re-search-forward
"<#!+/?\\(part\\|multipart\\|external\\|mml\\|secure\\)"
nil t)
(delete-region (+ (match-beginning 0) 2)
(+ (match-beginning 0) 3))))))
(cond
((eq (car cont) 'mml)
(let ((mml-boundary (mml-compute-boundary cont))
;; It is necessary for the case where this
;; function is called recursively since
;; `m-g-d-t' will be bound to "message/rfc822"
;; when encoding an article to be forwarded.
(mml-generate-default-type "text/plain"))
(mml-to-mime)
;; Update handle so mml-compute-boundary can
;; detect collisions with the nested parts.
(unless mml-inhibit-compute-boundary
(setcdr (assoc 'contents cont) (buffer-string))))
(let ((mm-7bit-chars (concat mm-7bit-chars "\x1b")))
;; ignore 0x1b, it is part of iso-2022-jp
(setq encoding (mm-body-7-or-8))))
((string= (car (split-string type "/")) "message")
(let ((mm-7bit-chars (concat mm-7bit-chars "\x1b")))
;; ignore 0x1b, it is part of iso-2022-jp
(setq encoding (mm-body-7-or-8))))
(t
;; Only perform format=flowed filling on text/plain
;; parts where there either isn't a format parameter
;; in the mml tag or it says "flowed" and there
;; actually are hard newlines in the text.
(let (use-hard-newlines)
(when (and mml-enable-flowed
(string= type "text/plain")
(not (string= (cdr (assq 'sign cont)) "pgp"))
(or (null (assq 'format cont))
(string= (cdr (assq 'format cont))
"flowed"))
(setq use-hard-newlines
(text-property-any
(point-min) (point-max) 'hard 't)))
(fill-flowed-encode)
;; Indicate that `mml-insert-mime-headers' should
;; insert a "; format=flowed" string unless the
;; user has already specified it.
(setq flowed (null (assq 'format cont)))))
;; Prefer `utf-8' for text/calendar parts.
(if (or charset
(not (string= type "text/calendar")))
(setq charset (mm-encode-body charset))
(let ((mm-coding-system-priorities
(cons 'utf-8 mm-coding-system-priorities)))
(setq charset (mm-encode-body))))
(setq encoding (mm-body-encoding
charset (cdr (assq 'encoding cont))))))
(setq coded (buffer-string)))
(mml-insert-mime-headers cont type charset encoding flowed)
(insert "\n")
(insert coded))
(with-temp-buffer
(set-buffer-multibyte nil)
(cond
((cdr (assq 'buffer cont))
;; multibyte string that inserted to a unibyte buffer
;; will be converted to the unibyte version safely.
(insert (with-current-buffer (cdr (assq 'buffer cont))
(buffer-string))))
((and filename
(not (equal (cdr (assq 'nofile cont)) "yes")))
(let ((coding-system-for-read mm-binary-coding-system))
(mm-insert-file-contents filename nil nil nil nil t))
(unless charset
(setq charset (mm-coding-system-to-mime-charset
(mm-find-buffer-file-coding-system
filename)))))
(t
(let ((contents (cdr (assq 'contents cont))))
(if (multibyte-string-p contents)
(progn
(set-buffer-multibyte t)
(insert contents)
(unless raw
(setq charset (mm-encode-body charset))))
(insert contents)))))
(if (setq encoding (cdr (assq 'encoding cont)))
(setq encoding (intern (downcase encoding))))
(setq encoding (mm-encode-buffer type encoding))
(setq coded (decode-coding-string (buffer-string) 'us-ascii)))
(mml-insert-mime-headers cont type charset encoding nil)
(insert "\n" coded))))
((eq (car cont) 'external)
(insert "Content-Type: message/external-body")
(let ((parameters (mml-parameter-string
cont '(expiration size permission)))
(name (cdr (assq 'name cont)))
(url (cdr (assq 'url cont))))
(when name
(setq name (mml-parse-file-name name))
(if (stringp name)
(mml-insert-parameter
(mail-header-encode-parameter "name" name)
"access-type=local-file")
(mml-insert-parameter
(mail-header-encode-parameter
"name" (file-name-nondirectory (nth 2 name)))
(mail-header-encode-parameter "site" (nth 1 name))
(mail-header-encode-parameter
"directory" (file-name-directory (nth 2 name))))
(mml-insert-parameter
(concat "access-type="
(if (member (nth 0 name) '("ftp@" "anonymous@"))
"anon-ftp"
"ftp")))))
(when url
(mml-insert-parameter
(mail-header-encode-parameter "url" url)
"access-type=url"))
(when parameters
(mml-insert-parameter-string
cont '(expiration size permission)))
(insert "\n\n")
(insert "Content-Type: "
(or (cdr (assq 'type cont))
(if name
(or (mm-default-file-type name)
"application/octet-stream")
"text/plain"))
"\n")
(insert "Content-ID: " (message-make-message-id) "\n")
(insert "Content-Transfer-Encoding: "
(or (cdr (assq 'encoding cont)) "binary"))
(insert "\n\n")
(insert (or (cdr (assq 'contents cont))))
(insert "\n")))
((eq (car cont) 'multipart)
(let* ((type (or (cdr (assq 'type cont)) "mixed"))
(mml-generate-default-type (if (equal type "digest")
"message/rfc822"
"text/plain"))
(handler (assoc type mml-generate-multipart-alist)))
(if handler
(funcall (cdr handler) cont)
;; No specific handler. Use default one.
(let ((mml-boundary (mml-compute-boundary cont)))
(insert (format "Content-Type: multipart/%s; boundary=\"%s\""
type mml-boundary)
(if (cdr (assq 'start cont))
(format "; start=\"%s\"\n" (cdr (assq 'start cont)))
"\n"))
(let ((cont cont) part)
(while (setq part (pop cont))
;; Skip `multipart' and attributes.
(when (and (consp part) (consp (cdr part)))
(insert "\n--" mml-boundary "\n")
(mml-generate-mime-1 part)
(goto-char (point-max)))))
(insert "\n--" mml-boundary "--\n")))))
(t
(error "Invalid element: %S" cont)))
;; handle sign & encrypt tags in a semi-smart way.
(let ((sign-item (assoc (cdr (assq 'sign cont)) mml-sign-alist))
(encrypt-item (assoc (cdr (assq 'encrypt cont))
mml-encrypt-alist))
sender recipients)
(when (or sign-item encrypt-item)
(when (setq sender (cdr (assq 'sender cont)))
(message-options-set 'mml-sender sender)
(message-options-set 'message-sender sender))
(if (setq recipients (cdr (assq 'recipients cont)))
(message-options-set 'message-recipients recipients))
(let ((style (mml-signencrypt-style
(car (or sign-item encrypt-item)))))
;; check if: we're both signing & encrypting, both methods
;; are the same (why would they be different?!), and that
;; the signencrypt style allows for combined operation.
(if (and sign-item encrypt-item (equal (car sign-item)
(car encrypt-item))
(equal style 'combined))
(funcall (nth 1 encrypt-item) cont t)
;; otherwise, revert to the old behavior.
(when sign-item
(funcall (nth 1 sign-item) cont))
(when encrypt-item
(funcall (nth 1 encrypt-item) cont)))))))))