From: ichikawa <ichikawa>
Date: Sun, 15 Nov 1998 03:02:23 +0000 (+0000)
Subject: Sync up with pgnus-0.46
X-Git-Tag: pgnus-ichikawa-199811302358~57
X-Git-Url: http://git.chise.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=ca2bfab819f3b8e1e31932f20d4aab4fb1a85d0d;p=elisp%2Fgnus.git-

Sync up with pgnus-0.46
---

diff --git a/lisp/mml.el b/lisp/mml.el
new file mode 100644
index 0000000..c31e7fd
--- /dev/null
+++ b/lisp/mml.el
@@ -0,0 +1,148 @@
+;;; mml.el --- A package for parsing and validating MML documents
+;; Copyright (C) 1998 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.	 See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(defvar mml-syntax-table
+  (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table)))
+    (modify-syntax-entry ?\\ "/" table)
+    (modify-syntax-entry ?< "(" table)
+    (modify-syntax-entry ?> ")" table)
+    (modify-syntax-entry ?@ "w" table)
+    (modify-syntax-entry ?/ "w" table)
+    (modify-syntax-entry ?= " " table)
+    (modify-syntax-entry ?* " " table)
+    (modify-syntax-entry ?\; " " table)
+    (modify-syntax-entry ?\' " " table)
+    table))
+
+(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))))
+  
+(defun mml-parse-1 ()
+  "Parse the current buffer as an MML document."
+  (let (struct)
+    (while (and (not (eobp))
+		(not (looking-at "</multipart")))
+      (cond
+       ((looking-at "<multipart")
+	(push (nconc (mml-read-tag) (mml-parse-1)) struct))
+       ((looking-at "<part")
+	(push (nconc (mml-read-tag) (list (cons 'contents (mml-read-part))))
+	      struct))
+       (t
+	(push (list 'part '(type . "text/plain")
+		    (cons 'contents (mml-read-part))) struct))))
+    (unless (eobp)
+      (forward-line 1))
+    (nreverse struct)))
+
+(defun mml-read-tag ()
+  "Read a tag and return the contents."
+  (let (contents name elem val)
+    (forward-char 1)
+    (setq name (buffer-substring (point) (progn (forward-sexp 1) (point))))
+    (skip-chars-forward " \t\n")
+    (while (not (looking-at ">"))
+      (setq elem (buffer-substring (point) (progn (forward-sexp 1) (point))))
+      (skip-chars-forward "= \t\n")
+      (setq val (buffer-substring (point) (progn (forward-sexp 1) (point))))
+      (when (string-match "^\"\\(.*\\)\"$" val)
+	(setq val (match-string 1 val)))
+      (push (cons (intern elem) val) contents)
+      (skip-chars-forward " \t\n"))
+    (forward-char 1)
+    (cons (intern name) (nreverse contents))))
+
+(defun mml-read-part ()
+  "Return the buffer up till the next part, multipart or closing part or multipart."
+  (let ((beg (point)))
+    (if (re-search-forward "</?\\(multi\\)?part." nil t)
+	(prog1
+	    (buffer-substring beg (match-beginning 0))
+	  (unless (equal (match-string 0) "</part>")
+	    (goto-char (match-beginning 0))))
+      (buffer-substring beg (goto-char (point-max))))))
+
+(defvar mml-boundary nil)
+
+(defun mml-generate-mime ()
+  "Generate a MIME message based on the current MML document."
+  (setq mml-boundary "=-=-=")
+  (let ((cont (mml-parse)))
+    (with-temp-buffer
+      (if (and (consp (car cont))
+	       (= (length cont) 1))
+	  (mml-generate-mime-1 (car cont))
+	(mml-generate-mime-1 (nconc (list 'multipart '(type . "mixed"))
+				    cont)))
+      (buffer-string))))
+
+(defun mml-generate-mime-1 (cont)
+  (cond
+   ((eq (car cont) 'part)
+    (let (coded encoding charset filename type)
+      (setq type (or (cdr (assq 'type cont)) "text/plain"))
+      (with-temp-buffer
+	(if (setq filename (cdr (assq 'filename cont)))
+	    (insert-file-contents-literally filename)
+	  (insert (cdr (assq 'contents cont))))
+	(if (equal (car (split-string type "/")) "text")
+	    (setq charset (mm-encode-body)
+		  encoding (mm-body-encoding))
+	  (setq encoding (mm-encode-buffer type)))
+	(setq coded (buffer-string)))
+      (when (or charset
+		(not (equal type "text/plain")))
+	(insert "Content-Type: " type))
+      (when charset
+	(insert (format "; charset=\"%s\"" charset)))
+      (insert "\n")
+      (unless (eq encoding '7bit)
+	(insert (format "Content-Transfer-Encoding: %s\n" encoding)))
+      (insert "\n")
+      (insert coded)))
+   ((eq (car cont) 'multipart)
+    (let ((mml-boundary (concat "=" mml-boundary)))
+      (insert (format "Content-Type: multipart/%s; boundary=\"%s\"\n"
+		      (or (cdr (assq 'type cont)) "mixed")
+		      mml-boundary))
+      (insert "\n")
+      (setq cont (cddr cont))
+      (while cont
+	(insert "--" mml-boundary "\n")
+	(mml-generate-mime-1 (pop cont)))
+      (insert "--" mml-boundary "--\n")))
+   (t
+    (error "%S" cont))))
+
+(provide 'mml)
+
+;;; mml.el ends here