1 ;;; mml.el --- A package for parsing and validating MML documents
2 ;; Copyright (C) 1998 Free Software Foundation, Inc.
4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5 ;; This file is part of GNU Emacs.
7 ;; GNU Emacs is free software; you can redistribute it and/or modify
8 ;; it under the terms of the GNU General Public License as published by
9 ;; the Free Software Foundation; either version 2, or (at your option)
12 ;; GNU Emacs is distributed in the hope that it will be useful,
13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ;; GNU General Public License for more details.
17 ;; You should have received a copy of the GNU General Public License
18 ;; along with GNU Emacs; see the file COPYING. If not, write to the
19 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 ;; Boston, MA 02111-1307, USA.
31 (autoload 'message-make-message-id "message"))
33 (defvar mml-syntax-table
34 (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table)))
35 (modify-syntax-entry ?\\ "/" table)
36 (modify-syntax-entry ?< "(" table)
37 (modify-syntax-entry ?> ")" table)
38 (modify-syntax-entry ?@ "w" table)
39 (modify-syntax-entry ?/ "w" table)
40 (modify-syntax-entry ?= " " table)
41 (modify-syntax-entry ?* " " table)
42 (modify-syntax-entry ?\; " " table)
43 (modify-syntax-entry ?\' " " table)
47 "Parse the current buffer as an MML document."
48 (goto-char (point-min))
49 (let ((table (syntax-table)))
52 (set-syntax-table mml-syntax-table)
54 (set-syntax-table table))))
57 "Parse the current buffer as an MML document."
59 (while (and (not (eobp))
60 (not (looking-at "<#/multipart")))
62 ((looking-at "<#multipart")
63 (push (nconc (mml-read-tag) (mml-parse-1)) struct))
64 ((looking-at "<#part")
65 (push (nconc (mml-read-tag) (list (cons 'contents (mml-read-part))))
67 ((looking-at "<#external")
68 (push (nconc (mml-read-tag) (list (cons 'contents (mml-read-part))))
71 (push (list 'part '(type . "text/plain")
72 (cons 'contents (mml-read-part))) struct))))
77 (defun mml-read-tag ()
78 "Read a tag and return the contents."
79 (let (contents name elem val)
81 (setq name (buffer-substring (point) (progn (forward-sexp 1) (point))))
82 (skip-chars-forward " \t\n")
83 (while (not (looking-at ">"))
84 (setq elem (buffer-substring (point) (progn (forward-sexp 1) (point))))
85 (skip-chars-forward "= \t\n")
86 (setq val (buffer-substring (point) (progn (forward-sexp 1) (point))))
87 (when (string-match "^\"\\(.*\\)\"$" val)
88 (setq val (match-string 1 val)))
89 (push (cons (intern elem) val) contents)
90 (skip-chars-forward " \t\n"))
92 (cons (intern name) (nreverse contents))))
94 (defun mml-read-part ()
95 "Return the buffer up till the next part, multipart or closing part or multipart."
97 ;; If the tag ended at the end of the line, we go to the next line.
98 (when (looking-at "[ \t]*\n")
100 (if (re-search-forward
101 "<#\\(/\\)?\\(multipart\\|part\\|external\\)." nil t)
103 (buffer-substring beg (match-beginning 0))
104 (if (or (not (match-beginning 1))
105 (equal (match-string 2) "multipart"))
106 (goto-char (match-beginning 0))
107 (when (looking-at "[ \t]*\n")
109 (buffer-substring beg (goto-char (point-max))))))
111 (defvar mml-boundary nil)
112 (defvar mml-base-boundary "=-=-=")
113 (defvar mml-multipart-number 0)
115 (defun mml-generate-mime ()
116 "Generate a MIME message based on the current MML document."
117 (let ((cont (mml-parse))
118 (mml-multipart-number 0))
122 (if (and (consp (car cont))
124 (mml-generate-mime-1 (car cont))
125 (mml-generate-mime-1 (nconc (list 'multipart '(type . "mixed"))
129 (defun mml-generate-mime-1 (cont)
131 ((eq (car cont) 'part)
132 (let (coded encoding charset filename type parameters)
133 (setq type (or (cdr (assq 'type cont)) "text/plain"))
134 (if (equal (car (split-string type "/")) "text")
136 (if (setq filename (cdr (assq 'filename cont)))
137 (insert-file-contents-literally filename)
139 (narrow-to-region (point) (point))
140 (insert (cdr (assq 'contents cont)))
141 ;; Remove quotes from quoted tags.
142 (goto-char (point-min))
143 (while (re-search-forward
144 "<#!+\\(part\\|multipart\\|external\\)" nil t)
145 (delete-region (+ (match-beginning 0) 2)
146 (+ (match-beginning 0) 3)))))
147 (setq charset (mm-encode-body)
148 encoding (mm-body-encoding))
149 (setq coded (buffer-string)))
150 (mm-with-unibyte-buffer
151 (if (setq filename (cdr (assq 'filename cont)))
152 (insert-file-contents-literally filename)
153 (insert (cdr (assq 'contents cont))))
154 (setq encoding (mm-encode-buffer type)
155 coded (buffer-string))))
156 (mml-insert-mime-headers cont type charset encoding)
159 ((eq (car cont) 'external)
160 (insert "Content-Type: message/external-body")
161 (let ((parameters (mml-parameter-string
162 cont '(expiration size permission)))
163 (name (cdr (assq 'name cont))))
165 (setq name (mml-parse-file-name name))
167 (insert ";\n name=\"" (prin1-to-string name)
168 "\";\n access-type=local-file")
170 (format ";\n name=%S;\n site=%S;\n directory=%S"
171 (file-name-nondirectory (nth 2 name))
173 (file-name-directory (nth 2 name))))
174 (insert ";\n access-type="
175 (if (member (nth 0 name) '("ftp@" "anonymous@"))
179 (insert parameters)))
181 (insert "Content-Type: " (cdr (assq 'type cont)) "\n")
182 (insert "Content-ID: " (message-make-message-id) "\n")
183 (insert "Content-Transfer-Encoding: "
184 (or (cdr (assq 'encoding cont)) "binary"))
186 (insert (or (cdr (assq 'contents cont))))
188 ((eq (car cont) 'multipart)
189 (let ((mml-boundary (mml-compute-boundary cont)))
190 (insert (format "Content-Type: multipart/%s; boundary=\"%s\"\n"
191 (or (cdr (assq 'type cont)) "mixed")
194 (setq cont (cddr cont))
196 (insert "\n--" mml-boundary "\n")
197 (mml-generate-mime-1 (pop cont)))
198 (insert "\n--" mml-boundary "--\n")))
200 (error "Invalid element: %S" cont))))
202 (defun mml-compute-boundary (cont)
203 "Return a unique boundary that does not exist in CONT."
204 (let ((mml-boundary (mml-make-boundary)))
205 ;; This function tries again and again until it has found