mime/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 'luna)
  29 (require 'std11)
  30
  31 (autoload 'mime-entity-body-buffer "mime")
  32 (autoload 'mime-entity-body-start-point "mime")
  33 (autoload 'mime-entity-body-end-point "mime")
  34
  35
  36 ;;; @ lexical analyzer
  37 ;;;
  38
  39 (defcustom mime-lexical-analyzer
  40   '(std11-analyze-quoted-string
  41     std11-analyze-domain-literal
  42     std11-analyze-comment
  43     std11-analyze-spaces
  44     mime-analyze-tspecial
  45     mime-analyze-token)
  46   "*List of functions to return result of lexical analyze.
  47 Each function must have two arguments: STRING and START.
  48 STRING is the target string to be analyzed.
  49 START is start position of STRING to analyze.
  50
  51 Previous function is preferred to next function.  If a function
  52 returns nil, next function is used.  Otherwise the return value will
  53 be the result."
  54   :group 'mime
  55   :type '(repeat function))
  56
  57 (defun mime-analyze-tspecial (string start)
  58   (if (and (> (length string) start)
  59            (memq (aref string start) mime-tspecial-char-list))
  60       (cons (cons 'tpecials (substring string start (1+ start)))
  61             (1+ start))
  62     ))
  63
  64 (defun mime-analyze-token (string start)
  65   (if (and (string-match mime-token-regexp string start)
  66            (= (match-beginning 0) start))
  67       (let ((end (match-end 0)))
  68         (cons (cons 'mime-token (substring string start end))
  69               ;;(substring string end)
  70               end)
  71         )))
  72
  73
  74 ;;; @ field parser
  75 ;;;
  76
  77 (defconst mime/content-parameter-value-regexp
  78   (concat "\\("
  79           std11-quoted-string-regexp
  80           "\\|[^; \t\n]*\\)"))
  81
  82 (defconst mime::parameter-regexp
  83   (concat "^[ \t]*\;[ \t]*\\(" mime-token-regexp "\\)"
  84           "[ \t]*=[ \t]*\\(" mime/content-parameter-value-regexp "\\)"))
  85
  86 (defun mime-parse-parameter (str)
  87   (if (string-match mime::parameter-regexp str)
  88       (let ((e (match-end 2)))
  89         (cons
  90          (cons (downcase (substring str (match-beginning 1) (match-end 1)))
  91                (std11-strip-quoted-string
  92                 (substring str (match-beginning 2) e))
  93                )
  94          (substring str e)
  95          ))))
  96
  97
  98 ;;; @ Content-Type
  99 ;;;
 100
 101 ;;;###autoload
 102 (defun mime-parse-Content-Type (string)
 103   "Parse STRING as field-body of Content-Type field.
 104 Return value is
 105     (PRIMARY-TYPE SUBTYPE (NAME1 . VALUE1)(NAME2 . VALUE2) ...)
 106 or nil.  PRIMARY-TYPE and SUBTYPE are symbol and NAME_n and VALUE_n
 107 are string."
 108   (setq string (std11-unfold-string string))
 109   (if (string-match `,(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-external (entity)
 291 ;;   (require 'mmexternal)
 292 ;;   (mime-entity-set-children-internal
 293 ;;    entity
 294 ;;    (with-current-buffer (mime-entity-body-buffer entity)
 295 ;;      (save-restriction
 296 ;;        (narrow-to-region (mime-entity-body-start-point entity)
 297 ;;                          (mime-entity-body-end-point entity))
 298 ;;        (list (mime-parse-message
 299 ;;               'mime-external-entity nil
 300 ;;               entity (cons 0 (mime-entity-node-id-internal entity))))
 301 ;;        ;; [tomo] Should we unify with `mime-parse-encapsulated'?
 302 ;;        ))))
 303
 304 (defun mime-parse-message (representation-type &optional default-ctl
 305                                                parent node-id)
 306   (let ((header-start (point-min))
 307         header-end
 308         body-start
 309         (body-end (point-max))
 310         content-type)
 311     (goto-char header-start)
 312     (if (re-search-forward "^$" nil t)
 313         (setq header-end (match-end 0)
 314               body-start (if (= header-end body-end)
 315                              body-end
 316                            (1+ header-end)))
 317       (setq header-end (point-min)
 318             body-start (point-min)))
 319     (save-restriction
 320       (narrow-to-region header-start header-end)
 321       (setq content-type (or (let ((str (std11-fetch-field "Content-Type")))
 322                                (if str
 323                                    (mime-parse-Content-Type str)
 324                                  ))
 325                              default-ctl))
 326       )
 327     (luna-make-entity representation-type
 328                       :location (current-buffer)
 329                       :content-type content-type
 330                       :parent parent
 331                       :node-id node-id
 332                       :buffer (current-buffer)
 333                       :header-start header-start
 334                       :header-end header-end
 335                       :body-start body-start
 336                       :body-end body-end)
 337     ))
 338
 339
 340 ;;; @ for buffer
 341 ;;;
 342
 343 ;;;###autoload
 344 (defun mime-parse-buffer (&optional buffer representation-type)
 345   "Parse BUFFER as a MIME message.
 346 If buffer is omitted, it parses current-buffer."
 347   (save-excursion
 348     (if buffer (set-buffer buffer))
 349     (mime-parse-message (or representation-type
 350                             'mime-buffer-entity) nil)))
 351
 352
 353 ;;; @ end
 354 ;;;
 355
 356 (provide 'mime-parse)
 357
 358 ;;; mime-parse.el ends here