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