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