;;; mml.el --- A package for parsing and validating MML documents
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002 Free Software Foundation, Inc.
+
+;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
+;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; This file is part of GNU Emacs.
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
+;; For Emacs < 22.2.
+(eval-and-compile
+ (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
+
(require 'mm-util)
(require 'mm-bodies)
(require 'mm-encode)
(require 'mm-decode)
(require 'mml-sec)
(eval-when-compile (require 'cl))
-
-(eval-and-compile
- (autoload 'message-make-message-id "message")
- (autoload 'gnus-setup-posting-charset "gnus-msg")
- (autoload 'gnus-add-minor-mode "gnus-ems")
- (autoload 'message-fetch-field "message")
- (autoload 'message-posting-charset "message"))
+(eval-when-compile
+ (when (featurep 'xemacs)
+ (require 'easy-mmode))) ; for `define-minor-mode'
+
+(autoload 'message-make-message-id "message")
+(declare-function gnus-setup-posting-charset "gnus-msg" (group))
+(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")
+(autoload 'dnd-get-local-file-name "dnd")
+
+(autoload 'message-options-set "message")
+(autoload 'message-narrow-to-head "message")
+(autoload 'message-in-body-p "message")
+(autoload 'message-mail-p "message")
+
+(defvar gnus-article-mime-handles)
+(defvar gnus-mouse-2)
+(defvar gnus-newsrc-hashtb)
+(defvar message-default-charset)
+(defvar message-deletable-headers)
+(defvar message-options)
+(defvar message-posting-charset)
+(defvar message-required-mail-headers)
+(defvar message-required-news-headers)
+(defvar dnd-protocol-alist)
+(defvar mml-dnd-protocol-alist)
(defcustom mml-content-type-parameters
'(name access-type expiration size permission format)
"*A list of acceptable parameters in MML tag.
These parameters are generated in Content-Type header if exists."
+ :version "22.1"
:type '(repeat (symbol :tag "Parameter"))
:group 'message)
'(filename creation-date modification-date read-date)
"*A list of acceptable parameters in MML tag.
These parameters are generated in Content-Disposition header if exists."
+ :version "22.1"
: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.1" ;; 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 t
+ "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."
+ :version "24.1"
+ :type 'boolean
+ :group 'message)
+
(defvar mml-tweak-type-alist nil
"A list of (TYPE . FUNCTION) for tweaking MML parts.
TYPE is a string containing a regexp to match the MIME type. FUNCTION
handle. FUNCTION is a Lisp function which is called with the MML
handle to tweak the part.")
-(defvar mml-tweak-sexp-alist
+(defvar mml-tweak-sexp-alist
'((mml-externalize-attachments . mml-tweak-externalize-attachments))
"A list of (SEXP . FUNCTION) for tweaking MML parts.
-SEXP is a s-expression. If the evaluation of SEXP is non-nil, FUNCTION
+SEXP is an s-expression. If the evaluation of SEXP is non-nil, FUNCTION
is called. FUNCTION is a Lisp function which is called with the MML
handle to tweak the part.")
with unknown encoding; `multipart': always send messages with more than
one charsets.")
-(defvar mml-generate-default-type "text/plain")
+(defvar mml-generate-default-type "text/plain"
+ "Content type by which the Content-Type header can be omitted.
+The Content-Type header will not be put in the MIME part if the type
+equals the value and there's no parameter (e.g. charset, format, etc.)
+and `mml-insert-mime-headers-always' is nil. The value will be bound
+to \"message/rfc822\" when encoding an article to be forwarded as a MIME
+part. This is for the internal use, you should never modify the value.")
(defvar mml-buffer-list nil)
(defun mml-destroy-buffers ()
(let (kill-buffer-hook)
- (mapcar 'kill-buffer mml-buffer-list)
+ (mapc 'kill-buffer mml-buffer-list)
(setq mml-buffer-list nil)))
(defun mml-parse ()
"Parse the current buffer as an MML document."
(save-excursion
(goto-char (point-min))
- (let ((table (syntax-table)))
- (unwind-protect
- (progn
- (set-syntax-table mml-syntax-table)
- (mml-parse-1))
- (set-syntax-table table)))))
+ (with-syntax-table mml-syntax-table
+ (mml-parse-1))))
(defun mml-parse-1 ()
"Parse the current buffer as an MML document."
(while (and (not (eobp))
(not (looking-at "<#/multipart")))
(cond
+ ((looking-at "<#secure")
+ ;; The secure part is essentially a meta-meta tag, which
+ ;; expands to either a part tag if there are no other parts in
+ ;; the document or a multipart tag if there are other parts
+ ;; included in the message
+ (let* (secure-mode
+ (taginfo (mml-read-tag))
+ (keyfile (cdr (assq 'keyfile taginfo)))
+ (certfiles (delq nil (mapcar (lambda (tag)
+ (if (eq (car-safe tag) 'certfile)
+ (cdr tag)))
+ taginfo)))
+ (recipients (cdr (assq 'recipients taginfo)))
+ (sender (cdr (assq 'sender taginfo)))
+ (location (cdr (assq 'tag-location taginfo)))
+ (mode (cdr (assq 'mode taginfo)))
+ (method (cdr (assq 'method taginfo)))
+ tags)
+ (save-excursion
+ (if (re-search-forward
+ "<#/?\\(multipart\\|part\\|external\\|mml\\)." nil t)
+ (setq secure-mode "multipart")
+ (setq secure-mode "part")))
+ (save-excursion
+ (goto-char location)
+ (re-search-forward "<#secure[^\n]*>\n"))
+ (delete-region (match-beginning 0) (match-end 0))
+ (cond ((string= mode "sign")
+ (setq tags (list "sign" method)))
+ ((string= mode "encrypt")
+ (setq tags (list "encrypt" method)))
+ ((string= mode "signencrypt")
+ (setq tags (list "sign" method "encrypt" method))))
+ (eval `(mml-insert-tag ,secure-mode
+ ,@tags
+ ,(if keyfile "keyfile")
+ ,keyfile
+ ,@(apply #'append
+ (mapcar (lambda (certfile)
+ (list "certfile" certfile))
+ certfiles))
+ ,(if recipients "recipients")
+ ,recipients
+ ,(if sender "sender")
+ ,sender))
+ ;; restart the parse
+ (goto-char location)))
((looking-at "<#multipart")
(push (nconc (mml-read-tag) (mml-parse-1)) struct))
((looking-at "<#external")
(list
(intern (downcase (cdr (assq 'charset tag))))))
(t
- (mm-find-mime-charset-region point (point)
+ (mm-find-mime-charset-region point (point)
mm-hack-charsets))))
(when (and (not raw) (memq nil charsets))
(if (or (memq 'unknown-encoding mml-confirmation-set)
(message-options-get 'unknown-encoding)
(and (y-or-n-p "\
-Message contains characters with unknown encoding. Really send?")
+Message contains characters with unknown encoding. Really send? ")
(message-options-set 'unknown-encoding t)))
(if (setq use-ascii
(or (memq 'use-ascii mml-confirmation-set)
(message-options-get 'use-ascii)
- (and (y-or-n-p "Use ASCII as charset?")
+ (and (y-or-n-p "Use ASCII as charset? ")
(message-options-set 'use-ascii t))))
(setq charsets (delq nil charsets))
(setq warn nil))
(skip-chars-forward "= \t\n")
(setq val (buffer-substring-no-properties
(point) (progn (forward-sexp 1) (point))))
- (when (string-match "^\"\\(.*\\)\"$" val)
- (setq val (match-string 1 val)))
+ (when (string-match "\\`\"" val)
+ (setq val (read val))) ;; inverse of prin1 in mml-insert-tag
(push (cons (intern elem) val) contents)
(skip-chars-forward " \t\n"))
(goto-char (match-end 0))
(setq contents (append (list (cons 'tag-location orig-point)) contents))
(cons (intern name) (nreverse contents))))
+(defun mml-buffer-substring-no-properties-except-hard-newlines (start end)
+ (let ((str (buffer-substring-no-properties start end))
+ (bufstart start) tmp)
+ (while (setq tmp (text-property-any start end 'hard 't))
+ (set-text-properties (- tmp bufstart) (- tmp bufstart -1)
+ '(hard t) str)
+ (setq start (1+ tmp)))
+ str))
+
(defun mml-read-part (&optional mml)
"Return the buffer up till the next part, multipart or closing part or multipart.
If MML is non-nil, return the buffer up till the correspondent mml tag."
(let ((beg (point)) (count 1))
- ;; If the tag ended at the end of the line, we go to the next line.
+ ;; If the tag ended at the end of the line, we go to the next line.
(when (looking-at "[ \t]*\n")
(forward-line 1))
(if mml
(if (re-search-forward "<#\\(/\\)?mml." nil t)
(setq count (+ count (if (match-beginning 1) -1 1)))
(goto-char (point-max))))
- (buffer-substring-no-properties beg (if (> count 0)
- (point)
- (match-beginning 0))))
+ (mml-buffer-substring-no-properties-except-hard-newlines
+ beg (if (> count 0)
+ (point)
+ (match-beginning 0))))
(if (re-search-forward
"<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)." nil t)
(prog1
- (buffer-substring-no-properties beg (match-beginning 0))
+ (mml-buffer-substring-no-properties-except-hard-newlines
+ beg (match-beginning 0))
(if (or (not (match-beginning 1))
(equal (match-string 2) "multipart"))
(goto-char (match-beginning 0))
(when (looking-at "[ \t]*\n")
(forward-line 1))))
- (buffer-substring-no-properties beg (goto-char (point-max)))))))
+ (mml-buffer-substring-no-properties-except-hard-newlines
+ beg (goto-char (point-max)))))))
(defvar mml-boundary nil)
(defvar mml-base-boundary "-=-=")
(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))
(mml-tweak-part cont)
(cond
((or (eq (car cont) 'part) (eq (car cont) 'mml))
- (let ((raw (cdr (assq 'raw cont)))
- coded encoding charset filename type)
- (setq type (or (cdr (assq 'type cont)) "text/plain"))
+ (let* ((raw (cdr (assq 'raw cont)))
+ (filename (cdr (assq 'filename cont)))
+ (type (or (cdr (assq 'type cont))
+ (if filename
+ (or (mm-default-file-encoding 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
+ &nbs
projects / gnus / blobdiff