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