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 (defun mime-parse-parameters-skip-to-next-token (lrl)
  77   (while (and lrl
  78               (memq (caar lrl) '(comment spaces)))
  79     (setq lrl (cdr lrl))
  80     )
  81   (if (eq (caar lrl) 'error)
  82       nil
  83     lrl))
  84
  85 (defun mime-parse-parameters (str)
  86   (let* ((lrl (std11-lexical-analyze str mime-lexical-analyzer))
  87          (token (car lrl))
  88          rest name val)
  89     (while (and token
  90                 (eq (car token) 'tpecials)
  91                 (string= (cdr token) ";")
  92                 )
  93       (if (and (setq lrl (mime-parse-parameters-skip-to-next-token
  94                           (cdr lrl)
  95                           ))
  96                (setq name (cdar lrl))
  97                (setq lrl (mime-parse-parameters-skip-to-next-token
  98                           (cdr lrl)
  99                           ))
 100                (string= (cdar lrl) "=")
 101                (setq lrl (mime-parse-parameters-skip-to-next-token
 102                           (cdr lrl)
 103                           ))
 104                (setq val (cdar lrl)))
 105           (setq lrl (mime-parse-parameters-skip-to-next-token (cdr lrl))
 106                 token (car lrl)
 107                 rest (cons val rest)
 108                 rest (cons name rest)
 109                 )
 110         (setq token nil)))
 111     (mime-parse-parameters-from-list rest)))
 112
 113 (defun mime-parse-parameters-from-list (list)
 114   (let (rest name val)
 115     (while list
 116       (let ((name (car list))
 117             (val (cadr list)))
 118         (setq list (cddr list))
 119         (when (string-match "^\\([^*]+\\)\\(\\*\\([0-9]+\\)\\)?\\(\\*\\)?"
 120                             name)
 121           (let ((number (if (match-beginning 3)
 122                             (string-to-int (substring name
 123                                                       (match-beginning 3)
 124                                                       (match-end 3)))
 125                           0))
 126                 (encoded (if (match-beginning 4) t nil))
 127                 (parm (progn
 128                         (setq name (downcase (substring name
 129                                                         (match-beginning 1)
 130                                                         (match-end 1))))
 131                         (or (assoc name rest)
 132                             (car (setq rest
 133                                        (cons (make-mime-parameter name)
 134                                              rest)))))))
 135             (when (and (eq number 0)
 136                        encoded
 137                        (string-match "^\\([^']*\\)'\\([^']*\\)'\\(.*\\)" val))
 138               (when (< (match-beginning 1) (match-end 1))
 139                 (mime-parameter-set-charset
 140                  parm
 141                  (intern (downcase (substring val
 142                                               (match-beginning 1)
 143                                               (match-end 1)
 144                                               )))))
 145               (when (< (match-beginning 2) (match-end 2))
 146                 (mime-parameter-set-language
 147                  parm
 148                  (intern (downcase (substring val
 149                                               (match-beginning 2)
 150                                               (match-end 2)
 151                                               )))))
 152               (setq val (substring val (match-beginning 3)))
 153               )
 154             (mime-parameter-append-raw-value parm number encoded val)))))
 155       rest))
 156
 157 ;;; @ Content-Type
 158 ;;;
 159
 160 ;;;###autoload
 161 (defun mime-parse-Content-Type (string)
 162   "Parse STRING as field-body of Content-Type field."
 163   (setq string (std11-unfold-string string))
 164   (if (string-match `,(concat "^\\(" mime-token-regexp
 165                               "\\)/\\(" mime-token-regexp "\\)") string)
 166       (let* ((type (downcase
 167                     (substring string (match-beginning 1) (match-end 1))))
 168              (subtype (downcase
 169                        (substring string (match-beginning 2) (match-end 2))))
 170              ret dest)
 171         (setq string (substring string (match-end 0)))
 172         (make-mime-content-type (intern type)(intern subtype)
 173                                 (nreverse (mime-parse-parameters string))
 174                                 ))))
 175
 176 ;;;###autoload
 177 (defun mime-read-Content-Type ()
 178   "Read field-body of Content-Type field from current-buffer,
 179 and return parsed it."
 180   (let ((str (std11-field-body "Content-Type")))
 181     (if str
 182         (mime-parse-Content-Type str)
 183       )))
 184
 185
 186 ;;; @ Content-Disposition
 187 ;;;
 188
 189 (eval-and-compile
 190   (defconst mime-disposition-type-regexp mime-token-regexp)
 191   )
 192
 193 ;;;###autoload
 194 (defun mime-parse-Content-Disposition (string)
 195   "Parse STRING as field-body of Content-Disposition field."
 196   (setq string (std11-unfold-string string))
 197   (if (string-match (eval-when-compile
 198                       (concat "^" mime-disposition-type-regexp)) string)
 199       (let* ((e (match-end 0))
 200              (type (downcase (substring string 0 e)))
 201              ret dest)
 202         (setq string (substring string e))
 203         (cons (cons 'type (intern type))
 204               (nreverse (mime-parse-parameters string)))
 205         )))
 206
 207 ;;;###autoload
 208 (defun mime-read-Content-Disposition ()
 209   "Read field-body of Content-Disposition field from current-buffer,
 210 and return parsed it."
 211   (let ((str (std11-field-body "Content-Disposition")))
 212     (if str
 213         (mime-parse-Content-Disposition str)
 214       )))
 215
 216
 217 ;;; @ Content-Transfer-Encoding
 218 ;;;
 219
 220 ;;;###autoload
 221 (defun mime-parse-Content-Transfer-Encoding (string)
 222   "Parse STRING as field-body of Content-Transfer-Encoding field."
 223   (let ((tokens (std11-lexical-analyze string mime-lexical-analyzer))
 224         token)
 225     (while (and tokens
 226                 (setq token (car tokens))
 227                 (std11-ignored-token-p token))
 228       (setq tokens (cdr tokens)))
 229     (if token
 230         (if (eq (car token) 'mime-token)
 231             (downcase (cdr token))
 232           ))))
 233
 234 ;;;###autoload
 235 (defun mime-read-Content-Transfer-Encoding (&optional default-encoding)
 236   "Read field-body of Content-Transfer-Encoding field from
 237 current-buffer, and return it.
 238 If is is not found, return DEFAULT-ENCODING."
 239   (let ((str (std11-field-body "Content-Transfer-Encoding")))
 240     (if str
 241         (mime-parse-Content-Transfer-Encoding str)
 242       default-encoding)))
 243
 244
 245 ;;; @ Content-Id / Message-Id
 246 ;;;
 247
 248 ;;;###autoload
 249 (defun mime-parse-msg-id (tokens)
 250   "Parse TOKENS as msg-id of Content-Id or Message-Id field."
 251   (car (std11-parse-msg-id tokens)))
 252
 253 ;;;###autoload
 254 (defun mime-uri-parse-cid (string)
 255   "Parse STRING as cid URI."
 256   (inline
 257     (mime-parse-msg-id (cons '(specials . "<")
 258                              (nconc
 259                               (cdr (cdr (std11-lexical-analyze string)))
 260                               '((specials . ">")))))))
 261
 262
 263 ;;; @ message parser
 264 ;;;
 265
 266 (defun mime-parse-multipart (entity)
 267   (with-current-buffer (mime-entity-body-buffer entity)
 268     (let* ((representation-type
 269             (mime-entity-representation-type-internal entity))
 270            (content-type (mime-entity-content-type-internal entity))
 271            (dash-boundary
 272             (concat "--"
 273                     (mime-content-type-parameter content-type "boundary")))
 274            (delimiter       (concat "\n" (regexp-quote dash-boundary)))
 275            (close-delimiter (concat delimiter "--[ \t]*$"))
 276            (rsep (concat delimiter "[ \t]*\n"))
 277            (dc-ctl
 278             (if (eq (mime-content-type-subtype content-type) 'digest)
 279                 (make-mime-content-type 'message 'rfc822)
 280               (make-mime-content-type 'text 'plain)
 281               ))
 282            (body-start (mime-entity-body-start-point entity))
 283            (body-end (mime-entity-body-end-point entity)))
 284       (save-restriction
 285         (goto-char body-end)
 286         (narrow-to-region body-start
 287                           (if (re-search-backward close-delimiter nil t)
 288                               (match-beginning 0)
 289                             body-end))
 290         (goto-char body-start)
 291         (if (re-search-forward
 292              (concat "^" (regexp-quote dash-boundary) "[ \t]*\n")
 293              nil t)
 294             (let ((cb (match-end 0))
 295                   ce ncb ret children
 296                   (node-id (mime-entity-node-id-internal entity))
 297                   (i 0))
 298               (while (re-search-forward rsep nil t)
 299                 (setq ce (match-beginning 0))
 300                 (setq ncb (match-end 0))
 301                 (save-restriction
 302                   (narrow-to-region cb ce)
 303                   (setq ret (mime-parse-message representation-type dc-ctl
 304                                                 entity (cons i node-id)))
 305                   )
 306                 (setq children (cons ret children))
 307                 (goto-char (setq cb ncb))
 308                 (setq i (1+ i))
 309                 )
 310               (setq ce (point-max))
 311               (save-restriction
 312                 (narrow-to-region cb ce)
 313                 (setq ret (mime-parse-message representation-type dc-ctl
 314                                               entity (cons i node-id)))
 315                 )
 316               (setq children (cons ret children))
 317               (mime-entity-set-children-internal entity (nreverse children))
 318               )
 319           (mime-entity-set-content-type-internal
 320            entity (make-mime-content-type 'message 'x-broken))
 321           nil)
 322         ))))
 323
 324 (defun mime-parse-encapsulated (entity)
 325   (mime-entity-set-children-internal
 326    entity
 327    (with-current-buffer (mime-entity-body-buffer entity)
 328      (save-restriction
 329        (narrow-to-region (mime-entity-body-start-point entity)
 330                          (mime-entity-body-end-point entity))
 331        (list (mime-parse-message
 332               (mime-entity-representation-type-internal entity) nil
 333               entity (cons 0 (mime-entity-node-id-internal entity))))
 334        ))))
 335
 336 (defun mime-parse-message (representation-type &optional default-ctl
 337                                                parent node-id)
 338   (let ((header-start (point-min))
 339         header-end
 340         body-start
 341         (body-end (point-max))
 342         content-type)
 343     (goto-char header-start)
 344     (if (re-search-forward "^$" nil t)
 345         (setq header-end (match-end 0)
 346               body-start (if (= header-end body-end)
 347                              body-end
 348                            (1+ header-end)))
 349       (setq header-end (point-min)
 350             body-start (point-min)))
 351     (save-restriction
 352       (narrow-to-region header-start header-end)
 353       (setq content-type (or (let ((str (std11-fetch-field "Content-Type")))
 354                                (if str
 355                                    (mime-parse-Content-Type str)
 356                                  ))
 357                              default-ctl))
 358       )
 359     (luna-make-entity representation-type
 360                       :location (current-buffer)
 361                       :content-type content-type
 362                       :parent parent
 363                       :node-id node-id
 364                       :buffer (current-buffer)
 365                       :header-start header-start
 366                       :header-end header-end
 367                       :body-start body-start
 368                       :body-end body-end)
 369     ))
 370
 371
 372 ;;; @ for buffer
 373 ;;;
 374
 375 ;;;###autoload
 376 (defun mime-parse-buffer (&optional buffer representation-type)
 377   "Parse BUFFER as a MIME message.
 378 If buffer is omitted, it parses current-buffer."
 379   (save-excursion
 380     (if buffer (set-buffer buffer))
 381     (setq mime-message-structure
 382           (mime-parse-message (or representation-type
 383                                   'mime-buffer-entity) nil))
 384     ))
 385
 386
 387 ;;; @ end
 388 ;;;
 389
 390 (provide 'mime-parse)
 391
 392 ;;; mime-parse.el ends here