;;; mml.el --- A package for parsing and validating MML documents
-;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc.
+;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003
+;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; This file is part of GNU Emacs.
(eval-and-compile
(autoload 'message-make-message-id "message")
(autoload 'gnus-setup-posting-charset "gnus-msg")
+ (autoload 'gnus-add-minor-mode "gnus-ems")
+ (autoload 'gnus-make-local-hook "gnus-util")
(autoload 'message-fetch-field "message")
+ (autoload 'fill-flowed-encode "flow-fill")
(autoload 'message-posting-charset "message"))
+(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."
+ :type '(repeat (symbol :tag "Parameter"))
+ :group 'message)
+
+(defcustom mml-content-disposition-parameters
+ '(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."
+ :type '(repeat (symbol :tag "Parameter"))
+ :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."
+ :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
+is a Lisp function which is called with the MML handle to tweak the
+part. This variable is used only when no TWEAK parameter exists in
+the MML handle.")
+
+(defvar mml-tweak-function-alist nil
+ "A list of (NAME . FUNCTION) for tweaking MML parts.
+NAME is a string containing the name of the TWEAK parameter in the MML
+handle. FUNCTION is a Lisp function which is called with the MML
+handle to tweak the part.")
+
+(defvar mml-tweak-sexp-alist
+ '((mml-externalize-attachments . mml-tweak-externalize-attachments))
+ "A list of (SEXP . FUNCTION) for tweaking MML parts.
+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.")
+
+(defvar mml-externalize-attachments nil
+ "*If non-nil, local-file attachments are generated as external parts.")
+
(defvar mml-generate-multipart-alist nil
"*Alist of multipart generation functions.
Each entry has the form (NAME . FUNCTION), where
-NAME is a string containing the name of the part (without the
+NAME is a string containing the name of the part (without the
leading \"/multipart/\"),
FUNCTION is a Lisp function which is called to generate the part.
(defvar mml-buffer-list nil)
-(defun mml-generate-new-buffer (name)
+(defun mml-generate-new-buffer (name)
(let ((buf (generate-new-buffer name)))
(push buf mml-buffer-list)
buf))
(defun mml-parse ()
"Parse the current buffer as an MML document."
- (goto-char (point-min))
- (let ((table (syntax-table)))
- (unwind-protect
- (progn
- (set-syntax-table mml-syntax-table)
- (mml-parse-1))
- (set-syntax-table table))))
+ (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)))))
(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))
+ (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 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")
(setq raw (cdr (assq 'raw tag))
point (point)
contents (mml-read-part (eq 'mml (car tag)))
- charsets (if raw nil
- (mm-find-mime-charset-region point (point))))
+ charsets (cond
+ (raw nil)
+ ((assq 'charset tag)
+ (list
+ (intern (downcase (cdr (assq 'charset tag))))))
+ (t
+ (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)
- (y-or-n-p
- "Message contains characters with unknown encoding. Really send?"))
- (if (setq use-ascii
+ (message-options-get 'unknown-encoding)
+ (and (y-or-n-p "\
+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)
- (y-or-n-p "Use ASCII as charset?")))
+ (message-options-get 'use-ascii)
+ (and (y-or-n-p "Use ASCII as charset? ")
+ (message-options-set 'use-ascii t))))
(setq charsets (delq nil charsets))
(setq warn nil))
(error "Edit your message to remove those characters")))
tag point (point) use-ascii)))
(when (and warn
(not (memq 'multipart mml-confirmation-set))
- (not
- (y-or-n-p
- (format
- "Warning: Your message contains more than %d parts. Really send? "
- (length nstruct)))))
+ (not (message-options-get 'multipart))
+ (not (and (y-or-n-p (format "\
+A message part needs to be split into %d charset parts. Really send? "
+ (length nstruct)))
+ (message-options-set 'multipart t))))
(error "Edit your message to use only one charset"))
(setq struct (nconc nstruct struct)))))))
(unless (eobp)
(forward-line 1))
(nreverse struct)))
-(defun mml-parse-singlepart-with-multiple-charsets
+(defun mml-parse-singlepart-with-multiple-charsets
(orig-tag beg end &optional use-ascii)
(save-excursion
(save-restriction
(defun mml-read-tag ()
"Read a tag and return the contents."
- (let (contents name elem val)
+ (let ((orig-point (point))
+ contents name elem val)
(forward-char 2)
(setq name (buffer-substring-no-properties
(point) (progn (forward-sexp 1) (point))))
(goto-char (match-end 0))
;; Don't skip the leading space.
;;(skip-chars-forward " \t\n")
+ ;; Put the tag location into the returned contents
+ (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."
(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)
<
projects / gnus / blobdiff