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