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 (defun mime-parse-Content-Type (string)
  62   "Parse STRING as field-body of Content-Type field.
  63 Return value is
  64     (PRIMARY-TYPE SUBTYPE (NAME1 . VALUE1)(NAME2 . VALUE2) ...)
  65 or nil.  PRIMARY-TYPE and SUBTYPE are symbol and NAME_n and VALUE_n
  66 are string."
  67   (setq string (std11-unfold-string string))
  68   (if (string-match `,(concat "^\\(" mime-token-regexp
  69                               "\\)/\\(" mime-token-regexp "\\)") string)
  70       (let* ((type (downcase
  71                     (substring string (match-beginning 1) (match-end 1))))
  72              (subtype (downcase
  73                        (substring string (match-beginning 2) (match-end 2))))
  74              ret dest)
  75         (setq string (substring string (match-end 0)))
  76         (while (setq ret (mime-parse-parameter string))
  77           (setq dest (cons (car ret) dest)
  78                 string (cdr ret))
  79           )
  80         (make-mime-content-type (intern type)(intern subtype)
  81                                 (nreverse dest))
  82         )))
  83
  84 (defun mime-read-Content-Type ()
  85   "Read field-body of Content-Type field from current-buffer,
  86 and return parsed it.  Format of return value is as same as
  87 `mime-parse-Content-Type'."
  88   (let ((str (std11-field-body "Content-Type")))
  89     (if str
  90         (mime-parse-Content-Type str)
  91       )))
  92
  93
  94 ;;; @ Content-Disposition
  95 ;;;
  96
  97 (defconst mime-disposition-type-regexp mime-token-regexp)
  98
  99 (defun mime-parse-Content-Disposition (string)
 100   "Parse STRING as field-body of Content-Disposition field."
 101   (setq string (std11-unfold-string string))
 102   (if (string-match `,(concat "^" mime-disposition-type-regexp) string)
 103       (let* ((e (match-end 0))
 104              (type (downcase (substring string 0 e)))
 105              ret dest)
 106         (setq string (substring string e))
 107         (while (setq ret (mime-parse-parameter string))
 108           (setq dest (cons (car ret) dest)
 109                 string (cdr ret))
 110           )
 111         (cons (cons 'type (intern type))
 112               (nreverse dest))
 113         )))
 114
 115 (defun mime-read-Content-Disposition ()
 116   "Read field-body of Content-Disposition field from current-buffer,
 117 and return parsed it."
 118   (let ((str (std11-field-body "Content-Disposition")))
 119     (if str
 120         (mime-parse-Content-Disposition str)
 121       )))
 122
 123 (defsubst mime-content-disposition-type (content-disposition)
 124   "Return disposition-type of CONTENT-DISPOSITION."
 125   (cdr (car content-disposition)))
 126
 127 (defsubst mime-content-disposition-parameters (content-disposition)
 128   "Return disposition-parameters of CONTENT-DISPOSITION."
 129   (cdr content-disposition))
 130
 131 (defsubst mime-content-disposition-parameter (content-disposition parameter)
 132   "Return PARAMETER value of CONTENT-DISPOSITION."
 133   (cdr (assoc parameter (cdr content-disposition))))
 134
 135 (defsubst mime-content-disposition-filename (content-disposition)
 136   "Return filename of CONTENT-DISPOSITION."
 137   (mime-content-disposition-parameter content-disposition "filename"))
 138
 139
 140 ;;; @ Content-Transfer-Encoding
 141 ;;;
 142
 143 (defun mime-parse-Content-Transfer-Encoding (string)
 144   "Parse STRING as field-body of Content-Transfer-Encoding field."
 145   (if (string-match "[ \t\n\r]+$" string)
 146       (setq string (match-string 0 string))
 147     )
 148   (downcase string))
 149
 150 (defun mime-read-Content-Transfer-Encoding (&optional default-encoding)
 151   "Read field-body of Content-Transfer-Encoding field from
 152 current-buffer, and return it.
 153 If is is not found, return DEFAULT-ENCODING."
 154   (let ((str (std11-field-body "Content-Transfer-Encoding")))
 155     (if str
 156         (mime-parse-Content-Transfer-Encoding str)
 157       default-encoding)))
 158
 159
 160 ;;; @ message parser
 161 ;;;
 162
 163 (defalias 'mime-entity-point-min 'mime-entity-header-start)
 164 (defalias 'mime-entity-point-max 'mime-entity-body-end)
 165
 166 (defsubst mime-entity-media-type (entity)
 167   (mime-content-type-primary-type (mime-entity-content-type entity)))
 168 (defsubst mime-entity-media-subtype (entity)
 169   (mime-content-type-subtype (mime-entity-content-type entity)))
 170 (defsubst mime-entity-parameters (entity)
 171   (mime-content-type-parameters (mime-entity-content-type entity)))
 172
 173 (defsubst mime-entity-type/subtype (entity-info)
 174   (mime-type/subtype-string (mime-entity-media-type entity-info)
 175                             (mime-entity-media-subtype entity-info)))
 176
 177 (defun mime-parse-multipart (header-start header-end body-start body-end
 178                                           content-type content-disposition
 179                                           encoding node-id)
 180   (goto-char (point-min))
 181   (let* ((dash-boundary
 182           (concat "--"
 183                   (std11-strip-quoted-string
 184                    (mime-content-type-parameter content-type "boundary"))))
 185          (delimiter       (concat "\n" (regexp-quote dash-boundary)))
 186          (close-delimiter (concat delimiter "--[ \t]*$"))
 187          (rsep (concat delimiter "[ \t]*\n"))
 188          (dc-ctl
 189           (if (eq (mime-content-type-subtype content-type) 'digest)
 190               (make-mime-content-type 'message 'rfc822)
 191             (make-mime-content-type 'text 'plain)
 192             ))
 193          cb ce ret ncb children (i 0))
 194     (save-restriction
 195       (goto-char body-end)
 196       (narrow-to-region header-end
 197                         (if (re-search-backward close-delimiter nil t)
 198                             (match-beginning 0)
 199                           body-end))
 200       (goto-char header-end)
 201       (re-search-forward rsep nil t)
 202       (setq cb (match-end 0))
 203       (while (re-search-forward rsep nil t)
 204         (setq ce (match-beginning 0))
 205         (setq ncb (match-end 0))
 206         (save-restriction
 207           (narrow-to-region cb ce)
 208           (setq ret (mime-parse-message dc-ctl "7bit" (cons i node-id)))
 209           )
 210         (setq children (cons ret children))
 211         (goto-char (setq cb ncb))
 212         (setq i (1+ i))
 213         )
 214       (setq ce (point-max))
 215       (save-restriction
 216         (narrow-to-region cb ce)
 217         (setq ret (mime-parse-message dc-ctl "7bit" (cons i node-id)))
 218         )
 219       (setq children (cons ret children))
 220       )
 221     (make-mime-entity (current-buffer)
 222                       header-start header-end body-start body-end
 223                       node-id content-type content-disposition encoding
 224                       (nreverse children))
 225     ))
 226
 227 (defun mime-parse-message (&optional default-ctl default-encoding node-id)
 228   "Parse current-buffer as a MIME message.
 229 DEFAULT-CTL is used when an entity does not have valid Content-Type
 230 field.  Its format must be as same as return value of
 231 mime-{parse|read}-Content-Type."
 232   (let ((header-start (point-min))
 233         header-end
 234         body-start
 235         (body-end (point-max))
 236         content-type content-disposition encoding
 237         primary-type)
 238     (goto-char header-start)
 239     (if (re-search-forward "^$" nil t)
 240         (setq header-end (match-end 0)
 241               body-start (1+ header-end))
 242       (setq header-end (point-min)
 243             body-start (point-min))
 244       )
 245     (save-restriction
 246       (narrow-to-region header-start header-end)
 247       (setq content-type (or (let ((str (std11-fetch-field "Content-Type")))
 248                                (if str
 249                                    (mime-parse-Content-Type str)
 250                                  ))
 251                              default-ctl)
 252             content-disposition (let ((str (std11-fetch-field
 253                                             "Content-Disposition")))
 254                                   (if str
 255                                       (mime-parse-Content-Disposition str)
 256                                     ))
 257             encoding (let ((str (std11-fetch-field
 258                                  "Content-Transfer-Encoding")))
 259                        (if str
 260                            (mime-parse-Content-Transfer-Encoding str)
 261                          default-encoding))
 262             primary-type (mime-content-type-primary-type content-type))
 263       )
 264     (cond ((eq primary-type 'multipart)
 265            (mime-parse-multipart header-start header-end
 266                                  body-start body-end
 267                                  content-type content-disposition encoding
 268                                  node-id)
 269            )
 270           ((and (eq primary-type 'message)
 271                 (memq (mime-content-type-subtype content-type)
 272                       '(rfc822 news external-body)
 273                       ))
 274            (make-mime-entity (current-buffer)
 275                              header-start header-end body-start body-end
 276                              node-id
 277                              content-type content-disposition encoding
 278                              (save-restriction
 279                                (narrow-to-region body-start body-end)
 280                                (list (mime-parse-message
 281                                       nil nil (cons 0 node-id)))
 282                                ))
 283            )
 284           (t
 285            (make-mime-entity (current-buffer)
 286                              header-start header-end body-start body-end
 287                              node-id
 288                              content-type content-disposition encoding nil)
 289            ))
 290     ))
 291
 292
 293 ;;; @ for buffer
 294 ;;;
 295
 296 (defvar mime-message-structure nil
 297   "Information about structure of message.
 298 Please use reference function `mime-entity-SLOT' to get value of SLOT.
 299
 300 Following is a list of slots of the structure:
 301
 302 buffer                  buffer includes this entity (buffer).
 303 node-id                 node-id (list of integers)
 304 header-start            minimum point of header in raw-buffer
 305 header-end              maximum point of header in raw-buffer
 306 body-start              minimum point of body in raw-buffer
 307 body-end                maximum point of body in raw-buffer
 308 content-type            content-type (content-type)
 309 content-disposition     content-disposition (content-disposition)
 310 encoding                Content-Transfer-Encoding (string or nil)
 311 children                entities included in this entity (list of entity)
 312
 313 If an entity includes other entities in its body, such as multipart or
 314 message/rfc822, `mime-entity' structures of them are included in
 315 `children', so the `mime-entity' structure become a tree.")
 316 (make-variable-buffer-local 'mime-message-structure)
 317
 318 (defun mime-parse-buffer (&optional buffer)
 319   "Parse BUFFER as a MIME message.
 320 If buffer is omitted, it parses current-buffer."
 321   (save-excursion
 322     (if buffer (set-buffer buffer))
 323     (setq mime-message-structure (mime-parse-message))
 324     ))
 325
 326
 327 ;;; @ utilities
 328 ;;;
 329
 330 (defsubst mime-root-entity-p (entity)
 331   "Return t if ENTITY is root-entity (message)."
 332   (null (mime-entity-node-id entity)))
 333
 334
 335 ;;; @ end
 336 ;;;
 337
 338 (provide 'mime-parse)
 339
 340 ;;; mime-parse.el ends here