;;; mml.el --- A package for parsing and validating MML documents
;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005 Free Software Foundation, Inc.
+;; 2005, 2006, 2007 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; This file is part of GNU Emacs.
(autoload 'gnus-make-local-hook "gnus-util")
(autoload 'message-fetch-field "message")
(autoload 'message-mark-active-p "message")
+ (autoload 'message-info "message")
(autoload 'fill-flowed-encode "flow-fill")
- (autoload 'message-posting-charset "message"))
-
-(eval-when-compile
+ (autoload 'message-posting-charset "message")
(autoload 'dnd-get-local-file-name "dnd"))
(defvar gnus-article-mime-handles)
(defvar message-posting-charset)
(defvar message-required-mail-headers)
(defvar message-required-news-headers)
+(defvar dnd-protocol-alist)
(defcustom mml-content-type-parameters
'(name access-type expiration size permission format)
:type '(repeat (symbol :tag "Parameter"))
:group 'message)
+(defcustom mml-content-disposition-alist
+ '((text (rtf . "attachment") (t . "inline"))
+ (t . "attachment"))
+ "Alist of MIME types or regexps matching file names and default dispositions.
+Each element should be one of the following three forms:
+
+ (REGEXP . DISPOSITION)
+ (SUPERTYPE (SUBTYPE . DISPOSITION) (SUBTYPE . DISPOSITION)...)
+ (TYPE . DISPOSITION)
+
+Where REGEXP is a string which matches the file name (if any) of an
+attachment, SUPERTYPE, SUBTYPE and TYPE should be symbols which are a
+MIME supertype (e.g., text), a MIME subtype (e.g., plain) and a MIME
+type (e.g., text/plain) respectively, and DISPOSITION should be either
+the string \"attachment\" or the string \"inline\". The value t for
+SUPERTYPE, SUBTYPE or TYPE matches any of those types. The first
+match found will be used."
+ :version "23.0" ;; No Gnus
+ :type (let ((dispositions '(radio :format "DISPOSITION: %v"
+ :value "attachment"
+ (const :format "%v " "attachment")
+ (const :format "%v\n" "inline"))))
+ `(repeat
+ :offset 0
+ (choice :format "%[Value Menu%]%v"
+ (cons :tag "(REGEXP . DISPOSITION)" :extra-offset 4
+ (regexp :tag "REGEXP" :value ".*")
+ ,dispositions)
+ (cons :tag "(SUPERTYPE (SUBTYPE . DISPOSITION)...)"
+ :indent 0
+ (symbol :tag " SUPERTYPE" :value text)
+ (repeat :format "%v%i\n" :offset 0 :extra-offset 4
+ (cons :format "%v" :extra-offset 5
+ (symbol :tag "SUBTYPE" :value t)
+ ,dispositions)))
+ (cons :tag "(TYPE . DISPOSITION)" :extra-offset 4
+ (symbol :tag "TYPE" :value t)
+ ,dispositions))))
+ :group 'message)
+
(defcustom mml-insert-mime-headers-always nil
"If non-nil, always put Content-Type: text/plain at top of empty parts.
It is necessary to work against a bug in certain clients."
(mml-multipart-number mml-multipart-number))
(if (not cont)
nil
- (with-temp-buffer
+ (mm-with-multibyte-buffer
(if (and (consp (car cont))
(= (length cont) 1))
(mml-generate-mime-1 (car cont))
;; insert a "; format=flowed" string unless the
;; user has already specified it.
(setq flowed (null (assq 'format cont)))))
- (setq charset (mm-encode-body charset))
+ ;; 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)))
(mm-with-unibyte-buffer
(cond
((cdr (assq 'buffer cont))
- (insert (with-current-buffer (cdr (assq 'buffer cont))
- (mm-with-unibyte-current-buffer
- (buffer-string)))))
+ (insert (mm-string-as-unibyte
+ (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-find-buffer-file-coding-system
filename)))))
(t
- (insert (cdr (assq 'contents cont)))))
+ (let ((contents (cdr (assq 'contents cont))))
+ (if (if (featurep 'xemacs)
+ (string-match "[^\000-\377]" contents)
+ (mm-multibyte-string-p contents))
+ (progn
+ (mm-enable-multibyte)
+ (insert contents)
+ (unless raw
+ (setq charset (mm-encode-body charset))))
+ (insert contents)))))
(setq encoding (mm-encode-buffer type)
coded (mm-string-as-multibyte (buffer-string))))
(mml-insert-mime-headers cont type charset encoding nil)
- (insert "\n")
- (mm-with-unibyte-current-buffer
- (insert coded)))))
+ (insert "\n" coded))))
((eq (car cont) 'external)
(insert "Content-Type: message/external-body")
(let ((parameters (mml-parameter-string
;; Skip `multipart' and attributes.
(when (and (consp part) (consp (cdr part)))
(insert "\n--" mml-boundary "\n")
- (mml-generate-mime-1 part))))
+ (mml-generate-mime-1 part)
+ (goto-char (point-max)))))
(insert "\n--" mml-boundary "--\n")))))
(t
(error "Invalid element: %S" cont)))
"")
mml-base-boundary))
+(defun mml-content-disposition (type &optional filename)
+ "Return a default disposition name suitable to TYPE or FILENAME."
+ (let ((defs mml-content-disposition-alist)
+ disposition def types)
+ (while (and (not disposition) defs)
+ (setq def (pop defs))
+ (cond ((stringp (car def))
+ (when (and filename
+ (string-match (car def) filename))
+ (setq disposition (cdr def))))
+ ((consp (cdr def))
+ (when (string= (car (setq types (split-string type "/")))
+ (car def))
+ (setq type (cadr types)
+ types (cdr def))
+ (while (and (not disposition) types)
+ (setq def (pop types))
+ (when (or (eq (car def) t) (string= type (car def)))
+ (setq disposition (cdr def))))))
+ (t
+ (when (or (eq (car def) t) (string= type (car def)))
+ (setq disposition (cdr def))))))
+ (or disposition "attachment")))
+
(defun mml-insert-mime-headers (cont type charset encoding flowed)
(let (parameters id disposition description)
(setq parameters
"Can't encode a part with several charsets"))
(insert "Content-Type: " type)
(when charset
- (insert "; " (mail-header-encode-parameter
- "charset" (symbol-name charset))))
+ (mml-insert-parameter
+ (mail-header-encode-parameter "charset" (symbol-name charset))))
(when flowed
- (insert "; format=flowed"))
+ (mml-insert-parameter "format=flowed"))
(when parameters
(mml-insert-parameter-string
cont mml-content-type-parameters))
cont mml-content-disposition-parameters))
(when (or (setq disposition (cdr (assq 'disposition cont)))
parameters)
- (insert "Content-Disposition: " (or disposition "inline"))
+ (insert "Content-Disposition: "
+ (or disposition
+ (mml-content-disposition type (cdr (assq 'filename cont)))))
(when parameters
(mml-insert-parameter-string
cont mml-content-disposition-parameters))
(unless (eq encoding '7bit)
(insert (format "Content-Transfer-Encoding: %s\n" encoding)))
(when (setq description (cdr (assq 'description cont)))
- (insert "Content-Description: "
- (mail-encode-encoded-word-string description) "\n"))))
+ (insert "Content-Description: ")
+ (setq description (prog1
+ (point)
+ (insert description "\n")))
+ (mail-encode-encoded-word-region description (point)))))
(defun mml-parameter-string (cont types)
(let ((string "")
(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)
+ (mm-insert-part handle 'no-cache)
(if (setq mmlp (equal (mm-handle-media-type handle)
"message/rfc822"))
(mime-to-mml)))))
(defun mml-insert-parameter (&rest parameters)
"Insert PARAMETERS in a nice way."
- (dolist (param parameters)
- (insert ";")
- (let ((point (point)))
+ (let (start end)
+ (dolist (param parameters)
+ (insert ";")
+ (setq start (point))
(insert " " param)
- (when (> (current-column) 71)
- (goto-char point)
- (insert "\n")
- (end-of-line)))))
+ (setq end (point))
+ (goto-char start)
+ (end-of-line)
+ (if (> (current-column) 76)
+ (progn
+ (goto-char start)
+ (insert "\n")
+ (goto-char (1+ end)))
+ (goto-char end)))))
;;;
;;; Mode for inserting and editing MML forms
,@(if (featurep 'xemacs) nil
'(:help "Quote MML tags in region"))]
["Validate MML" mml-validate t]
- ["Preview" mml-preview t]))
+ ["Preview" mml-preview t]
+ "----"
+ ["Emacs MIME manual" (lambda () (interactive) (message-info 4))
+ ,@(if (featurep 'xemacs) '(t)
+ '(:help "Display the Emacs MIME manual"))]
+ ["PGG manual" (lambda () (interactive) (message-info 16))
+ ,@(if (featurep 'xemacs) '(t)
+ '(:help "Display the PGG manual"))]))
(defvar mml-mode nil
"Minor mode for editing MML.")
(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))))
+ (append mml-dnd-protocol-alist dnd-protocol-alist)))
(run-hooks 'mml-mode-hook)))
;;;
;;; inserting stuff to the buffer.
;;;
+(defcustom mml-default-directory mm-default-directory
+ "The default directory where mml will find files.
+If not set, `default-directory' will be used."
+ :type '(choice directory (const :tag "Default" nil))
+ :version "23.0" ;; No Gnus
+ :group 'message)
+
(defun mml-minibuffer-read-file (prompt)
(let* ((completion-ignored-extensions nil)
- (file (read-file-name prompt nil nil t)))
+ (file (read-file-name prompt
+ (or mml-default-directory default-directory)
+ nil t)))
;; Prevent some common errors. This is inspired by similar code in
;; VM.
(when (file-directory-p file)
(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")))
+(defun mml-minibuffer-read-disposition (type &optional default filename)
+ (unless default
+ (setq default (mml-content-disposition type filename)))
(let ((disposition (completing-read
- (format "Disposition (default %s): " default)
- '(("attachment") ("inline") (""))
- nil t nil nil default)))
+ (format "Disposition (default %s): " default)
+ '(("attachment") ("inline") (""))
+ nil t nil nil default)))
(if (not (equal disposition ""))
disposition
default)))
as in other buffers."
:type '(choice (repeat (cons (regexp) (function)))
(const :tag "Behave as in other buffers" nil))
- :version "23.0" ;; No Gnus
+ :version "22.1" ;; Gnus 5.10.9
:group 'message)
(defcustom mml-dnd-attach-options nil
(const type)
(const description)
(const disposition))))
- :version "23.0" ;; No Gnus
+ :version "22.1" ;; Gnus 5.10.9
:group 'message)
(defun mml-attach-file (file &optional type description disposition)
(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)))
+ (disposition (mml-minibuffer-read-disposition type nil file)))
(list file type description disposition)))
(save-excursion
(unless (message-in-body-p) (goto-char (point-max)))
(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)))
+ (setq disposition (mml-minibuffer-read-disposition type nil file)))
(mml-attach-file file type description disposition)))))
(defun mml-attach-buffer (buffer &optional type description)
(lambda (event)
(interactive "@e")
(widget-button-press (widget-event-point event) event)))
+ ;; FIXME: Buffer is in article mode, but most tool bar commands won't
+ ;; work. Maybe only keep the following icons: search, print, quit
(goto-char (point-min))))
(if (and (not (mm-special-display-p (buffer-name mml-preview-buffer)))
(boundp 'gnus-buffer-configuration)
projects / gnus / blobdiff