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