git.chise.org Git - elisp/gnus.git-/blob - 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 (re-search-forward "<#/?\\(multi\\)?part." nil t)
  88         (prog1
  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))))))
  93
  94 (defvar mml-boundary nil)
  95
  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)))
 100     (with-temp-buffer
 101       (if (and (consp (car cont))
 102                (= (length cont) 1))
 103           (mml-generate-mime-1 (car cont))
 104         (mml-generate-mime-1 (nconc (list 'multipart '(type . "mixed"))
 105                                     cont)))
 106       (buffer-string))))
 107
 108 (defun mml-generate-mime-1 (cont)
 109   (cond
 110    ((eq (car cont) 'part)
 111     (let (coded encoding charset filename type)
 112       (setq type (or (cdr (assq 'type cont)) "text/plain"))
 113       (with-temp-buffer
 114         (if (setq filename (cdr (assq 'filename cont)))
 115             (insert-file-contents-literally filename)
 116           (save-restriction
 117             (narrow-to-region (point) (point))
 118             (insert (cdr (assq 'contents cont)))
 119             (goto-char (point-min))
 120             (while (re-search-forward "<#!+\\(part\\|multipart\\)" nil t)
 121               (delete-region (+ (match-beginning 0) 2)
 122                              (+ (match-beginning 0) 3)))))
 123         (if (equal (car (split-string type "/")) "text")
 124             (setq charset (mm-encode-body)
 125                   encoding (mm-body-encoding))
 126           (setq encoding (mm-encode-buffer type)))
 127         (setq coded (buffer-string)))
 128       (when (or charset
 129                 (not (equal type "text/plain")))
 130         (insert "Content-Type: " type))
 131       (when charset
 132         (insert (format "; charset=\"%s\"" charset)))
 133       (insert "\n")
 134       (unless (eq encoding '7bit)
 135         (insert (format "Content-Transfer-Encoding: %s\n" encoding)))
 136       (insert "\n")
 137       (insert coded)))
 138    ((eq (car cont) 'multipart)
 139     (let ((mml-boundary (concat "=" mml-boundary)))
 140       (insert (format "Content-Type: multipart/%s; boundary=\"%s\"\n"
 141                       (or (cdr (assq 'type cont)) "mixed")
 142                       mml-boundary))
 143       (insert "\n")
 144       (setq cont (cddr cont))
 145       (while cont
 146         (insert "--" mml-boundary "\n")
 147         (mml-generate-mime-1 (pop cont)))
 148       (insert "--" mml-boundary "--\n")))
 149    (t
 150     (error "Invalid element: %S" cont))))
 151
 152 (provide 'mml)
 153
 154 ;;; mml.el ends here