mime-parse.el

   1 ;;; mime-parse.el --- MIME message parser
   2
   3 ;; Copyright (C) 1994,1995,1996,1997 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; Version: $Id: mime-parse.el,v 0.24 1997-09-05 12:10:48 morioka Exp $
   7 ;; Keywords: parse, MIME, multimedia, mail, news
   8
   9 ;; This file is part of SEMI (SEMI is Emacs MIME Interfaces).
  10
  11 ;; This program is free software; you can redistribute it and/or
  12 ;; modify it under the terms of the GNU General Public License as
  13 ;; published by the Free Software Foundation; either version 2, or (at
  14 ;; your option) any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Code:
  27
  28 (require 'emu)
  29 (require 'std11)
  30 (require 'mime-def)
  31
  32 (defsubst symbol-concat (&rest args)
  33   "Return a symbol whose name is concatenation of arguments ARGS
  34 which are string or symbol."
  35   (intern (mapconcat (function
  36                       (lambda (s)
  37                         (cond ((symbolp s) (symbol-name s))
  38                               ((stringp s) s)
  39                               )))
  40                      args "")))
  41
  42
  43 ;;; @ field parser
  44 ;;;
  45
  46 (defsubst regexp-* (regexp)
  47   (concat regexp "*"))
  48
  49 (defconst rfc822/quoted-pair-regexp "\\\\.")
  50 (defconst rfc822/qtext-regexp
  51   (concat "[^" (char-list-to-string std11-non-qtext-char-list) "]"))
  52 (defconst rfc822/quoted-string-regexp
  53   (concat "\""
  54           (regexp-*
  55            (regexp-or rfc822/qtext-regexp rfc822/quoted-pair-regexp)
  56            )
  57           "\""))
  58
  59 (defconst mime/content-parameter-value-regexp
  60   (concat "\\("
  61           rfc822/quoted-string-regexp
  62           "\\|[^; \t\n]*\\)"))
  63
  64 (defconst mime::parameter-regexp
  65   (concat "^[ \t]*\;[ \t]*\\(" mime-token-regexp "\\)"
  66           "[ \t]*=[ \t]*\\(" mime/content-parameter-value-regexp "\\)"))
  67
  68 (defun mime-parse-parameter (str)
  69   (if (string-match mime::parameter-regexp str)
  70       (let ((e (match-end 2)))
  71         (cons
  72          (cons (downcase (substring str (match-beginning 1) (match-end 1)))
  73                (std11-strip-quoted-string
  74                 (substring str (match-beginning 2) e))
  75                )
  76          (substring str e)
  77          ))))
  78
  79 (defun mime-parse-Content-Type (string)
  80   "Parse STRING as field-body of Content-Type field.
  81 Return value is
  82     (PRIMARY-TYPE SUBTYPE (NAME1 . VALUE1)(NAME2 . VALUE2) ...)
  83 or nil.  PRIMARY-TYPE and SUBTYPE are symbol and NAME_n and VALUE_n
  84 are string."
  85   (setq string (std11-unfold-string string))
  86   (if (string-match `,(concat "^\\(" mime-token-regexp
  87                               "\\)/\\(" mime-token-regexp "\\)") string)
  88       (let* ((type (downcase
  89                     (substring string (match-beginning 1) (match-end 1))))
  90              (subtype (downcase
  91                        (substring string (match-beginning 2) (match-end 2))))
  92              ret dest)
  93         (setq string (substring string (match-end 0)))
  94         (while (setq ret (mime-parse-parameter string))
  95           (setq dest (cons (car ret) dest)
  96                 string (cdr ret))
  97           )
  98         (cons (intern type) (cons (intern subtype) (nreverse dest)))
  99         )))
 100
 101
 102 (defconst mime-disposition-type-regexp mime-token-regexp)
 103
 104 (defun mime-parse-Content-Disposition (string)
 105   "Parse STRING as field-body of Content-Disposition field."
 106   (setq string (std11-unfold-string string))
 107   (if (string-match `,(concat "^" mime-disposition-type-regexp) string)
 108       (let* ((e (match-end 0))
 109              (ctype (downcase (substring string 0 e)))
 110              ret dest)
 111         (setq string (substring string e))
 112         (while (setq ret (mime-parse-parameter string))
 113           (setq dest (cons (car ret) dest)
 114                 string (cdr ret))
 115           )
 116         (cons ctype (nreverse dest))
 117         )))
 118
 119
 120 ;;; @ field reader
 121 ;;;
 122
 123 (defun mime-read-Content-Type ()
 124   "Read field-body of Content-Type field from current-buffer,
 125 and return parsed it.  Format of return value is as same as
 126 `mime-parse-Content-Type'."
 127   (let ((str (std11-field-body "Content-Type")))
 128     (if str
 129         (mime-parse-Content-Type str)
 130       )))
 131
 132 (defun mime/Content-Transfer-Encoding (&optional default-encoding)
 133   "Read field-body of Content-Transfer-Encoding field from
 134 current-buffer, and return it.
 135 If is is not found, return DEFAULT-ENCODING. [mime-parse.el]"
 136   (let ((str (std11-field-body "Content-Transfer-Encoding")))
 137     (if str
 138         (progn
 139           (if (string-match "[ \t\n\r]+$" str)
 140               (setq str (substring str 0 (match-beginning 0)))
 141             )
 142           (downcase str)
 143           )
 144       default-encoding)
 145     ))
 146
 147 (defun mime/Content-Disposition ()
 148   "Read field-body of Content-Disposition field from current-buffer,
 149 and return parsed it. [mime-parse.el]"
 150   (let ((str (std11-field-body "Content-Disposition")))
 151     (if str
 152         (mime-parse-Content-Disposition str)
 153       )))
 154
 155
 156 ;;; @ message parser
 157 ;;;
 158
 159 (defsubst make-mime-entity-info (rcnum
 160                                  point-min point-max
 161                                  media-type media-subtype parameters
 162                                  encoding children)
 163   (vector rcnum point-min point-max
 164           media-type media-subtype parameters encoding children))
 165
 166 (defsubst mime-entity-info-rnum (entity-info)           (aref entity-info 0))
 167 (defsubst mime-entity-info-point-min (entity-info)      (aref entity-info 1))
 168 (defsubst mime-entity-info-point-max (entity-info)      (aref entity-info 2))
 169 (defsubst mime-entity-info-media-type (entity-info)     (aref entity-info 3))
 170 (defsubst mime-entity-info-media-subtype (entity-info)  (aref entity-info 4))
 171 (defsubst mime-entity-info-parameters (entity-info)     (aref entity-info 5))
 172 (defsubst mime-entity-info-encoding (entity-info)       (aref entity-info 6))
 173 (defsubst mime-entity-info-children (entity-info)       (aref entity-info 7))
 174
 175 (defsubst mime-entity-info-type/subtype (entity-info)
 176   (let ((type (mime-entity-info-media-type entity-info)))
 177     (if type
 178         (let ((subtype (mime-entity-info-media-subtype entity-info)))
 179           (if subtype
 180               (format "%s/%s" type subtype)
 181             (symbol-name type))))))
 182
 183 (defun mime-parse-multipart (boundary primtype subtype params encoding rcnum)
 184   (goto-char (point-min))
 185   (let* ((dash-boundary   (concat "--" boundary))
 186          (delimiter       (concat "\n" (regexp-quote dash-boundary)))
 187          (close-delimiter (concat delimiter "--[ \t]*$"))
 188          (beg (point-min))
 189          (end (progn
 190                 (goto-char (point-max))
 191                 (if (re-search-backward close-delimiter nil t)
 192                     (match-beginning 0)
 193                   (point-max)
 194                   )))
 195          (rsep (concat delimiter "[ \t]*\n"))
 196          (dc-ctl
 197           (if (eq subtype 'digest)
 198               '(message rfc822)
 199             '(text plain)
 200             ))
 201          cb ce ret ncb children (i 0))
 202     (save-restriction
 203       (narrow-to-region beg end)
 204       (goto-char beg)
 205       (re-search-forward rsep nil t)
 206       (setq cb (match-end 0))
 207       (while (re-search-forward rsep nil t)
 208         (setq ce (match-beginning 0))
 209         (setq ncb (match-end 0))
 210         (save-restriction
 211           (narrow-to-region cb ce)
 212           (setq ret (mime-parse-message dc-ctl "7bit" (cons i rcnum)))
 213           )
 214         (setq children (cons ret children))
 215         (goto-char (mime-entity-info-point-max ret))
 216         (goto-char (setq cb ncb))
 217         (setq i (1+ i))
 218         )
 219       (setq ce (point-max))
 220       (save-restriction
 221         (narrow-to-region cb ce)
 222         (setq ret (mime-parse-message dc-ctl "7bit" (cons i rcnum)))
 223         )
 224       (setq children (cons ret children))
 225       )
 226     (make-mime-entity-info rcnum beg (point-max)
 227                            primtype subtype params encoding
 228                            (nreverse children))
 229     ))
 230
 231 (defun mime-parse-message (&optional default-ctl default-encoding rcnum)
 232   "Parse current-buffer as a MIME message.
 233 DEFAULT-CTL is used when an entity does not have valid Content-Type
 234 field.  Its format must be as same as return value of
 235 mime-{parse|read}-Content-Type."
 236   (setq default-ctl (or (mime-read-Content-Type) default-ctl))
 237   (let ((primtype (car default-ctl))
 238         (subtype (car (cdr default-ctl)))
 239         (params (cdr (cdr default-ctl)))
 240         (encoding (or (mime/Content-Transfer-Encoding) default-encoding))
 241         )
 242     (let ((boundary (assoc "boundary" params)))
 243       (cond (boundary
 244              (setq boundary (std11-strip-quoted-string (cdr boundary)))
 245              (mime-parse-multipart
 246               boundary
 247               primtype subtype params encoding rcnum)
 248              )
 249             ((and (eq primtype 'message)
 250                   (memq subtype '(rfc822 news))
 251                   )
 252              (goto-char (point-min))
 253              (make-mime-entity-info rcnum
 254                                     (point-min) (point-max)
 255                                     primtype subtype params encoding
 256                                     (save-restriction
 257                                       (narrow-to-region
 258                                        (if (re-search-forward "^$" nil t)
 259                                            (1+ (match-end 0))
 260                                          (point-min)
 261                                          )
 262                                        (point-max))
 263                                       (list (mime-parse-message
 264                                              nil nil (cons 0 rcnum)))
 265                                       ))
 266              )
 267             (t
 268              (make-mime-entity-info rcnum (point-min) (point-max)
 269                                     primtype subtype params encoding
 270                                     nil)
 271              ))
 272       )))
 273
 274
 275 ;;; @ end
 276 ;;;
 277
 278 (provide 'mime-parse)
 279
 280 ;;; mime-parse.el ends here