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 (eval-and-compile
  31   (autoload 'message-make-message-id "message"))
  32
  33 (defvar mml-syntax-table
  34   (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table)))
  35     (modify-syntax-entry ?\\ "/" table)
  36     (modify-syntax-entry ?< "(" table)
  37     (modify-syntax-entry ?> ")" table)
  38     (modify-syntax-entry ?@ "w" table)
  39     (modify-syntax-entry ?/ "w" table)
  40     (modify-syntax-entry ?= " " table)
  41     (modify-syntax-entry ?* " " table)
  42     (modify-syntax-entry ?\; " " table)
  43     (modify-syntax-entry ?\' " " table)
  44     table))
  45
  46 (defun mml-parse ()
  47   "Parse the current buffer as an MML document."
  48   (goto-char (point-min))
  49   (let ((table (syntax-table)))
  50     (unwind-protect
  51         (progn
  52           (set-syntax-table mml-syntax-table)
  53           (mml-parse-1))
  54       (set-syntax-table table))))
  55
  56 (defun mml-parse-1 ()
  57   "Parse the current buffer as an MML document."
  58   (let (struct)
  59     (while (and (not (eobp))
  60                 (not (looking-at "<#/multipart")))
  61       (cond
  62        ((looking-at "<#multipart")
  63         (push (nconc (mml-read-tag) (mml-parse-1)) struct))
  64        ((looking-at "<#part")
  65         (push (nconc (mml-read-tag) (list (cons 'contents (mml-read-part))))
  66               struct))
  67        ((looking-at "<#external")
  68         (push (nconc (mml-read-tag) (list (cons 'contents (mml-read-part))))
  69               struct))
  70        (t
  71         (push (list 'part '(type . "text/plain")
  72                     (cons 'contents (mml-read-part))) struct))))
  73     (unless (eobp)
  74       (forward-line 1))
  75     (nreverse struct)))
  76
  77 (defun mml-read-tag ()
  78   "Read a tag and return the contents."
  79   (let (contents name elem val)
  80     (forward-char 2)
  81     (setq name (buffer-substring (point) (progn (forward-sexp 1) (point))))
  82     (skip-chars-forward " \t\n")
  83     (while (not (looking-at ">"))
  84       (setq elem (buffer-substring (point) (progn (forward-sexp 1) (point))))
  85       (skip-chars-forward "= \t\n")
  86       (setq val (buffer-substring (point) (progn (forward-sexp 1) (point))))
  87       (when (string-match "^\"\\(.*\\)\"$" val)
  88         (setq val (match-string 1 val)))
  89       (push (cons (intern elem) val) contents)
  90       (skip-chars-forward " \t\n"))
  91     (forward-char 1)
  92     (cons (intern name) (nreverse contents))))
  93
  94 (defun mml-read-part ()
  95   "Return the buffer up till the next part, multipart or closing part or multipart."
  96   (let ((beg (point)))
  97     ;; If the tag ended at the end of the line, we go to the next line.
  98     (when (looking-at "[ \t]*\n")
  99       (forward-line 1))
 100     (if (re-search-forward
 101          "<#\\(/\\)?\\(multipart\\|part\\|external\\)." nil t)
 102         (prog1
 103             (buffer-substring beg (match-beginning 0))
 104           (if (or (not (match-beginning 1))
 105                   (equal (match-string 2) "multipart"))
 106               (goto-char (match-beginning 0))
 107             (when (looking-at "[ \t]*\n")
 108               (forward-line 1))))
 109       (buffer-substring beg (goto-char (point-max))))))
 110
 111 (defvar mml-boundary nil)
 112 (defvar mml-base-boundary "=-=-=")
 113 (defvar mml-multipart-number 0)
 114
 115 (defun mml-generate-mime ()
 116   "Generate a MIME message based on the current MML document."
 117   (let ((cont (mml-parse))
 118         (mml-multipart-number 0))
 119     (if (not cont)
 120         nil
 121       (with-temp-buffer
 122         (if (and (consp (car cont))
 123                  (= (length cont) 1))
 124             (mml-generate-mime-1 (car cont))
 125           (mml-generate-mime-1 (nconc (list 'multipart '(type . "mixed"))
 126                                       cont)))
 127         (buffer-string)))))
 128
 129 (defun mml-generate-mime-1 (cont)
 130   (cond
 131    ((eq (car cont) 'part)
 132     (let (coded encoding charset filename type parameters)
 133       (setq type (or (cdr (assq 'type cont)) "text/plain"))
 134       (if (equal (car (split-string type "/")) "text")
 135           (with-temp-buffer
 136             (if (setq filename (cdr (assq 'filename cont)))
 137                 (insert-file-contents-literally filename)
 138               (save-restriction
 139                 (narrow-to-region (point) (point))
 140                 (insert (cdr (assq 'contents cont)))
 141                 ;; Remove quotes from quoted tags.
 142                 (goto-char (point-min))
 143                 (while (re-search-forward
 144                         "<#!+\\(part\\|multipart\\|external\\)" nil t)
 145                   (delete-region (+ (match-beginning 0) 2)
 146                                  (+ (match-beginning 0) 3)))))
 147             (setq charset (mm-encode-body)
 148                   encoding (mm-body-encoding))
 149             (setq coded (buffer-string)))
 150         (mm-with-unibyte-buffer
 151           (if (setq filename (cdr (assq 'filename cont)))
 152               (insert-file-contents-literally filename)
 153             (insert (cdr (assq 'contents cont))))
 154           (setq encoding (mm-encode-buffer type)
 155                 coded (buffer-string))))
 156       (mml-insert-mime-headers cont type charset encoding)
 157       (insert "\n")
 158       (insert coded)))
 159    ((eq (car cont) 'external)
 160     (insert "Content-Type: message/external-body")
 161     (let ((parameters (mml-parameter-string
 162                        cont '(expiration size permission)))
 163           (name (cdr (assq 'name cont))))
 164       (when name
 165         (setq name (mml-parse-file-name name))
 166         (if (stringp name)
 167             (insert ";\n " (mail-header-encode-parameter "name" name)
 168                     "\";\n access-type=local-file")
 169           (insert
 170            (format ";\n "
 171                    (mail-header-encode-parameter
 172                     "name" (file-name-nondirectory (nth 2 name)))
 173                    (mail-header-encode-parameter "site" (nth 1 name))
 174                    (mail-header-encode-parameter
 175                     "directory" (file-name-directory (nth 2 name)))))
 176           (insert ";\n access-type="
 177                   (if (member (nth 0 name) '("ftp@" "anonymous@"))
 178                       "anon-ftp"
 179                     "ftp"))))
 180       (when parameters
 181         (insert parameters)))
 182     (insert "\n\n")
 183     (insert "Content-Type: " (cdr (assq 'type cont)) "\n")
 184     (insert "Content-ID: " (message-make-message-id) "\n")
 185     (insert "Content-Transfer-Encoding: "
 186             (or (cdr (assq 'encoding cont)) "binary"))
 187     (insert "\n\n")
 188     (insert (or (cdr (assq 'contents cont))))
 189     (insert "\n"))
 190    ((eq (car cont) 'multipart)
 191     (let ((mml-boundary (mml-compute-boundary cont)))
 192       (insert (format "Content-Type: multipart/%s; boundary=\"%s\"\n"
 193                       (or (cdr (assq 'type cont)) "mixed")
 194                       mml-boundary))
 195       (insert "\n")
 196       (setq cont (cddr cont))
 197       (while cont
 198         (insert "\n--" mml-boundary "\n")
 199         (mml-generate-mime-1 (pop cont)))
 200       (insert "\n--" mml-boundary "--\n")))
 201    (t
 202     (error "Invalid element: %S" cont))))
 203
 204 (defun mml-compute-boundary (cont)
 205   "Return a unique boundary that does not exist in CONT."
 206   (let ((mml-boundary (mml-make-boundary)))
 207     ;; This function tries again and again until it has found
 208     ;; a unique boundary.
 209     (while (not (catch 'not-unique
 210                   (mml-compute-boundary-1 cont))))
 211     mml-boundary))
 212
 213 (defun mml-compute-boundary-1 (cont)
 214   (let (filename)
 215     (cond
 216      ((eq (car cont) 'part)
 217       (with-temp-buffer
 218         (if (setq filename (cdr (assq 'filename cont)))
 219             (insert-file-contents-literally filename)
 220           (insert (cdr (assq 'contents cont))))
 221         (goto-char (point-min))
 222         (when (re-search-forward (concat "^--" mml-boundary) nil t)
 223           (setq mml-boundary (mml-make-boundary))
 224           (throw 'not-unique nil))))
 225      ((eq (car cont) 'multipart)
 226       (mapcar 'mml-compute-boundary-1 (cddr cont))))
 227     t))
 228
 229 (defun mml-make-boundary ()
 230   (concat (make-string (% (incf mml-multipart-number) 60) ?=)
 231           (if (> mml-multipart-number 17)
 232               (format "%x" mml-multipart-number)
 233             "")
 234           mml-base-boundary))
 235
 236 (defun mml-make-string (num string)
 237   (let ((out ""))
 238     (while (not (zerop (decf num)))
 239       (setq out (concat out string)))
 240     out))
 241
 242 (defun mml-insert-mime-headers (cont type charset encoding)
 243   (let (parameters disposition description)
 244     (when (or charset
 245               (setq parameters
 246                     (mml-parameter-string
 247                      cont '(name access-type expiration size permission)))
 248               (not (equal type "text/plain")))
 249       (insert "Content-Type: " type)
 250       (when charset
 251         (insert "; " (mail-header-encode-parameter
 252                       "charset" (symbol-name charset))))
 253       (when parameters
 254         (insert parameters))
 255       (insert "\n"))
 256     (when (or (setq disposition (cdr (assq 'disposition cont)))
 257               (setq parameters
 258                     (mml-parameter-string
 259                      cont '(filename creation-date modification-date
 260                                      read-date))))
 261       (insert "Content-Disposition: " (or disposition "inline"))
 262       (when parameters
 263         (insert parameters))
 264       (insert "\n"))
 265     (unless (eq encoding '7bit)
 266       (insert (format "Content-Transfer-Encoding: %s\n" encoding)))
 267     (when (setq description (cdr (assq 'description cont)))
 268       (insert "Content-Description: " description "\n"))))
 269
 270 (defun mml-parameter-string (cont types)
 271   (let ((string "")
 272         value type)
 273     (while (setq type (pop types))
 274       (when (setq value (cdr (assq type cont)))
 275         (setq string (concat string ";\n "
 276                              (mail-header-encode-parameter
 277                               (symbol-name type) value)))))
 278     (when (not (zerop (length string)))
 279       string)))
 280
 281 (defvar ange-ftp-path-format)
 282 (defvar efs-path-regexp)
 283 (defun mml-parse-file-name (path)
 284   (if (if (boundp 'efs-path-regexp)
 285           (string-match efs-path-regexp path)
 286         (if (boundp 'ange-ftp-path-format)
 287             (string-match (car ange-ftp-path-format))))
 288       (list (match-string 1 path) (match-string 2 path)
 289             (substring path (1+ (match-end 2))))
 290     path))
 291
 292 (provide 'mml)
 293
 294 ;;; mml.el ends here