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