mime-parse.el

   1 ;;; mime-parse.el --- MIME message parser
   2
   3 ;; Copyright (C) 1994,1995,1996,1997,1998,1999 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 'mime-def)
  28 (require 'std11)
  29
  30
  31 ;;; @ lexical analyzer
  32 ;;;
  33
  34 (defcustom mime-lexical-analyzer
  35   '(std11-analyze-quoted-string
  36     std11-analyze-domain-literal
  37     std11-analyze-comment
  38     std11-analyze-spaces
  39     mime-analyze-tspecial
  40     mime-analyze-token)
  41   "*List of functions to return result of lexical analyze.
  42 Each function must have two arguments: STRING and START.
  43 STRING is the target string to be analyzed.
  44 START is start position of STRING to analyze.
  45
  46 Previous function is preferred to next function.  If a function
  47 returns nil, next function is used.  Otherwise the return value will
  48 be the result."
  49   :group 'mime
  50   :type '(repeat function))
  51
  52 (defun mime-analyze-tspecial (string start)
  53   (if (and (> (length string) start)
  54            (memq (aref string start) mime-tspecial-char-list))
  55       (cons (cons 'tpecials (substring string start (1+ start)))
  56             (1+ start))
  57     ))
  58
  59 (defun mime-analyze-token (string start)
  60   (if (and (string-match mime-token-regexp string start)
  61            (= (match-beginning 0) start))
  62       (let ((end (match-end 0)))
  63         (cons (cons 'mime-token (substring string start end))
  64               ;;(substring string end)
  65               end)
  66         )))
  67
  68
  69 ;;; @ field parser
  70 ;;;
  71
  72 (defconst mime/content-parameter-value-regexp
  73   (concat "\\("
  74           std11-quoted-string-regexp
  75           "\\|[^; \t\n]*\\)"))
  76
  77 (defconst mime::parameter-regexp
  78   (concat "^[ \t]*\;[ \t]*\\(" mime-token-regexp "\\)"
  79           "[ \t]*=[ \t]*\\(" mime/content-parameter-value-regexp "\\)"))
  80
  81 (defun mime-parse-parameter (str)
  82   (if (string-match mime::parameter-regexp str)
  83       (let ((e (match-end 2)))
  84         (cons
  85          (cons (downcase (substring str (match-beginning 1) (match-end 1)))
  86                (std11-strip-quoted-string
  87                 (substring str (match-beginning 2) e))
  88                )
  89          (substring str e)
  90          ))))
  91
  92
  93 ;;; @ Content-Type
  94 ;;;
  95
  96 ;;;###autoload
  97 (defun mime-parse-Content-Type (string)
  98   "Parse STRING as field-body of Content-Type field.
  99 Return value is
 100     (PRIMARY-TYPE SUBTYPE (NAME1 . VALUE1)(NAME2 . VALUE2) ...)
 101 or nil.  PRIMARY-TYPE and SUBTYPE are symbol and NAME_n and VALUE_n
 102 are string."
 103   (setq string (std11-unfold-string string))
 104   (if (string-match `,(concat "^\\(" mime-token-regexp
 105                               "\\)/\\(" mime-token-regexp "\\)") string)
 106       (let* ((type (downcase
 107                     (substring string (match-beginning 1) (match-end 1))))
 108              (subtype (downcase
 109                        (substring string (match-beginning 2) (match-end 2))))
 110              ret dest)
 111         (setq string (substring string (match-end 0)))
 112         (while (setq ret (mime-parse-parameter string))
 113           (setq dest (cons (car ret) dest)
 114                 string (cdr ret))
 115           )
 116         (make-mime-content-type (intern type)(intern subtype)
 117                                 (nreverse dest))
 118         )))
 119
 120 ;;;###autoload
 121 (defun mime-read-Content-Type ()
 122   "Read field-body of Content-Type field from current-buffer,
 123 and return parsed it.  Format of return value is as same as
 124 `mime-parse-Content-Type'."
 125   (let ((str (std11-field-body "Content-Type")))
 126     (if str
 127         (mime-parse-Content-Type str)
 128       )))
 129
 130
 131 ;;; @ Content-Disposition
 132 ;;;
 133
 134 (eval-and-compile
 135   (defconst mime-disposition-type-regexp mime-token-regexp)
 136   )
 137
 138 ;;;###autoload
 139 (defun mime-parse-Content-Disposition (string)
 140   "Parse STRING as field-body of Content-Disposition field."
 141   (setq string (std11-unfold-string string))
 142   (if (string-match (eval-when-compile
 143                       (concat "^" mime-disposition-type-regexp)) string)
 144       (let* ((e (match-end 0))
 145              (type (downcase (substring string 0 e)))
 146              ret dest)
 147         (setq string (substring string e))
 148         (while (setq ret (mime-parse-parameter string))
 149           (setq dest (cons (car ret) dest)
 150                 string (cdr ret))
 151           )
 152         (cons (cons 'type (intern type))
 153               (nreverse dest))
 154         )))
 155
 156 ;;;###autoload
 157 (defun mime-read-Content-Disposition ()
 158   "Read field-body of Content-Disposition field from current-buffer,
 159 and return parsed it."
 160   (let ((str (std11-field-body "Content-Disposition")))
 161     (if str
 162         (mime-parse-Content-Disposition str)
 163       )))
 164
 165
 166 ;;; @ Content-Transfer-Encoding
 167 ;;;
 168
 169 ;;;###autoload
 170 (defun mime-parse-Content-Transfer-Encoding (string)
 171   "Parse STRING as field-body of Content-Transfer-Encoding field."
 172   (let ((tokens (std11-lexical-analyze string mime-lexical-analyzer))
 173         token)
 174     (while (and tokens
 175                 (setq token (car tokens))
 176                 (std11-ignored-token-p token))
 177       (setq tokens (cdr tokens)))
 178     (if token
 179         (if (eq (car token) 'mime-token)
 180             (downcase (cdr token))
 181           ))))
 182
 183 ;;;###autoload
 184 (defun mime-read-Content-Transfer-Encoding (&optional default-encoding)
 185   "Read field-body of Content-Transfer-Encoding field from
 186 current-buffer, and return it.
 187 If is is not found, return DEFAULT-ENCODING."
 188   (let ((str (std11-field-body "Content-Transfer-Encoding")))
 189     (if str
 190         (mime-parse-Content-Transfer-Encoding str)
 191       default-encoding)))
 192
 193
 194 ;;; @ Content-Id / Message-Id
 195 ;;;
 196
 197 ;;;###autoload
 198 (defun mime-parse-msg-id (tokens)
 199   "Parse TOKENS as msg-id of Content-Id or Message-Id field."
 200   (car (std11-parse-msg-id tokens)))
 201
 202 ;;;###autoload
 203 (defun mime-uri-parse-cid (string)
 204   "Parse STRING as cid URI."
 205   (inline
 206     (mime-parse-msg-id (cons '(specials . "<")
 207                              (nconc
 208                               (cdr (cdr (std11-lexical-analyze string)))
 209                               '((specials . ">")))))))
 210
 211
 212 ;;; @ message parser
 213 ;;;
 214
 215 (defun mime-parse-multipart (entity)
 216   (with-current-buffer (mime-entity-body-buffer entity)
 217     (let* ((representation-type
 218             (mime-entity-representation-type-internal entity))
 219            (content-type (mime-entity-content-type-internal entity))
 220            (dash-boundary
 221             (concat "--"
 222                     (mime-content-type-parameter content-type "boundary")))
 223            (delimiter       (concat "\n" (regexp-quote dash-boundary)))
 224            (close-delimiter (concat delimiter "--[ \t]*$"))
 225            (rsep (concat delimiter "[ \t]*\n"))
 226            (dc-ctl
 227             (if (eq (mime-content-type-subtype content-type) 'digest)
 228                 (make-mime-content-type 'message 'rfc822)
 229               (make-mime-content-type 'text 'plain)
 230               ))
 231            (body-start (mime-entity-body-start-point entity))
 232            (body-end (mime-entity-body-end-point entity)))
 233       (save-restriction
 234         (goto-char body-end)
 235         (narrow-to-region body-start
 236                           (if (re-search-backward close-delimiter nil t)
 237                               (match-beginning 0)
 238                             body-end))
 239         (goto-char body-start)
 240         (if (re-search-forward
 241              (concat "^" (regexp-quote dash-boundary) "[ \t]*\n")
 242              nil t)
 243             (let ((cb (match-end 0))
 244                   ce ncb ret children
 245                   (node-id (mime-entity-node-id-internal entity))
 246                   (i 0))
 247               (while (re-search-forward rsep nil t)
 248                 (setq ce (match-beginning 0))
 249                 (setq ncb (match-end 0))
 250                 (save-restriction
 251                   (narrow-to-region cb ce)
 252                   (setq ret (mime-parse-message representation-type dc-ctl
 253                                                 entity (cons i node-id)))
 254                   )
 255                 (setq children (cons ret children))
 256                 (goto-char (setq cb ncb))
 257                 (setq i (1+ i))
 258                 )
 259               (setq ce (point-max))
 260               (save-restriction
 261                 (narrow-to-region cb ce)
 262                 (setq ret (mime-parse-message representation-type dc-ctl
 263                                               entity (cons i node-id)))
 264                 )
 265               (setq children (cons ret children))
 266               (mime-entity-set-children-internal entity (nreverse children))
 267               )
 268           (mime-entity-set-content-type-internal
 269            entity (make-mime-content-type 'message 'x-broken))
 270           nil)
 271         ))))
 272
 273 (defun mime-parse-encapsulated (entity)
 274   (mime-entity-set-children-internal
 275    entity
 276    (with-current-buffer (mime-entity-body-buffer entity)
 277      (save-restriction
 278        (narrow-to-region (mime-entity-body-start-point entity)
 279                          (mime-entity-body-end-point entity))
 280        (list (mime-parse-message
 281               (mime-entity-representation-type-internal entity) nil
 282               entity (cons 0 (mime-entity-node-id-internal entity))))
 283        ))))
 284
 285 (defun mime-parse-message (representation-type &optional default-ctl
 286                                                parent node-id)
 287   (let ((header-start (point-min))
 288         header-end
 289         body-start
 290         (body-end (point-max))
 291         content-type)
 292     (goto-char header-start)
 293     (if (re-search-forward "^$" nil t)
 294         (setq header-end (match-end 0)
 295               body-start (if (= header-end body-end)
 296                              body-end
 297                            (1+ header-end)))
 298       (setq header-end (point-min)
 299             body-start (point-min)))
 300     (save-restriction
 301       (narrow-to-region header-start header-end)
 302       (setq content-type (or (let ((str (std11-fetch-field "Content-Type")))
 303                                (if str
 304                                    (mime-parse-Content-Type str)
 305                                  ))
 306                              default-ctl))
 307       )
 308     (luna-make-entity representation-type
 309                       :location (current-buffer)
 310                       :content-type content-type
 311                       :parent parent
 312                       :node-id node-id
 313                       :buffer (current-buffer)
 314                       :header-start header-start
 315                       :header-end header-end
 316                       :body-start body-start
 317                       :body-end body-end)
 318     ))
 319
 320
 321 ;;; @ for buffer
 322 ;;;
 323
 324 ;;;###autoload
 325 (defun mime-parse-buffer (&optional buffer representation-type)
 326   "Parse BUFFER as a MIME message.
 327 If buffer is omitted, it parses current-buffer."
 328   (save-excursion
 329     (if buffer (set-buffer buffer))
 330     (setq mime-message-structure
 331           (mime-parse-message (or representation-type
 332                                   'mime-buffer-entity) nil))
 333     ))
 334
 335
 336 ;;; @ end
 337 ;;;
 338
 339 (provide 'mime-parse)
 340
 341 ;;; mime-parse.el ends here