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.
26 (defvar mml-syntax-table
27 (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table)))
28 (modify-syntax-entry ?\\ "/" table)
29 (modify-syntax-entry ?< "(" table)
30 (modify-syntax-entry ?> ")" table)
31 (modify-syntax-entry ?@ "w" table)
32 (modify-syntax-entry ?/ "w" table)
33 (modify-syntax-entry ?= " " table)
34 (modify-syntax-entry ?* " " table)
35 (modify-syntax-entry ?\; " " table)
36 (modify-syntax-entry ?\' " " table)
40 "Parse the current buffer as an MML document."
41 (goto-char (point-min))
42 (let ((table (syntax-table)))
45 (set-syntax-table mml-syntax-table)
47 (set-syntax-table table))))
50 "Parse the current buffer as an MML document."
52 (while (and (not (eobp))
53 (not (looking-at "</multipart")))
55 ((looking-at "<multipart")
56 (push (nconc (mml-read-tag) (mml-parse-1)) struct))
58 (push (nconc (mml-read-tag) (list (cons 'contents (mml-read-part))))
61 (push (list 'part '(type . "text/plain")
62 (cons 'contents (mml-read-part))) struct))))
67 (defun mml-read-tag ()
68 "Read a tag and return the contents."
69 (let (contents name elem val)
71 (setq name (buffer-substring (point) (progn (forward-sexp 1) (point))))
72 (skip-chars-forward " \t\n")
73 (while (not (looking-at ">"))
74 (setq elem (buffer-substring (point) (progn (forward-sexp 1) (point))))
75 (skip-chars-forward "= \t\n")
76 (setq val (buffer-substring (point) (progn (forward-sexp 1) (point))))
77 (when (string-match "^\"\\(.*\\)\"$" val)
78 (setq val (match-string 1 val)))
79 (push (cons (intern elem) val) contents)
80 (skip-chars-forward " \t\n"))
82 (cons (intern name) (nreverse contents))))
84 (defun mml-read-part ()
85 "Return the buffer up till the next part, multipart or closing part or multipart."
87 (if (re-search-forward "</?\\(multi\\)?part." nil t)
89 (buffer-substring beg (match-beginning 0))
90 (unless (equal (match-string 0) "</part>")
91 (goto-char (match-beginning 0))))
92 (buffer-substring beg (goto-char (point-max))))))
94 (defvar mml-boundary nil)
96 (defun mml-generate-mime ()
97 "Generate a MIME message based on the current MML document."
98 (setq mml-boundary "=-=-=")
99 (let ((cont (mml-parse)))
101 (if (and (consp (car cont))
103 (mml-generate-mime-1 (car cont))
104 (mml-generate-mime-1 (nconc (list 'multipart '(type . "mixed"))
108 (defun mml-generate-mime-1 (cont)
110 ((eq (car cont) 'part)
111 (let (coded encoding charset filename type)
112 (setq type (or (cdr (assq 'type cont)) "text/plain"))
114 (if (setq filename (cdr (assq 'filename cont)))
115 (insert-file-contents-literally filename)
116 (insert (cdr (assq 'contents cont))))
117 (if (equal (car (split-string type "/")) "text")
118 (setq charset (mm-encode-body)
119 encoding (mm-body-encoding))
120 (setq encoding (mm-encode-buffer type)))
121 (setq coded (buffer-string)))
123 (not (equal type "text/plain")))
124 (insert "Content-Type: " type))
126 (insert (format "; charset=\"%s\"" charset)))
128 (unless (eq encoding '7bit)
129 (insert (format "Content-Transfer-Encoding: %s\n" encoding)))
132 ((eq (car cont) 'multipart)
133 (let ((mml-boundary (concat "=" mml-boundary)))
134 (insert (format "Content-Type: multipart/%s; boundary=\"%s\"\n"
135 (or (cdr (assq 'type cont)) "mixed")
138 (setq cont (cddr cont))
140 (insert "--" mml-boundary "\n")
141 (mml-generate-mime-1 (pop cont)))
142 (insert "--" mml-boundary "--\n")))