mmgeneric.el

   1 ;;; mmgeneric.el --- MIME entity module for generic buffer
   2
   3 ;; Copyright (C) 1998,1999 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; Keywords: MIME, multimedia, mail, news
   7
   8 ;; This file is part of FLIM (Faithful Library about Internet Message).
   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)
  28 (require 'mime-parse)
  29
  30 (mm-define-backend generic)
  31
  32 (mm-define-method entity-header-start ((entity generic))
  33   (mime-entity-set-header-start-internal
  34    entity
  35    (save-excursion
  36      (set-buffer (mime-entity-buffer entity))
  37      (point-min)
  38      )))
  39
  40 (mm-define-method entity-header-end ((entity generic))
  41   (save-excursion
  42     (set-buffer (mime-entity-buffer entity))
  43     (mime-entity-header-end-internal entity)
  44     ))
  45
  46 (mm-define-method entity-body-start ((entity generic))
  47   (mime-entity-set-body-start-internal
  48    entity
  49    (save-excursion
  50      (set-buffer (mime-entity-buffer entity))
  51      (mime-entity-body-start-internal entity)
  52      )))
  53
  54 (mm-define-method entity-body-end ((entity generic))
  55   (mime-entity-set-body-end-internal
  56    entity
  57    (save-excursion
  58      (set-buffer (mime-entity-buffer entity))
  59      (point-max)
  60      )))
  61
  62 (mm-define-method entity-point-min ((entity generic))
  63   (or (mime-entity-header-start-internal entity)
  64       (mime-entity-send entity 'entity-header-start)))
  65
  66 (mm-define-method entity-point-max ((entity generic))
  67   (or (mime-entity-body-end-internal entity)
  68       (mime-entity-send entity 'entity-body-end)))
  69
  70 (mm-define-method fetch-field ((entity generic) field-name)
  71   (save-excursion
  72     (set-buffer (mime-entity-buffer entity))
  73     (save-restriction
  74       (narrow-to-region (mime-entity-header-start-internal entity)
  75                         (mime-entity-header-end-internal entity))
  76       (std11-fetch-field field-name)
  77       )))
  78
  79 (mm-define-method entity-cooked-p ((entity generic)) nil)
  80
  81 (mm-define-method entity-children ((entity generic))
  82   (let* ((content-type (mime-entity-content-type entity))
  83          (primary-type (mime-content-type-primary-type content-type)))
  84     (cond ((eq primary-type 'multipart)
  85            (mime-parse-multipart entity)
  86            )
  87           ((and (eq primary-type 'message)
  88                 (memq (mime-content-type-subtype content-type)
  89                       '(rfc822 news external-body)
  90                       ))
  91            (mime-parse-encapsulated entity)
  92            ))
  93     ))
  94
  95 (mm-define-method entity-content ((entity generic))
  96   (save-excursion
  97     (set-buffer (mime-entity-buffer entity))
  98     (mime-decode-string
  99      (buffer-substring (mime-entity-body-start-internal entity)
 100                        (mime-entity-body-end-internal entity))
 101      (mime-entity-encoding entity))))
 102
 103 (mm-define-method insert-entity-content ((entity generic))
 104   (insert (with-current-buffer (mime-entity-buffer entity)
 105             (mime-decode-string
 106              (buffer-substring (mime-entity-body-start-internal entity)
 107                                (mime-entity-body-end-internal entity))
 108              (mime-entity-encoding entity)))))
 109
 110 (mm-define-method write-entity-content ((entity generic) filename)
 111   (save-excursion
 112     (set-buffer (mime-entity-buffer entity))
 113     (mime-write-decoded-region (mime-entity-body-start-internal entity)
 114                                (mime-entity-body-end-internal entity)
 115                                filename
 116                                (or (mime-entity-encoding entity) "7bit"))
 117     ))
 118
 119 (mm-define-method insert-entity ((entity generic))
 120   (insert-buffer-substring (mime-entity-buffer entity)
 121                            (mime-entity-header-start-internal entity)
 122                            (mime-entity-body-end-internal entity))
 123   )
 124
 125 (mm-define-method write-entity ((entity generic) filename)
 126   (save-excursion
 127     (set-buffer (mime-entity-buffer entity))
 128     (write-region-as-raw-text-CRLF (mime-entity-header-start-internal entity)
 129                                    (mime-entity-body-end-internal entity)
 130                                    filename)
 131     ))
 132
 133 (mm-define-method write-entity-body ((entity generic) filename)
 134   (save-excursion
 135     (set-buffer (mime-entity-buffer entity))
 136     (write-region-as-binary (mime-entity-body-start-internal entity)
 137                             (mime-entity-body-end-internal entity)
 138                             filename)
 139     ))
 140
 141 (defun mime-visible-field-p (field-name visible-fields invisible-fields)
 142   (or (catch 'found
 143         (while visible-fields
 144           (let ((regexp (car visible-fields)))
 145             (if (string-match regexp field-name)
 146                 (throw 'found t)
 147               ))
 148           (setq visible-fields (cdr visible-fields))
 149           ))
 150       (catch 'found
 151         (while invisible-fields
 152           (let ((regexp (car invisible-fields)))
 153             (if (string-match regexp field-name)
 154                 (throw 'found nil)
 155               ))
 156           (setq invisible-fields (cdr invisible-fields))
 157           )
 158         t)))
 159
 160 (defun mime-insert-header-from-buffer (buffer start end
 161                                               &optional invisible-fields
 162                                               visible-fields)
 163   (let ((the-buf (current-buffer))
 164         (mode-obj (mime-find-field-presentation-method 'wide))
 165         field-decoder
 166         f-b p f-e field-name len field field-body)
 167     (save-excursion
 168       (set-buffer buffer)
 169       (save-restriction
 170         (narrow-to-region start end)
 171         (goto-char start)
 172         (while (re-search-forward std11-field-head-regexp nil t)
 173           (setq f-b (match-beginning 0)
 174                 p (match-end 0)
 175                 field-name (buffer-substring f-b p)
 176                 len (string-width field-name)
 177                 f-e (std11-field-end))
 178           (when (mime-visible-field-p field-name
 179                                       visible-fields invisible-fields)
 180             (setq field (intern
 181                          (capitalize (buffer-substring f-b (1- p))))
 182                   field-body (buffer-substring p f-e)
 183                   field-decoder (inline (mime-find-field-decoder-internal
 184                                          field mode-obj)))
 185             (with-current-buffer the-buf
 186               (insert field-name)
 187               (insert (if field-decoder
 188                           (funcall field-decoder field-body len)
 189                         ;; Don't decode
 190                         field-body))
 191               (insert "\n")
 192               )))))))
 193
 194 (mm-define-method insert-header ((entity generic)
 195                                  &optional invisible-fields visible-fields)
 196   (mime-insert-header-from-buffer
 197    (mime-entity-buffer entity)
 198    (mime-entity-header-start-internal entity)
 199    (mime-entity-header-end-internal entity)
 200    invisible-fields visible-fields)
 201   )
 202
 203 (mm-define-method insert-text-content ((entity generic))
 204   (insert
 205    (decode-mime-charset-string (mime-entity-content entity)
 206                                (or (mime-content-type-parameter
 207                                     (mime-entity-content-type entity)
 208                                     "charset")
 209                                    default-mime-charset)
 210                                'CRLF)
 211    ))
 212
 213
 214 ;;; @ end
 215 ;;;
 216
 217 (provide 'mmgeneric)
 218
 219 ;;; mmgeneric.el ends here