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-external (entity)
 290 ;;   (require 'mmexternal)
 291 ;;   (mime-entity-set-children-internal
 292 ;;    entity
 293 ;;    (with-current-buffer (mime-entity-body-buffer entity)
 294 ;;      (save-restriction
 295 ;;        (narrow-to-region (mime-entity-body-start-point entity)
 296 ;;                          (mime-entity-body-end-point entity))
 297 ;;        (list (mime-parse-message
 298 ;;               'mime-external-entity nil
 299 ;;               entity (cons 0 (mime-entity-node-id-internal entity))))
 300 ;;        ;; [tomo] Should we unify with `mime-parse-encapsulated'?
 301 ;;        ))))
 302
 303 (defun mime-parse-message (representation-type &optional default-ctl
 304                                                parent node-id)
 305   (let ((header-start (point-min))
 306         header-end
 307         body-start
 308         (body-end (point-max))
 309         content-type)
 310     (goto-char header-start)
 311     (if (re-search-forward "^$" nil t)
 312         (setq header-end (match-end 0)
 313               body-start (if (= header-end body-end)
 314                              body-end
 315                            (1+ header-end)))
 316       (setq header-end (point-min)
 317             body-start (point-min)))
 318     (save-restriction
 319       (narrow-to-region header-start header-end)
 320       (setq content-type (or (let ((str (std11-fetch-field "Content-Type")))
 321                                (if str
 322                                    (mime-parse-Content-Type str)
 323                                  ))
 324                              default-ctl))
 325       )
 326     (luna-make-entity representation-type
 327                       :location (current-buffer)
 328                       :content-type content-type
 329                       :parent parent
 330                       :node-id node-id
 331                       :buffer (current-buffer)
 332                       :header-start header-start
 333                       :header-end header-end
 334                       :body-start body-start
 335                       :body-end body-end)
 336     ))
 337
 338
 339 ;;; @ for buffer
 340 ;;;
 341
 342 ;;;###autoload
 343 (defun mime-parse-buffer (&optional buffer representation-type)
 344   "Parse BUFFER as a MIME message.
 345 If buffer is omitted, it parses current-buffer."
 346   (save-excursion
 347     (if buffer (set-buffer buffer))
 348     (mime-parse-message (or representation-type
 349                             'mime-buffer-entity) nil)))
 350
 351
 352 ;;; @ end
 353 ;;;
 354
 355 (provide 'mime-parse)
 356
 357 ;;; mime-parse.el ends here