+(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
+ :active (message-mark-active-p)
+ ,@(if (featurep 'xemacs) nil
+ '(:help "Quote MML tags in region"))]
+ ["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 'dnd-protocol-alist)
+ (set (make-local-variable 'dnd-protocol-alist)
+ (append mml-dnd-protocol-alist
+ (symbol-value 'dnd-protocol-alist))))
+ (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)
+ (unless default (setq default
+ (if (and (string-match "\\`text/" type)
+ (not (string-match "\\`text/rtf\\'" type)))
+ "inline"
+ "attachment")))
+ (let ((disposition (completing-read
+ (format "Disposition (default %s): " default)
+ '(("attachment") ("inline") (""))
+ nil t nil nil default)))
+ (if (not (equal disposition ""))
+ disposition
+ default)))
+
+(defun mml-quote-region (beg end)
+ "Quote the MML tags in the region."
+ (interactive "r")
+ (save-excursion
+ (save-restriction
+ ;; Temporarily narrow the region to defend from changes
+ ;; invalidating END.
+ (narrow-to-region beg end)
+ (goto-char (point-min))
+ ;; Quote parts.
+ (while (re-search-forward
+ "<#!*/?\\(multipart\\|part\\|external\\|mml\\)" nil t)
+ ;; Insert ! after the #.
+ (goto-char (+ (match-beginning 0) 2))
+ (insert "!")))))
+
+(defun mml-insert-tag (name &rest plist)
+ "Insert an MML tag described by NAME and PLIST."
+ (when (symbolp name)
+ (setq name (symbol-name name)))
+ (insert "<#" name)
+ (while plist
+ (let ((key (pop plist))
+ (value (pop plist)))
+ (when value
+ ;; Quote VALUE if it contains suspicious characters.
+ (when (string-match "[\"'\\~/*;() \t\n]" value)
+ (setq value (with-output-to-string
+ (let (print-escape-nonascii)
+ (prin1 value)))))
+ (insert (format " %s=%s" key value)))))
+ (insert ">\n"))
+
+(defun mml-insert-empty-tag (name &rest plist)
+ "Insert an empty MML tag described by NAME and PLIST."
+ (when (symbolp name)
+ (setq name (symbol-name name)))
+ (apply #'mml-insert-tag name plist)
+ (insert "<#/" name ">\n"))
+
+;;; Attachment functions.
+
+(defcustom mml-dnd-protocol-alist
+ '(("^file:///" . mml-dnd-attach-file)
+ ("^file://" . dnd-open-file)
+ ("^file:" . mml-dnd-attach-file))
+ "The functions to call when a drop in `mml-mode' is made.
+See `dnd-protocol-alist' for more information. When nil, behave
+as in other buffers."
+ :type '(choice (repeat (cons (regexp) (function)))
+ (const :tag "Behave as in other buffers" nil))
+ :version "23.0" ;; No Gnus
+ :group 'message)
+
+(defcustom mml-dnd-attach-options nil
+ "Which options should be queried when attaching a file via drag and drop.
+
+If it is a list, valid members are `type', `description' and
+`disposition'. `disposition' implies `type'. If it is nil,
+don't ask for options. If it is t, ask the user whether or not
+to specify options."
+ :type '(choice
+ (const :tag "Non" nil)
+ (const :tag "Query" t)
+ (list :value (type description disposition)
+ (set :inline t
+ (const type)
+ (const description)
+ (const disposition))))
+ :version "23.0" ;; No Gnus
+ :group 'message)
+
+(defun mml-attach-file (file &optional type description disposition)
+ "Attach a file to the outgoing MIME message.
+The file is not inserted or encoded until you send the message with
+`\\[message-send-and-exit]' or `\\[message-send]'.
+
+FILE is the name of the file to attach. TYPE is its content-type, a
+string of the form \"type/subtype\". DESCRIPTION is a one-line
+description of the attachment."
+ (interactive
+ (let* ((file (mml-minibuffer-read-file "Attach file: "))
+ (type (mml-minibuffer-read-type file))
+ (description (mml-minibuffer-read-description))
+ (disposition (mml-minibuffer-read-disposition type)))
+ (list file type description disposition)))
+ (mml-insert-empty-tag 'part
+ 'type type
+ 'filename file
+ 'disposition (or disposition "attachment")
+ 'description description))
+
+(defun mml-dnd-attach-file (uri action)
+ "Attach a drag and drop file.
+
+Ask for type, description or disposition according to
+`mml-dnd-attach-options'."
+ (let ((file (dnd-get-local-file-name uri t)))
+ (when (and file (file-regular-p file))
+ (let ((mml-dnd-attach-options mml-dnd-attach-options)
+ type description disposition)
+ (setq mml-dnd-attach-options
+ (when (and (eq mml-dnd-attach-options t)
+ (not
+ (y-or-n-p
+ "Use default type, disposition and description? ")))
+ '(type description disposition)))
+ (when (or (memq 'type mml-dnd-attach-options)
+ (memq 'disposition mml-dnd-attach-options))
+ (setq type (mml-minibuffer-read-type file)))
+ (when (memq 'description mml-dnd-attach-options)
+ (setq description (mml-minibuffer-read-description)))
+ (when (memq 'disposition mml-dnd-attach-options)
+ (setq disposition (mml-minibuffer-read-disposition type)))
+ (mml-attach-file file type description disposition)))))
+
+(defun mml-attach-buffer (buffer &optional type description)
+ "Attach a buffer to the outgoing MIME message.
+See `mml-attach-file' for details of operation."
+ (interactive
+ (let* ((buffer (read-buffer "Attach buffer: "))
+ (type (mml-minibuffer-read-type buffer "text/plain"))
+ (description (mml-minibuffer-read-description)))
+ (list buffer type description)))
+ (mml-insert-empty-tag 'part 'type type 'buffer buffer
+ 'disposition "attachment" 'description description))
+
+(defun mml-attach-external (file &optional type description)
+ "Attach an external file into the buffer.
+FILE is an ange-ftp/efs specification of the part location.
+TYPE is the MIME type to use."
+ (interactive
+ (let* ((file (mml-minibuffer-read-file "Attach external file: "))
+ (type (mml-minibuffer-read-type file))
+ (description (mml-minibuffer-read-description)))
+ (list file type description)))
+ (mml-insert-empty-tag 'external 'type type 'name file
+ 'disposition "attachment" 'description description))
+
+(defun mml-insert-multipart (&optional type)
+ (interactive (list (completing-read "Multipart type (default mixed): "
+ '(("mixed") ("alternative") ("digest") ("parallel")
+ ("signed") ("encrypted"))
+ nil nil "mixed")))
+ (or type
+ (setq type "mixed"))
+ (mml-insert-empty-tag "multipart" 'type type)
+ (forward-line -1))
+
+(defun mml-insert-part (&optional type)
+ (interactive
+ (list (mml-minibuffer-read-type "")))
+ (mml-insert-tag 'part 'type type 'disposition "inline")
+ (forward-line -1))
+
+(defun mml-preview-insert-mail-followup-to ()
+ "Insert a Mail-Followup-To header before previewing an article.
+Should be adopted if code in `message-send-mail' is changed."
+ (when (and (message-mail-p)
+ (message-subscribed-p)
+ (not (mail-fetch-field "mail-followup-to"))
+ (message-make-mail-followup-to))
+ (message-position-on-field "Mail-Followup-To" "X-Draft-From")
+ (insert (message-make-mail-followup-to))))
+
+(defvar mml-preview-buffer nil)
+
+(defun mml-preview (&optional raw)
+ "Display current buffer with Gnus, in a new buffer.
+If RAW, don't highlight the article."
+ (interactive "P")
+ (setq mml-preview-buffer (generate-new-buffer
+ (concat (if raw "*Raw MIME preview of "
+ "*MIME preview of ") (buffer-name))))
+ (save-excursion
+ (let* ((buf (current-buffer))
+ (message-options message-options)
+ (message-this-is-mail (message-mail-p))
+ (message-this-is-news (message-news-p))
+ (message-posting-charset (or (gnus-setup-posting-charset
+ (save-restriction
+ (message-narrow-to-headers-or-head)
+ (message-fetch-field "Newsgroups")))
+ message-posting-charset)))
+ (message-options-set-recipient)
+ (when (boundp 'gnus-buffers)
+ (push mml-preview-buffer gnus-buffers))
+ (save-restriction
+ (widen)
+ (set-buffer mml-preview-buffer)
+ (erase-buffer)
+ (insert-buffer-substring buf))
+ (mml-preview-insert-mail-followup-to)
+ (let ((message-deletable-headers (if (message-news-p)
+ nil
+ message-deletable-headers)))
+ (message-generate-headers
+ (copy-sequence (if (message-news-p)
+ message-required-news-headers
+ message-required-mail-headers))))
+ (if (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
+ (replace-match "\n"))
+ (let ((mail-header-separator ""));; mail-header-separator is removed.
+ (message-sort-headers)
+ (mml-to-mime))
+ (if raw
+ (when (fboundp 'set-buffer-multibyte)
+ (let ((s (buffer-string)))
+ ;; Insert the content into unibyte buffer.
+ (erase-buffer)
+ (mm-disable-multibyte)
+ (insert s)))
+ (let ((gnus-newsgroup-charset (car message-posting-charset))
+ gnus-article-prepare-hook gnus-original-article-buffer)
+ (run-hooks 'gnus-article-decode-hook)
+ (let ((gnus-newsgroup-name "dummy")
+ (gnus-newsrc-hashtb (or gnus-newsrc-hashtb
+ (gnus-make-hashtable 5))))
+ (gnus-article-prepare-display))))
+ ;; Disable article-mode-map.
+ (use-local-map nil)
+ (gnus-make-local-hook 'kill-buffer-hook)
+ (add-hook 'kill-buffer-hook
+ (lambda ()
+ (mm-destroy-parts gnus-article-mime-handles)) nil t)
+ (setq buffer-read-only t)
+ (local-set-key "q" (lambda () (interactive) (kill-buffer nil)))
+ (local-set-key "=" (lambda () (interactive) (delete-other-windows)))
+ (local-set-key "\r"
+ (lambda ()
+ (interactive)
+ (widget-button-press (point))))
+ (local-set-key gnus-mouse-2
+ (lambda (event)
+ (interactive "@e")
+ (widget-button-press (widget-event-point event) event)))
+ (goto-char (point-min))))
+ (if (and (boundp 'gnus-buffer-configuration)
+ (assq 'mml-preview gnus-buffer-configuration))
+ (let ((gnus-message-buffer (current-buffer)))
+ (gnus-configure-windows 'mml-preview))
+ (pop-to-buffer mml-preview-buffer)))
+
+(defun mml-validate ()
+ "Validate the current MML document."
+ (interactive)
+ (mml-parse))
+
+(defun mml-tweak-part (cont)
+ "Tweak a MML part."
+ (let ((tweak (cdr (assq 'tweak cont)))
+ func)
+ (cond
+ (tweak
+ (setq func
+ (or (cdr (assoc tweak mml-tweak-function-alist))
+ (intern tweak))))
+ (mml-tweak-type-alist
+ (let ((alist mml-tweak-type-alist)
+ (type (or (cdr (assq 'type cont)) "text/plain")))
+ (while alist
+ (if (string-match (caar alist) type)
+ (setq func (cdar alist)
+ alist nil)
+ (setq alist (cdr alist)))))))
+ (if func
+ (funcall func cont)
+ cont)
+ (let ((alist mml-tweak-sexp-alist))
+ (while alist
+ (if (eval (caar alist))
+ (funcall (cdar alist) cont))
+ (setq alist (cdr alist)))))
+ cont)
+
+(defun mml-tweak-externalize-attachments (cont)
+ "Tweak attached files as external parts."
+ (let (filename-cons)
+ (when (and (eq (car cont) 'part)
+ (not (cdr (assq 'buffer cont)))
+ (and (setq filename-cons (assq 'filename cont))
+ (not (equal (cdr (assq 'nofile cont)) "yes"))))
+ (setcar cont 'external)
+ (setcar filename-cons 'name))))
+