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 (require 'mm-util)
  27 (require 'mm-bodies)
  28 (require 'mm-encode)
  29
  30 (defvar mml-syntax-table
  31   (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table)))
  32     (modify-syntax-entry ?\\ "/" table)
  33     (modify-syntax-entry ?< "(" table)
  34     (modify-syntax-entry ?> ")" table)
  35     (modify-syntax-entry ?@ "w" table)
  36     (modify-syntax-entry ?/ "w" table)
  37     (modify-syntax-entry ?= " " table)
  38     (modify-syntax-entry ?* " " table)
  39     (modify-syntax-entry ?\; " " table)
  40     (modify-syntax-entry ?\' " " table)
  41     table))
  42
  43 (defun mml-parse ()
  44   "Parse the current buffer as an MML document."
  45   (goto-char (point-min))
  46   (let ((table (syntax-table)))
  47     (unwind-protect
  48         (progn
  49           (set-syntax-table mml-syntax-table)
  50           (mml-parse-1))
  51       (set-syntax-table table))))
  52
  53 (defun mml-parse-1 ()
  54   "Parse the current buffer as an MML document."
  55   (let (struct)
  56     (while (and (not (eobp))
  57                 (not (looking-at "<#/multipart")))
  58       (cond
  59        ((looking-at "<#multipart")
  60         (push (nconc (mml-read-tag) (mml-parse-1)) struct))
  61        ((looking-at "<#part")
  62         (push (nconc (mml-read-tag) (list (cons 'contents (mml-read-part))))
  63               struct))
  64        (t
  65         (push (list 'part '(type . "text/plain")
  66                     (cons 'contents (mml-read-part))) struct))))
  67     (unless (eobp)
  68       (forward-line 1))
  69     (nreverse struct)))
  70
  71 (defun mml-read-tag ()
  72   "Read a tag and return the contents."
  73   (let (contents name elem val)
  74     (forward-char 2)
  75     (setq name (buffer-substring (point) (progn (forward-sexp 1) (point))))
  76     (skip-chars-forward " \t\n")
  77     (while (not (looking-at ">"))
  78       (setq elem (buffer-substring (point) (progn (forward-sexp 1) (point))))
  79       (skip-chars-forward "= \t\n")
  80       (setq val (buffer-substring (point) (progn (forward-sexp 1) (point))))
  81       (when (string-match "^\"\\(.*\\)\"$" val)
  82         (setq val (match-string 1 val)))
  83       (push (cons (intern elem) val) contents)
  84       (skip-chars-forward " \t\n"))
  85     (forward-char 1)
  86     (cons (intern name) (nreverse contents))))
  87
  88 (defun mml-read-part ()
  89   "Return the buffer up till the next part, multipart or closing part or multipart."
  90   (let ((beg (point)))
  91     ;; If the tag ended at the end of the line, we go to the next line.
  92     (when (looking-at "[ \t]*\n")
  93       (forward-line 1))
  94     (if (re-search-forward "<#/?\\(multi\\)?part." nil t)
  95         (prog1
  96             (buffer-substring beg (match-beginning 0))
  97           (if (not (equal (match-string 0) "<#/part>"))
  98               (goto-char (match-beginning 0))
  99             (when (looking-at "[ \t]*\n")
 100               (forward-line 1))))
 101       (buffer-substring beg (goto-char (point-max))))))
 102
 103 (defvar mml-boundary nil)
 104 (defvar mml-base-boundary "=-=-=")
 105 (defvar mml-multipart-number 0)
 106
 107 (defun mml-generate-mime ()
 108   "Generate a MIME message based on the current MML document."
 109   (let ((cont (mml-parse))
 110         (mml-multipart-number 0))
 111     (with-temp-buffer
 112       (if (and (consp (car cont))
 113                (= (length cont) 1))
 114           (mml-generate-mime-1 (car cont))
 115         (mml-generate-mime-1 (nconc (list 'multipart '(type . "mixed"))
 116                                     cont)))
 117       (buffer-string))))
 118
 119 (defun mml-generate-mime-1 (cont)
 120   (cond
 121    ((eq (car cont) 'part)
 122     (let (coded encoding charset filename type)
 123       (setq type (or (cdr (assq 'type cont)) "text/plain"))
 124       (if (equal (car (split-string type "/")) "text")
 125           (with-temp-buffer
 126             (if (setq filename (cdr (assq 'filename cont)))
 127                 (insert-file-contents-literally filename)
 128               (save-restriction
 129                 (narrow-to-region (point) (point))
 130                 (insert (cdr (assq 'contents cont)))
 131                 ;; Remove quotes from quoted tags.
 132                 (goto-char (point-min))
 133                 (while (re-search-forward "<#!+\\(part\\|multipart\\)" nil t)
 134                   (delete-region (+ (match-beginning 0) 2)
 135                                  (+ (match-beginning 0) 3)))))
 136             (setq charset (mm-encode-body)
 137                   encoding (mm-body-encoding))
 138             (setq coded (buffer-string)))
 139         (mm-with-unibyte-buffer
 140           (if (setq filename (cdr (assq 'filename cont)))
 141               (insert-file-contents-literally filename)
 142             (insert (cdr (assq 'contents cont))))
 143           (setq encoding (mm-encode-buffer type)
 144                 coded (buffer-string))))
 145       (when (or charset
 146                 (not (equal type "text/plain")))
 147         (insert "Content-Type: " type)
 148         (when charset
 149           (insert (format "; charset=\"%s\"" charset)))
 150         (insert "\n"))
 151       (unless (eq encoding '7bit)
 152         (insert (format "Content-Transfer-Encoding: %s\n" encoding)))
 153       (insert "\n")
 154       (insert coded)))
 155    ((eq (car cont) 'multipart)
 156     (let ((mml-boundary (mml-compute-boundary cont)))
 157       (insert (format "Content-Type: multipart/%s; boundary=\"%s\"\n"
 158                       (or (cdr (assq 'type cont)) "mixed")
 159                       mml-boundary))
 160       (insert "\n")
 161       (setq cont (cddr cont))
 162       (while cont
 163         (insert "\n--" mml-boundary "\n")
 164         (mml-generate-mime-1 (pop cont)))
 165       (insert "\n--" mml-boundary "--\n")))
 166    (t
 167     (error "Invalid element: %S" cont))))
 168
 169 (defun mml-compute-boundary (cont)
 170   "Return a unique boundary that does not exist in CONT."
 171   (let ((mml-boundary (mml-make-boundary)))
 172     ;; This function tries again and again until it has found
 173     ;; a unique boundary.
 174     (while (not (catch 'not-unique
 175                   (mml-compute-boundary-1 cont))))
 176     mml-boundary))
 177
 178 (defun mml-compute-boundary-1 (cont)
 179   (let (filename)
 180     (cond
 181      ((eq (car cont) 'part)
 182       (with-temp-buffer
 183         (if (setq filename (cdr (assq 'filename cont)))
 184             (insert-file-contents-literally filename)
 185           (insert (cdr (assq 'contents cont))))
 186         (goto-char (point-min))
 187         (when (re-search-forward (concat "^--" mml-boundary) nil t)
 188           (setq mml-boundary (mml-make-boundary))
 189           (throw 'not-unique nil))))
 190      ((eq (car cont) 'multipart)
 191       (mapcar 'mml-compute-boundary-1 (cddr cont))))
 192     t))
 193
 194 (defun mml-make-boundary ()
 195   (concat (mml-make-string (% (incf mml-multipart-number) 60) "=")
 196           (if (> mml-multipart-number 17)
 197               (format "%x" mml-multipart-number)
 198             "")
 199           mml-base-boundary))
 200
 201 (defun mml-make-string (num string)
 202   (let ((out ""))
 203     (while (not (zerop (decf num)))
 204       (setq out (concat out string)))
 205     out))
 206
 207 (provide 'mml)
 208
 209 ;;; mml.el ends here