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 `,(concat "^\\(" mime-token-regexp
 109                               "\\)/\\(" mime-token-regexp "\\)") string)
 110       (let* ((type (downcase
 111                     (substring string (match-beginning 1) (match-end 1))))
 112              (subtype (downcase
 113                        (substring string (match-beginning 2) (match-end 2))))
 114              ret dest)
 115         (setq string (substring string (match-end 0)))
 116         (while (setq ret (mime-parse-parameter string))
 117           (setq dest (cons (car ret) dest)
 118                 string (cdr ret))
 119           )
 120         (make-mime-content-type (intern type)(intern subtype)
 121                                 (nreverse dest))
 122         )))
 123
 124 ;;;###autoload
 125 (defun mime-read-Content-Type ()
 126   "Read field-body of Content-Type field from current-buffer,
 127 and return parsed it.  Format of return value is as same as
 128 `mime-parse-Content-Type'."
 129   (let ((str (std11-field-body "Content-Type")))
 130     (if str
 131         (mime-parse-Content-Type str)
 132       )))
 133
 134
 135 ;;; @ Content-Disposition
 136 ;;;
 137
 138 (eval-and-compile
 139   (defconst mime-disposition-type-regexp mime-token-regexp)
 140   )
 141
 142 ;;;###autoload
 143 (defun mime-parse-Content-Disposition (string)
 144   "Parse STRING as field-body of Content-Disposition field."
 145   (setq string (std11-unfold-string string))
 146   (if (string-match (eval-when-compile
 147                       (concat "^" mime-disposition-type-regexp)) string)
 148       (let* ((e (match-end 0))
 149              (type (downcase (substring string 0 e)))
 150              ret dest)
 151         (setq string (substring string e))
 152         (while (setq ret (mime-parse-parameter string))
 153           (setq dest (cons (car ret) dest)
 154                 string (cdr ret))
 155           )
 156         (cons (cons 'type (intern type))
 157               (nreverse dest))
 158         )))
 159
 160 ;;;###autoload
 161 (defun mime-read-Content-Disposition ()
 162   "Read field-body of Content-Disposition field from current-buffer,
 163 and return parsed it."
 164   (let ((str (std11-field-body "Content-Disposition")))
 165     (if str
 166         (mime-parse-Content-Disposition str)
 167       )))
 168
 169
 170 ;;; @ Content-Transfer-Encoding
 171 ;;;
 172
 173 ;;;###autoload
 174 (defun mime-parse-Content-Transfer-Encoding (string)
 175   "Parse STRING as field-body of Content-Transfer-Encoding field."
 176   (let ((tokens (std11-lexical-analyze string mime-lexical-analyzer))
 177         token)
 178     (while (and tokens
 179                 (setq token (car tokens))
 180                 (std11-ignored-token-p token))
 181       (setq tokens (cdr tokens)))
 182     (if token
 183         (if (eq (car token) 'mime-token)
 184             (downcase (cdr token))
 185           ))))
 186
 187 ;;;###autoload
 188 (defun mime-read-Content-Transfer-Encoding (&optional default-encoding)
 189   "Read field-body of Content-Transfer-Encoding field from
 190 current-buffer, and return it.
 191 If is is not found, return DEFAULT-ENCODING."
 192   (let ((str (std11-field-body "Content-Transfer-Encoding")))
 193     (if str
 194         (mime-parse-Content-Transfer-Encoding str)
 195       default-encoding)))
 196
 197
 198 ;;; @ Content-Id / Message-Id
 199 ;;;
 200
 201 ;;;###autoload
 202 (defun mime-parse-msg-id (tokens)
 203   "Parse TOKENS as msg-id of Content-Id or Message-Id field."
 204   (car (std11-parse-msg-id tokens)))
 205
 206 ;;;###autoload
 207 (defun mime-uri-parse-cid (string)
 208   "Parse STRING as cid URI."
 209   (inline
 210     (mime-parse-msg-id (cons '(specials . "<")
 211                              (nconc
 212                               (cdr (cdr (std11-lexical-analyze string)))
 213                               '((specials . ">")))))))
 214
 215
 216 ;;; @ message parser
 217 ;;;
 218
 219 (defun mime-parse-multipart (entity)
 220   (with-current-buffer (mime-entity-body-buffer entity)
 221     (let* ((representation-type
 222             (mime-entity-representation-type-internal entity))
 223            (content-type (mime-entity-content-type-internal entity))
 224            (dash-boundary
 225             (concat "--"
 226                     (mime-content-type-parameter content-type "boundary")))
 227            (delimiter       (concat "\n" (regexp-quote dash-boundary)))
 228            (close-delimiter (concat delimiter "--[ \t]*$"))
 229            (rsep (concat delimiter "[ \t]*\n"))
 230            (dc-ctl
 231             (if (eq (mime-content-type-subtype content-type) 'digest)
 232                 (make-mime-content-type 'message 'rfc822)
 233               (make-mime-content-type 'text 'plain)
 234               ))
 235            (body-start (mime-entity-body-start-point entity))
 236            (body-end (mime-entity-body-end-point entity)))
 237       (save-restriction
 238         (goto-char body-end)
 239         (narrow-to-region body-start
 240                           (if (re-search-backward close-delimiter nil t)
 241                               (match-beginning 0)
 242                             body-end))
 243         (goto-char body-start)
 244         (if (re-search-forward
 245              (concat "^" (regexp-quote dash-boundary) "[ \t]*\n")
 246              nil t)
 247             (let ((cb (match-end 0))
 248                   ce ncb ret children
 249                   (node-id (mime-entity-node-id-internal entity))
 250                   (i 0))
 251               (while (re-search-forward rsep nil t)
 252                 (setq ce (match-beginning 0))
 253                 (setq ncb (match-end 0))
 254                 (save-restriction
 255                   (narrow-to-region cb ce)
 256                   (setq ret (mime-parse-message representation-type dc-ctl
 257                                                 entity (cons i node-id)))
 258                   )
 259                 (setq children (cons ret children))
 260                 (goto-char (setq cb ncb))
 261                 (setq i (1+ i))
 262                 )
 263               (setq ce (point-max))
 264               (save-restriction
 265                 (narrow-to-region cb ce)
 266                 (setq ret (mime-parse-message representation-type dc-ctl
 267                                               entity (cons i node-id)))
 268                 )
 269               (setq children (cons ret children))
 270               (mime-entity-set-children-internal entity (nreverse children))
 271               )
 272           (mime-entity-set-content-type-internal
 273            entity (make-mime-content-type 'message 'x-broken))
 274           nil)
 275         ))))
 276
 277 (defun mime-parse-encapsulated (entity)
 278   (mime-entity-set-children-internal
 279    entity
 280    (with-current-buffer (mime-entity-body-buffer entity)
 281      (save-restriction
 282        (narrow-to-region (mime-entity-body-start-point entity)
 283                          (mime-entity-body-end-point entity))
 284        (list (mime-parse-message
 285               (mime-entity-representation-type-internal entity) nil
 286               entity (cons 0 (mime-entity-node-id-internal entity))))
 287        ))))
 288
 289 (defun mime-parse-message (representation-type &optional default-ctl
 290                                                parent node-id)
 291   (let ((header-start (point-min))
 292         header-end
 293         body-start
 294         (body-end (point-max))
 295         content-type)
 296     (goto-char header-start)
 297     (if (re-search-forward "^$" nil t)
 298         (setq header-end (match-end 0)
 299               body-start (if (= header-end body-end)
 300                              body-end
 301                            (1+ header-end)))
 302       (setq header-end (point-min)
 303             body-start (point-min)))
 304     (save-restriction
 305       (narrow-to-region header-start header-end)
 306       (setq content-type (or (let ((str (std11-fetch-field "Content-Type")))
 307                                (if str
 308                                    (mime-parse-Content-Type str)
 309                                  ))
 310                              default-ctl))
 311       )
 312     (luna-make-entity representation-type
 313                       :location (current-buffer)
 314                       :content-type content-type
 315                       :parent parent
 316                       :node-id node-id
 317                       :buffer (current-buffer)
 318                       :header-start header-start
 319                       :header-end header-end
 320                       :body-start body-start
 321                       :body-end body-end)
 322     ))
 323
 324
 325 ;;; @ for buffer
 326 ;;;
 327
 328 ;;;###autoload
 329 (defun mime-parse-buffer (&optional buffer representation-type)
 330   "Parse BUFFER as a MIME message.
 331 If buffer is omitted, it parses current-buffer."
 332   (save-excursion
 333     (if buffer (set-buffer buffer))
 334     (setq mime-message-structure
 335           (mime-parse-message (or representation-type
 336                                   'mime-buffer-entity) nil))
 337     ))
 338
 339
 340 ;;; @ end
 341 ;;;
 342
 343 (provide 'mime-parse)
 344
 345 ;;; mime-parse.el ends here