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