mime-parse.el

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