fab6be2dd0fa6690bc06589da4aa21ce5d914519
[elisp/gnus.git-] / lisp / mml.el
1 ;;; mml.el --- A package for parsing and validating MML documents
2 ;; Copyright (C) 1998 Free Software Foundation, Inc.
3
4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
5 ;; This file is part of GNU Emacs.
6
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)
10 ;; any later version.
11
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.
16
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.
21
22 ;;; Commentary:
23
24 ;;; Code:
25
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)
37     table))
38
39 (defun mml-parse ()
40   "Parse the current buffer as an MML document."
41   (goto-char (point-min))
42   (let ((table (syntax-table)))
43     (unwind-protect
44         (progn
45           (set-syntax-table mml-syntax-table)
46           (mml-parse-1))
47       (set-syntax-table table))))
48   
49 (defun mml-parse-1 ()
50   "Parse the current buffer as an MML document."
51   (let (struct)
52     (while (and (not (eobp))
53                 (not (looking-at "</#multipart")))
54       (cond
55        ((looking-at "<#multipart")
56         (push (nconc (mml-read-tag) (mml-parse-1)) struct))
57        ((looking-at "<#part")
58         (push (nconc (mml-read-tag) (list (cons 'contents (mml-read-part))))
59               struct))
60        (t
61         (push (list 'part '(type . "text/plain")
62                     (cons 'contents (mml-read-part))) struct))))
63     (unless (eobp)
64       (forward-line 1))
65     (nreverse struct)))
66
67 (defun mml-read-tag ()
68   "Read a tag and return the contents."
69   (let (contents name elem val)
70     (forward-char 2)
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"))
81     (forward-char 1)
82     (cons (intern name) (nreverse contents))))
83
84 (defun mml-read-part ()
85   "Return the buffer up till the next part, multipart or closing part or multipart."
86   (let ((beg (point)))
87     ;; If the tag ended at the end of the line, we go to the next line.
88     (when (looking-at "[ \t]*\n")
89       (forward-line 1))
90     (if (re-search-forward "<#/?\\(multi\\)?part." nil t)
91         (prog1
92             (buffer-substring beg (match-beginning 0))
93           (if (not (equal (match-string 0) "<#/part>"))
94               (goto-char (match-beginning 0))
95             (when (looking-at "[ \t]*\n")
96               (forward-line 1))))
97       (buffer-substring beg (goto-char (point-max))))))
98
99 (defvar mml-boundary nil)
100
101 (defun mml-generate-mime ()
102   "Generate a MIME message based on the current MML document."
103   (setq mml-boundary "=-=-=")
104   (let ((cont (mml-parse)))
105     (with-temp-buffer
106       (if (and (consp (car cont))
107                (= (length cont) 1))
108           (mml-generate-mime-1 (car cont))
109         (mml-generate-mime-1 (nconc (list 'multipart '(type . "mixed"))
110                                     cont)))
111       (buffer-string))))
112
113 (defun mml-generate-mime-1 (cont)
114   (cond
115    ((eq (car cont) 'part)
116     (let (coded encoding charset filename type)
117       (setq type (or (cdr (assq 'type cont)) "text/plain"))
118       (if (equal (car (split-string type "/")) "text")
119           (with-temp-buffer
120             (if (setq filename (cdr (assq 'filename cont)))
121                 (insert-file-contents-literally filename)
122               (save-restriction
123                 (narrow-to-region (point) (point))
124                 (insert (cdr (assq 'contents cont)))
125                 ;; Remove quotes from quoted tags.
126                 (goto-char (point-min))
127                 (while (re-search-forward "<#!+\\(part\\|multipart\\)" nil t)
128                   (delete-region (+ (match-beginning 0) 2)
129                                  (+ (match-beginning 0) 3)))))
130             (setq charset (mm-encode-body)
131                   encoding (mm-body-encoding))
132             (setq coded (buffer-string)))
133         (mm-with-unibyte-buffer
134           (if (setq filename (cdr (assq 'filename cont)))
135               (insert-file-contents-literally filename)
136             (insert (cdr (assq 'contents cont))))
137           (setq coded (buffer-string))))
138       (when (or charset
139                 (not (equal type "text/plain")))
140         (insert "Content-Type: " type)
141         (when charset
142           (insert (format "; charset=\"%s\"" charset)))
143         (insert "\n"))
144       (unless (eq encoding '7bit)
145         (insert (format "Content-Transfer-Encoding: %s\n" encoding)))
146       (insert "\n")
147       (insert coded)))
148    ((eq (car cont) 'multipart)
149     (let ((mml-boundary (concat "=" mml-boundary)))
150       (insert (format "Content-Type: multipart/%s; boundary=\"%s\"\n"
151                       (or (cdr (assq 'type cont)) "mixed")
152                       mml-boundary))
153       (insert "\n")
154       (setq cont (cddr cont))
155       (while cont
156         (unless (bolp)
157           (insert "\n"))
158         (insert "--" mml-boundary "\n")
159         (mml-generate-mime-1 (pop cont)))
160       (unless (bolp)
161         (insert "\n"))
162       (insert "--" mml-boundary "--\n")))
163    (t
164     (error "Invalid element: %S" cont))))
165
166 (provide 'mml)
167
168 ;;; mml.el ends here