+(defun mml-insert-buffer (buffer)
+ "Insert BUFFER at point and quote any MML markup."
+ (save-restriction
+ (narrow-to-region (point) (point))
+ (insert-buffer-substring buffer)
+ (mml-quote-region (point-min) (point-max))
+ (goto-char (point-max))))
+
+;;;
+;;; Transforming MIME to MML
+;;;
+
+(defun mime-to-mml (&optional handles)
+ "Translate the current buffer (which should be a message) into MML.
+If HANDLES is non-nil, use it instead reparsing the buffer."
+ ;; First decode the head.
+ (save-restriction
+ (message-narrow-to-head)
+ (mail-decode-encoded-word-region (point-min) (point-max)))
+ (unless handles
+ (setq handles (mm-dissect-buffer t)))
+ (goto-char (point-min))
+ (search-forward "\n\n" nil t)
+ (delete-region (point) (point-max))
+ (if (stringp (car handles))
+ (mml-insert-mime handles)
+ (mml-insert-mime handles t))
+ (mm-destroy-parts handles)
+ (save-restriction
+ (message-narrow-to-head)
+ ;; Remove them, they are confusing.
+ (message-remove-header "Content-Type")
+ (message-remove-header "MIME-Version")
+ (message-remove-header "Content-Disposition")
+ (message-remove-header "Content-Transfer-Encoding")))
+
+(defun mml-to-mime ()
+ "Translate the current buffer from MML to MIME."
+ (message-encode-message-body)
+ (save-restriction
+ (message-narrow-to-headers-or-head)
+ ;; Skip past any From_ headers.
+ (while (looking-at "From ")
+ (forward-line 1))
+ (let ((mail-parse-charset message-default-charset))
+ (mail-encode-encoded-word-buffer))))
+
+(defun mml-insert-mime (handle &optional no-markup)
+ (let (textp buffer mmlp)
+ ;; Determine type and stuff.
+ (unless (stringp (car handle))
+ (unless (setq textp (equal (mm-handle-media-supertype handle) "text"))
+ (save-excursion
+ (set-buffer (setq buffer (mml-generate-new-buffer " *mml*")))
+ (mm-insert-part handle)
+ (if (setq mmlp (equal (mm-handle-media-type handle)
+ "message/rfc822"))
+ (mime-to-mml)))))
+ (if mmlp
+ (mml-insert-mml-markup handle nil t t)
+ (unless (and no-markup
+ (equal (mm-handle-media-type handle) "text/plain"))
+ (mml-insert-mml-markup handle buffer textp)))
+ (cond
+ (mmlp
+ (insert-buffer-substring buffer)
+ (goto-char (point-max))
+ (insert "<#/mml>\n"))
+ ((stringp (car handle))
+ (mapcar 'mml-insert-mime (cdr handle))
+ (insert "<#/multipart>\n"))
+ (textp
+ (let ((charset (mail-content-type-get
+ (mm-handle-type handle) 'charset))
+ (start (point)))
+ (if (eq charset 'gnus-decoded)
+ (mm-insert-part handle)
+ (insert (mm-decode-string (mm-get-part handle) charset)))
+ (mml-quote-region start (point)))
+ (goto-char (point-max)))
+ (t
+ (insert "<#/part>\n")))))
+
+(defun mml-insert-mml-markup (handle &optional buffer nofile mmlp)
+ "Take a MIME handle and insert an MML tag."
+ (if (stringp (car handle))
+ (progn
+ (insert "<#multipart type=" (mm-handle-media-subtype handle))
+ (let ((start (mm-handle-multipart-ctl-parameter handle 'start)))
+ (when start
+ (insert " start=\"" start "\"")))
+ (insert ">\n"))
+ (if mmlp
+ (insert "<#mml type=" (mm-handle-media-type handle))
+ (insert "<#part type=" (mm-handle-media-type handle)))
+ (dolist (elem (append (cdr (mm-handle-type handle))
+ (cdr (mm-handle-disposition handle))))
+ (unless (symbolp (cdr elem))
+ (insert " " (symbol-name (car elem)) "=\"" (cdr elem) "\"")))
+ (when (mm-handle-id handle)
+ (insert " id=\"" (mm-handle-id handle) "\""))
+ (when (mm-handle-disposition handle)
+ (insert " disposition=" (car (mm-handle-disposition handle))))
+ (when buffer
+ (insert " buffer=\"" (buffer-name buffer) "\""))
+ (when nofile
+ (insert " nofile=yes"))
+ (when (mm-handle-description handle)
+ (insert " description=\"" (mm-handle-description handle) "\""))
+ (insert ">\n")))
+
+(defun mml-insert-parameter (&rest parameters)
+ "Insert PARAMETERS in a nice way."
+ (dolist (param parameters)
+ (insert ";")
+ (let ((point (point)))
+ (insert " " param)
+ (when (> (current-column) 71)
+ (goto-char point)
+ (insert "\n ")
+ (end-of-line)))))
+
+;;;
+;;; Mode for inserting and editing MML forms
+;;;
+
+(defvar mml-mode-map
+ (let ((sign (make-sparse-keymap))
+ (encrypt (make-sparse-keymap))
+ (signpart (make-sparse-keymap))
+ (encryptpart (make-sparse-keymap))
+ (map (make-sparse-keymap))
+ (main (make-sparse-keymap)))
+ (define-key sign "p" 'mml-secure-message-sign-pgpmime)
+ (define-key sign "o" 'mml-secure-message-sign-pgp)
+ (define-key sign "s" 'mml-secure-message-sign-smime)
+ (define-key signpart "p" 'mml-secure-sign-pgpmime)
+ (define-key signpart "o" 'mml-secure-sign-pgp)
+ (define-key signpart "s" 'mml-secure-sign-smime)
+ (define-key encrypt "p" 'mml-secure-message-encrypt-pgpmime)
+ (define-key encrypt "o" 'mml-secure-message-encrypt-pgp)
+ (define-key encrypt "s" 'mml-secure-message-encrypt-smime)
+ (define-key encryptpart "p" 'mml-secure-encrypt-pgpmime)
+ (define-key encryptpart "o" 'mml-secure-encrypt-pgp)
+ (define-key encryptpart "s" 'mml-secure-encrypt-smime)
+ (define-key map "\C-n" 'mml-unsecure-message)
+ (define-key map "f" 'mml-attach-file)
+ (define-key map "b" 'mml-attach-buffer)
+ (define-key map "e" 'mml-attach-external)
+ (define-key map "q" 'mml-quote-region)
+ (define-key map "m" 'mml-insert-multipart)
+ (define-key map "p" 'mml-insert-part)
+ (define-key map "v" 'mml-validate)
+ (define-key map "P" 'mml-preview)
+ (define-key map "s" sign)
+ (define-key map "S" signpart)
+ (define-key map "c" encrypt)
+ (define-key map "C" encryptpart)
+ ;;(define-key map "n" 'mml-narrow-to-part)
+ ;; `M-m' conflicts with `back-to-indentation'.
+ ;; (define-key main "\M-m" map)
+ (define-key main "\C-c\C-m" map)
+ main))
+
+(easy-menu-define
+ mml-menu mml-mode-map ""
+ `("Attachments"
+ ["Attach File..." mml-attach-file
+ ,@(if (featurep 'xemacs) '(t)
+ '(:help "Attach a file at point"))]
+ ["Attach Buffer..." mml-attach-buffer t]
+ ["Attach External..." mml-attach-external t]
+ ["Insert Part..." mml-insert-part t]
+ ["Insert Multipart..." mml-insert-multipart t]
+ ["PGP/MIME Sign" mml-secure-message-sign-pgpmime t]
+ ["PGP/MIME Encrypt" mml-secure-message-encrypt-pgpmime t]
+ ["PGP Sign" mml-secure-message-sign-pgp t]
+ ["PGP Encrypt" mml-secure-message-encrypt-pgp t]
+ ["S/MIME Sign" mml-secure-message-sign-smime t]
+ ["S/MIME Encrypt" mml-secure-message-encrypt-smime t]
+ ("Secure MIME part"
+ ["PGP/MIME Sign Part" mml-secure-sign-pgpmime t]
+ ["PGP/MIME Encrypt Part" mml-secure-encrypt-pgpmime t]
+ ["PGP Sign Part" mml-secure-sign-pgp t]
+ ["PGP Encrypt Part" mml-secure-encrypt-pgp t]
+ ["S/MIME Sign Part" mml-secure-sign-smime t]
+ ["S/MIME Encrypt Part" mml-secure-encrypt-smime t])
+ ["Encrypt/Sign off" mml-unsecure-message t]
+ ;;["Narrow" mml-narrow-to-part t]
+ ["Quote MML" mml-quote-region t]
+ ["Validate MML" mml-validate t]
+ ["Preview" mml-preview t]))
+
+(defvar mml-mode nil
+ "Minor mode for editing MML.")
+
+(defun mml-mode (&optional arg)
+ "Minor mode for editing MML.
+MML is the MIME Meta Language, a minor mode for composing MIME articles.
+See Info node `(emacs-mime)Composing'.
+
+\\{mml-mode-map}"
+ (interactive "P")
+ (when (set (make-local-variable 'mml-mode)
+ (if (null arg) (not mml-mode)
+ (> (prefix-numeric-value arg) 0)))
+ (add-minor-mode 'mml-mode " MML" mml-mode-map)
+ (easy-menu-add mml-menu mml-mode-map)
+ (when (boundp 'x-dnd-protocol-alist)
+ (set (make-local-variable 'x-dnd-protocol-alist)
+ '(("^file:///" . mml-x-dnd-attach-file)
+ ("^file://" . x-dnd-open-file)
+ ("^file:" . mml-x-dnd-attach-file))))
+ (run-hooks 'mml-mode-hook)))
+
+;;;
+;;; Helper functions for reading MIME stuff from the minibuffer and
+;;; inserting stuff to the buffer.
+;;;
+
+(defun mml-minibuffer-read-file (prompt)
+ (let* ((completion-ignored-extensions nil)
+ (file (read-file-name prompt nil nil t)))
+ ;; Prevent some common errors. This is inspired by similar code in
+ ;; VM.
+ (when (file-directory-p file)
+ (error "%s is a directory, cannot attach" file))
+ (unless (file-exists-p file)
+ (error "No such file: %s" file))
+ (unless (file-readable-p file)
+ (error "Permission denied: %s" file))
+ file))
+
+(defun mml-minibuffer-read-type (name &optional default)
+ (mailcap-parse-mimetypes)
+ (let* ((default (or default
+ (mm-default-file-encoding name)
+ ;; Perhaps here we should check what the file
+ ;; looks like, and offer text/plain if it looks
+ ;; like text/plain.
+ "application/octet-stream"))
+ (string (completing-read
+ (format "Content type (default %s): " default)
+ (mapcar 'list (mailcap-mime-types)))))
+ (if (not (equal string ""))
+ string
+ default)))
+
+(defun mml-minibuffer-read-description ()
+ (let ((description (read-string "One line description: ")))
+ (when (string-match "\\`[ \t]*\\'" description)
+ (setq description nil))
+ description))
+
+(defun mml-minibuffer-read-disposition (type &optional default)
+ (let* ((default (or default
+ (if (string-match "^text/.*" type)
+ "inline"
+ "attachment")))
+ (disposition (completing-read
+ (format "Disposition: (default %s): " default)
+ '(("attachment") ("inline") (""))
+ nil
+ nil)))
+ (if (not (equal disposition ""))
+ disposition
+ default)))
+