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."
58 (let (struct tag point contents charsets warn)
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 "<#external")
65 (push (nconc (mml-read-tag) (list (cons 'contents (mml-read-part))))
68 (if (looking-at "<#part")
69 (setq tag (mml-read-tag))
70 (setq tag (list 'part '(type . "text/plain"))
73 contents (mml-read-part)
74 charsets (delq 'ascii (mm-find-charset-region point (point))))
75 (if (< (length charsets) 2)
76 (push (nconc tag (list (cons 'contents contents)))
78 (let ((nstruct (mml-parse-singlepart-with-multiple-charsets
84 "Warning: Your message contains %d parts. Really send? "
86 (error "Edit your message to use only one charset"))
87 (setq struct (nconc nstruct struct))))))
92 (defun mml-parse-singlepart-with-multiple-charsets (orig-tag beg end)
94 (narrow-to-region beg end)
95 (goto-char (point-min))
96 (let ((current (char-charset (following-char)))
97 charset struct space newline paragraph)
100 ;; The charset remains the same.
101 ((or (eq (setq charset (char-charset (following-char))) 'ascii)
102 (eq charset current)))
103 ;; The initial charset was ascii.
105 (setq current charset))
106 ;; We have a change in charsets.
110 (list (cons 'contents
112 beg (or paragraph newline space (point))))))
114 (setq beg (or paragraph newline space (point))
119 ;; Compute places where it might be nice to break the part.
121 ((memq (following-char) '(? ?\t))
122 (setq space (1+ (point))))
123 ((eq (following-char) ?\n)
124 (setq newline (1+ (point))))
125 ((and (eq (following-char) ?\n)
127 (eq (char-after (1- (point))) ?\n))
128 (setq paragraph (point))))
130 ;; Do the final part.
131 (unless (= beg (point))
132 (push (append orig-tag
133 (list (cons 'contents
134 (buffer-substring beg (point)))))
138 (defun mml-read-tag ()
139 "Read a tag and return the contents."
140 (let (contents name elem val)
142 (setq name (buffer-substring (point) (progn (forward-sexp 1) (point))))
143 (skip-chars-forward " \t\n")
144 (while (not (looking-at ">"))
145 (setq elem (buffer-substring (point) (progn (forward-sexp 1) (point))))
146 (skip-chars-forward "= \t\n")
147 (setq val (buffer-substring (point) (progn (forward-sexp 1) (point))))
148 (when (string-match "^\"\\(.*\\)\"$" val)
149 (setq val (match-string 1 val)))
150 (push (cons (intern elem) val) contents)
151 (skip-chars-forward " \t\n"))
153 (cons (intern name) (nreverse contents))))
155 (defun mml-read-part ()
156 "Return the buffer up till the next part, multipart or closing part or multipart."
158 ;; If the tag ended at the end of the line, we go to the next line.
159 (when (looking-at "[ \t]*\n")
161 (if (re-search-forward
162 "<#\\(/\\)?\\(multipart\\|part\\|external\\)." nil t)
164 (buffer-substring beg (match-beginning 0))
165 (if (or (not (match-beginning 1))
166 (equal (match-string 2) "multipart"))
167 (goto-char (match-beginning 0))
168 (when (looking-at "[ \t]*\n")
170 (buffer-substring beg (goto-char (point-max))))))
172 (defvar mml-boundary nil)
173 (defvar mml-base-boundary "=-=-=")
174 (defvar mml-multipart-number 0)
176 (defun mml-generate-mime ()
177 "Generate a MIME message based on the current MML document."
178 (let ((cont (mml-parse))
179 (mml-multipart-number 0))
183 (if (and (consp (car cont))
185 (mml-generate-mime-1 (car cont))
186 (mml-generate-mime-1 (nconc (list 'multipart '(type . "mixed"))
190 (defun mml-generate-mime-1 (cont)
192 ((eq (car cont) 'part)
193 (let (coded encoding charset filename type)
194 (setq type (or (cdr (assq 'type cont)) "text/plain"))
195 (if (equal (car (split-string type "/")) "text")
197 (if (setq filename (cdr (assq 'filename cont)))
198 (insert-file-contents-literally filename)
200 (narrow-to-region (point) (point))
201 (insert (cdr (assq 'contents cont)))
202 ;; Remove quotes from quoted tags.
203 (goto-char (point-min))
204 (while (re-search-forward
205 "<#!+/?\\(part\\|multipart\\|external\\)" nil t)
206 (delete-region (+ (match-beginning 0) 2)
207 (+ (match-beginning 0) 3)))))
208 (setq charset (mm-encode-body)
209 encoding (mm-body-encoding))
210 (setq coded (buffer-string)))
211 (mm-with-unibyte-buffer
212 (if (setq filename (cdr (assq 'filename cont)))
213 (insert-file-contents-literally filename)
214 (insert (cdr (assq 'contents cont))))
215 (setq encoding (mm-encode-buffer type)
216 coded (buffer-string))))
217 (mml-insert-mime-headers cont type charset encoding)
220 ((eq (car cont) 'external)
221 (insert "Content-Type: message/external-body")
222 (let ((parameters (mml-parameter-string
223 cont '(expiration size permission)))
224 (name (cdr (assq 'name cont))))
226 (setq name (mml-parse-file-name name))
228 (insert ";\n " (mail-header-encode-parameter "name" name)
229 "\";\n access-type=local-file")
232 (mail-header-encode-parameter
233 "name" (file-name-nondirectory (nth 2 name)))
234 (mail-header-encode-parameter "site" (nth 1 name))
235 (mail-header-encode-parameter
236 "directory" (file-name-directory (nth 2 name)))))
237 (insert ";\n access-type="
238 (if (member (nth 0 name) '("ftp@" "anonymous@"))
242 (insert parameters)))
244 (insert "Content-Type: " (cdr (assq 'type cont)) "\n")
245 (insert "Content-ID: " (message-make-message-id) "\n")
246 (insert "Content-Transfer-Encoding: "
247 (or (cdr (assq 'encoding cont)) "binary"))
249 (insert (or (cdr (assq 'contents cont))))
251 ((eq (car cont) 'multipart)
252 (let ((mml-boundary (mml-compute-boundary cont)))
253 (insert (format "Content-Type: multipart/%s; boundary=\"%s\"\n"
254 (or (cdr (assq 'type cont)) "mixed")
257 (setq cont (cddr cont))
259 (insert "\n--" mml-boundary "\n")
260 (mml-generate-mime-1 (pop cont)))
261 (insert "\n--" mml-boundary "--\n")))
263 (error "Invalid element: %S" cont))))
265 (defun mml-compute-boundary (cont)
266 "Return a unique boundary that does not exist in CONT."
267 (let ((mml-boundary (mml-make-boundary)))
268 ;; This function tries again and again until it has found
269 ;; a unique boundary.
270 (while (not (catch 'not-unique
271 (mml-compute-boundary-1 cont))))
274 (defun mml-compute-boundary-1 (cont)
277 ((eq (car cont) 'part)
279 (if (setq filename (cdr (assq 'filename cont)))
280 (insert-file-contents-literally filename)
281 (insert (cdr (assq 'contents cont))))
282 (goto-char (point-min))
283 (when (re-search-forward (concat "^--" (regexp-quote mml-boundary))
285 (setq mml-boundary (mml-make-boundary))
286 (throw 'not-unique nil))))
287 ((eq (car cont) 'multipart)
288 (mapcar 'mml-compute-boundary-1 (cddr cont))))
291 (defun mml-make-boundary ()
292 (concat (make-string (% (incf mml-multipart-number) 60) ?=)
293 (if (> mml-multipart-number 17)
294 (format "%x" mml-multipart-number)
298 (defun mml-make-string (num string)
300 (while (not (zerop (decf num)))
301 (setq out (concat out string)))
304 (defun mml-insert-mime-headers (cont type charset encoding)
305 (let (parameters disposition description)
308 (mml-parameter-string
309 cont '(name access-type expiration size permission)))
310 (not (equal type "text/plain")))
311 (when (listp charset)
313 "Can't encode a part with several charsets. Insert a <#part>."))
314 (insert "Content-Type: " type)
316 (insert "; " (mail-header-encode-parameter
317 "charset" (symbol-name charset))))
321 (when (or (setq disposition (cdr (assq 'disposition cont)))
323 (mml-parameter-string
324 cont '(filename creation-date modification-date
326 (insert "Content-Disposition: " (or disposition "inline"))
330 (unless (eq encoding '7bit)
331 (insert (format "Content-Transfer-Encoding: %s\n" encoding)))
332 (when (setq description (cdr (assq 'description cont)))
333 (insert "Content-Description: " description "\n"))))
335 (defun mml-parameter-string (cont types)
338 (while (setq type (pop types))
339 (when (setq value (cdr (assq type cont)))
340 (setq string (concat string ";\n "
341 (mail-header-encode-parameter
342 (symbol-name type) value)))))
343 (when (not (zerop (length string)))
346 (defvar ange-ftp-path-format)
347 (defvar efs-path-regexp)
348 (defun mml-parse-file-name (path)
349 (if (if (boundp 'efs-path-regexp)
350 (string-match efs-path-regexp path)
351 (if (boundp 'ange-ftp-path-format)
352 (string-match (car ange-ftp-path-format))))
353 (list (match-string 1 path) (match-string 2 path)
354 (substring path (1+ (match-end 2))))