tm-parse.el

   1 ;;;
   2 ;;; tm-parse.el --- MIME message parser
   3 ;;;
   4 ;;; Copyright (C) 1995 Free Software Foundation, Inc.
   5 ;;; Copyright (C) 1994 .. 1996 MORIOKA Tomohiko
   6 ;;;
   7 ;;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   8 ;;; Version:
   9 ;;;     $Id: tm-parse.el,v 7.9 1996/06/06 07:24:30 morioka Exp $
  10 ;;; Keywords: mail, news, MIME, multimedia
  11 ;;;
  12 ;;; This file is part of tm (Tools for MIME).
  13 ;;;
  14 ;;; This program is free software; you can redistribute it and/or
  15 ;;; modify it under the terms of the GNU General Public License as
  16 ;;; published by the Free Software Foundation; either version 2, or
  17 ;;; (at your option) any later version.
  18 ;;;
  19 ;;; This program is distributed in the hope that it will be useful,
  20 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  22 ;;; General Public License for more details.
  23 ;;;
  24 ;;; You should have received a copy of the GNU General Public License
  25 ;;; along with This program.  If not, write to the Free Software
  26 ;;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  27 ;;;
  28 ;;; Code:
  29
  30 (require 'tl-822)
  31 (require 'tl-misc)
  32 (require 'tm-def)
  33
  34
  35 ;;; @ field parser
  36 ;;;
  37
  38 (defconst mime::parameter-regexp
  39   (concat "^[ \t]*\;[ \t]*\\(" mime/token-regexp "\\)"
  40           "[ \t]*=[ \t]*\\(" mime/content-parameter-value-regexp "\\)"))
  41
  42 (defun mime/parse-parameter (str)
  43   (if (string-match mime::parameter-regexp str)
  44       (let ((e (match-end 2)))
  45         (cons
  46          (cons (downcase (substring str (match-beginning 1) (match-end 1)))
  47                (rfc822/strip-quoted-string
  48                 (substring str (match-beginning 2) e))
  49                )
  50          (substring str e)
  51          ))))
  52
  53 (defconst mime::ctype-regexp (concat "^" mime/content-type-subtype-regexp))
  54
  55 (defun mime/parse-Content-Type (str)
  56   "Parse STR as field-body of Content-Type field. [tm-parse.el]"
  57   (setq str (rfc822/unfolding-string str))
  58   (if (string-match mime::ctype-regexp str)
  59       (let* ((e (match-end 0))
  60              (ctype (downcase (substring str 0 e)))
  61              ret dest)
  62         (setq str (substring str e))
  63         (while (setq ret (mime/parse-parameter str))
  64           (setq dest (cons (car ret) dest)
  65                 str (cdr ret))
  66           )
  67         (cons ctype (nreverse dest))
  68         )))
  69
  70 (defconst mime::dtype-regexp (concat "^" mime/disposition-type-regexp))
  71
  72 (defun mime/parse-Content-Disposition (str)
  73   "Parse STR as field-body of Content-Disposition field. [tm-parse.el]"
  74   (setq str (rfc822/unfolding-string str))
  75   (if (string-match mime::dtype-regexp str)
  76       (let* ((e (match-end 0))
  77              (ctype (downcase (substring str 0 e)))
  78              ret dest)
  79         (setq str (substring str e))
  80         (while (setq ret (mime/parse-parameter str))
  81           (setq dest (cons (car ret) dest)
  82                 str (cdr ret))
  83           )
  84         (cons ctype (nreverse dest))
  85         )))
  86
  87
  88 ;;; @ field reader
  89 ;;;
  90
  91 (defun mime/Content-Type ()
  92   "Read field-body of Content-Type field from current-buffer,
  93 and return parsed it. [tm-parse.el]"
  94   (let ((str (rfc822/get-field-body "Content-Type")))
  95     (if str
  96         (mime/parse-Content-Type str)
  97       )))
  98
  99 (defun mime/Content-Transfer-Encoding (&optional default-encoding)
 100   "Read field-body of Content-Transfer-Encoding field from
 101 current-buffer, and return it.
 102 If is is not found, return DEFAULT-ENCODING. [tm-parse.el]"
 103   (let ((str (rfc822/get-field-body "Content-Transfer-Encoding")))
 104     (if str
 105         (progn
 106           (if (string-match "[ \t\n\r]+$" str)
 107               (setq str (substring str 0 (match-beginning 0)))
 108             )
 109           (downcase str)
 110           )
 111       default-encoding)
 112     ))
 113
 114 (defun mime/Content-Disposition ()
 115   "Read field-body of Content-Disposition field from current-buffer,
 116 and return parsed it. [tm-parse.el]"
 117   (let ((str (rfc822/get-field-body "Content-Disposition")))
 118     (if str
 119         (mime/parse-Content-Disposition str)
 120       )))
 121
 122
 123 ;;; @ message parser
 124 ;;;
 125
 126 (define-structure mime::content-info
 127   rcnum point-min point-max type parameters encoding children)
 128
 129
 130 (defun mime/parse-multipart (boundary ctype params encoding rcnum)
 131   (goto-char (point-min))
 132   (let* ((dash-boundary   (concat "--" boundary))
 133          (delimiter       (concat "\n" (regexp-quote dash-boundary)))
 134          (close-delimiter (concat delimiter "--[ \t]*$"))
 135          (beg (point-min))
 136          (end (progn
 137                 (goto-char (point-max))
 138                 (if (re-search-backward close-delimiter nil t)
 139                     (match-beginning 0)
 140                   (point-max)
 141                   )))
 142          (rsep (concat delimiter "[ \t]*\n"))
 143          (dc-ctl
 144           (if (string-equal ctype "multipart/digest")
 145               '("message/rfc822")
 146             '("text/plain")
 147             ))
 148          cb ce ct ret ncb children (i 0))
 149     (save-restriction
 150       (narrow-to-region beg end)
 151       (goto-char beg)
 152       (re-search-forward rsep nil t)
 153       (setq cb (match-end 0))
 154       (while (re-search-forward rsep nil t)
 155         (setq ce (match-beginning 0))
 156         (setq ncb (match-end 0))
 157         (save-restriction
 158           (narrow-to-region cb ce)
 159           (setq ret (mime/parse-message dc-ctl "7bit" (cons i rcnum)))
 160           )
 161         (setq children (cons ret children))
 162         (goto-char (mime::content-info/point-max ret))
 163         (goto-char (setq cb ncb))
 164         (setq i (1+ i))
 165         )
 166       (setq ce (point-max))
 167       (save-restriction
 168         (narrow-to-region cb ce)
 169         (setq ret (mime/parse-message dc-ctl "7bit" (cons i rcnum)))
 170         )
 171       (setq children (cons ret children))
 172       )
 173     (mime::content-info/create rcnum beg (point-max)
 174                                ctype params encoding
 175                                (nreverse children))
 176     ))
 177
 178 (defun mime/parse-message (&optional ctl encoding rcnum)
 179   "Parse current-buffer as a MIME message. [tm-parse.el]"
 180   (setq ctl (or (mime/Content-Type) ctl))
 181   (setq encoding (or (mime/Content-Transfer-Encoding) encoding))
 182   (let ((ctype (car ctl))
 183         (params (cdr ctl))
 184         )
 185     (let ((boundary (assoc "boundary" params)))
 186       (cond (boundary
 187              (setq boundary (rfc822/strip-quoted-string (cdr boundary)))
 188              (mime/parse-multipart boundary ctype params encoding rcnum)
 189              )
 190             ((string-equal ctype "message/rfc822")
 191              (goto-char (point-min))
 192              (mime::content-info/create rcnum
 193                                         (point-min) (point-max)
 194                                         ctype params encoding
 195                                         (save-restriction
 196                                           (narrow-to-region
 197                                            (if (re-search-forward "^$" nil t)
 198                                                (1+ (match-end 0))
 199                                              (point-min)
 200                                              )
 201                                            (point-max))
 202                                           (list (mime/parse-message
 203                                                  nil nil (cons 0 rcnum)))
 204                                           )
 205                                         )
 206              )
 207             (t
 208              (mime::content-info/create rcnum (point-min) (point-max)
 209                                         ctype params encoding nil)
 210              ))
 211       )))
 212
 213
 214 ;;; @ end
 215 ;;;
 216
 217 (provide 'tm-parse)
 218
 219 ;;; tm-parse.el ends here