tm-parse.el

   1 ;;;
   2 ;;; tm-parse.el --- MIME message parser
   3 ;;;
   4 ;;; Copyright (C) 1995 Free Software Foundation, Inc.
   5 ;;; Copyright (C) 1994,1995 MORIOKA Tomohiko
   6 ;;;
   7 ;;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   8 ;;; Version:
   9 ;;;     $Id: tm-parse.el,v 6.0 1995/11/15 11:56:10 morioka Exp $
  10 ;;; Keywords: mail, news, MIME, multimedia
  11 ;;;
  12 ;;; This file is part of tm (Tools for MIME).
  13 ;;;
  14
  15 (require 'tl-822)
  16 (require 'tl-misc)
  17 (require 'tm-def)
  18
  19
  20 ;;; @ field parser
  21 ;;;
  22
  23 (defconst mime::parameter-regexp
  24   (concat "^[ \t]*\;[ \t]*\\(" mime/token-regexp "\\)"
  25           "[ \t]*=[ \t]*\\(" mime/content-parameter-value-regexp "\\)"))
  26
  27 (defun mime/parse-parameter (str)
  28   (if (string-match mime::parameter-regexp str)
  29       (let ((e (match-end 2)))
  30         (cons
  31          (cons (downcase (substring str (match-beginning 1) (match-end 1)))
  32                (rfc822/strip-quoted-string
  33                 (substring str (match-beginning 2) e))
  34                )
  35          (substring str e)
  36          ))))
  37
  38 (defconst mime::ctype-regexp
  39   (concat "^" mime/content-type-subtype-regexp))
  40
  41 (defun mime/parse-Content-Type (str)
  42   "Parse STR as field-body of Content-Type field. [tm-parse.el]"
  43   (setq str (rfc822/unfolding-string str))
  44   (if (string-match mime::ctype-regexp str)
  45       (let* ((e (match-end 0))
  46              (ctype (downcase (substring str 0 e)))
  47              ret dest)
  48         (setq str (substring str e))
  49         (while (setq ret (mime/parse-parameter str))
  50           (setq dest (cons (car ret) dest))
  51           (setq str (cdr ret))
  52           )
  53         (cons ctype (reverse dest))
  54         )))
  55
  56
  57 ;;; @ field reader
  58 ;;;
  59
  60 (defun mime/Content-Type ()
  61   "Read field-body of Content-Type field from current-buffer,
  62 and return parsed it. [tm-parse.el]"
  63   (let ((str (rfc822/get-field-body "Content-Type")))
  64     (if str
  65         (mime/parse-Content-Type str)
  66       )))
  67
  68 (defun mime/Content-Transfer-Encoding (&optional default-encoding)
  69   "Read field-body of Content-Transfer-Encoding field from
  70 current-buffer, and return it.
  71 If is is not found, return DEFAULT-ENCODING. [tm-parse.el]"
  72   (let ((str (rfc822/get-field-body "Content-Transfer-Encoding")))
  73     (if str
  74         (downcase str)
  75       default-encoding)
  76     ))
  77
  78
  79 ;;; @ message parser
  80 ;;;
  81
  82 (define-structure mime::content-info
  83   rcnum point-min point-max type parameters encoding children)
  84
  85
  86 (defun mime/parse-multipart (boundary ctype params encoding rcnum)
  87   (goto-char (point-min))
  88   (let* ((dash-boundary   (concat "--" boundary))
  89          (delimiter       (concat "\n" dash-boundary))
  90          (close-delimiter (concat delimiter "--"))
  91          (beg (point-min))
  92          (end (if (search-forward close-delimiter nil t)
  93                   (match-beginning 0)
  94                 (point-max)
  95                 ))
  96          (rsep (concat (regexp-quote delimiter) "[ \t]*\n"))
  97          (dc-ctl
  98           (cond ((string= ctype "multipart/digest") '("message/rfc822"))
  99                 (t '("text/plain"))
 100                 ))
 101          cb ce ct ret ncb children (i 0))
 102     (save-restriction
 103       (narrow-to-region beg end)
 104       (goto-char beg)
 105       (re-search-forward rsep nil t)
 106       (setq cb (match-end 0))
 107       (while (re-search-forward rsep nil t)
 108         (setq ce (match-beginning 0))
 109         (setq ncb (match-end 0))
 110         (save-restriction
 111           (narrow-to-region cb ce)
 112           (setq ret (mime/parse-message dc-ctl "7bit" (cons i rcnum)))
 113           )
 114         (setq children (cons ret children))
 115         (goto-char (mime::content-info/point-max ret))
 116         (goto-char (setq cb ncb))
 117         (setq i (1+ i))
 118         )
 119       (setq ce (point-max))
 120       (save-restriction
 121         (narrow-to-region cb ce)
 122         (setq ret (mime/parse-message dc-ctl "7bit" (cons i rcnum)))
 123         )
 124       (setq children (cons ret children))
 125       )
 126     (mime::content-info/create rcnum beg end ctype params encoding
 127                                (reverse children))
 128     ))
 129
 130 (defun mime/parse-message (&optional ctl encoding rcnum)
 131   "Parse current-buffer as a MIME message. [tm-parse.el]"
 132   (setq ctl (or (mime/Content-Type) ctl))
 133   (setq encoding (or (mime/Content-Transfer-Encoding) encoding))
 134   (let ((ctype (car ctl))
 135         (params (cdr ctl))
 136         )
 137     (let ((boundary (assoc "boundary" params)))
 138       (cond (boundary
 139              (setq boundary (rfc822/strip-quoted-string (cdr boundary)))
 140              (mime/parse-multipart boundary ctype params encoding rcnum)
 141              )
 142             ((string= ctype "message/rfc822")
 143              (goto-char (point-min))
 144              (mime::content-info/create rcnum
 145                                         (point-min) (point-max)
 146                                         ctype params encoding
 147                                         (save-restriction
 148                                           (narrow-to-region
 149                                            (if (re-search-forward "^$" nil t)
 150                                                (+ (match-end 0) 1)
 151                                              (point-min)
 152                                              )
 153                                            (point-max))
 154                                           (list (mime/parse-message
 155                                                  nil nil (cons 0 rcnum)))
 156                                           )
 157                                         )
 158              )
 159             (t
 160              (mime::content-info/create rcnum (point-min) (point-max)
 161                                         ctype params encoding nil)
 162              ))
 163       )))
 164
 165
 166 ;;; @ end
 167 ;;;
 168
 169 (provide 'tm-parse)