mmdbuffer.el

   1 ;;; mmdual.el --- MIME entity module for dual buffers
   2
   3 ;; Copyright (C) 1998,1999 Free Software Foundation, Inc.
   4 ;; Copyright (C) 1999 Electrotechnical Laboratory, JAPAN.
   5 ;; Licensed to the Free Software Foundation.
   6
   7 ;; Author: MORIOKA Tomohiko <tomo@m17n.org>
   8 ;; Keywords: MIME, multimedia, mail, news
   9
  10 ;; This file is part of FLIM (Faithful Library about Internet Message).
  11
  12 ;; This program is free software; you can redistribute it and/or
  13 ;; modify it under the terms of the GNU General Public License as
  14 ;; published by the Free Software Foundation; either version 2, or (at
  15 ;; your option) any later version.
  16
  17 ;; This program is distributed in the hope that it will be useful, but
  18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20 ;; General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;;; Code:
  28
  29 (require 'mime)
  30
  31 (eval-and-compile
  32   (luna-define-class mime-dual-entity (mime-entity)
  33                      (header-buffer
  34                       body-buffer))
  35
  36   (luna-define-internal-accessors 'mime-dual-entity)
  37   )
  38
  39 (luna-define-method initialize-instance :after ((entity mime-dual-entity)
  40                                                 &rest init-args)
  41   (let (buf)
  42     (setq buf (mime-dual-entity-header-buffer-internal entity))
  43     (if buf
  44         (with-current-buffer buf
  45           (if (mime-root-entity-p entity)
  46               (setq mime-message-structure entity))
  47           (or (mime-entity-content-type-internal entity)
  48               (mime-entity-set-content-type-internal
  49                entity
  50                (let ((str (std11-fetch-field "Content-Type")))
  51                  (if str
  52                      (mime-parse-Content-Type str)
  53                    ))))))
  54     (setq buf (mime-dual-entity-body-buffer-internal entity))
  55     (if buf
  56         (with-current-buffer buf
  57           (if (mime-root-entity-p entity)
  58               (setq mime-message-structure entity))))
  59     ) entity)
  60
  61 (luna-define-method mime-entity-name ((entity mime-dual-entity))
  62   (buffer-name (mime-dual-entity-header-buffer-internal entity))
  63   )
  64
  65
  66 (defun mime-visible-field-p (field-name visible-fields invisible-fields)
  67   (or (catch 'found
  68         (while visible-fields
  69           (let ((regexp (car visible-fields)))
  70             (if (string-match regexp field-name)
  71                 (throw 'found t)
  72               ))
  73           (setq visible-fields (cdr visible-fields))
  74           ))
  75       (catch 'found
  76         (while invisible-fields
  77           (let ((regexp (car invisible-fields)))
  78             (if (string-match regexp field-name)
  79                 (throw 'found nil)
  80               ))
  81           (setq invisible-fields (cdr invisible-fields))
  82           )
  83         t)))
  84
  85 (defun mime-insert-header-from-buffer (buffer start end
  86                                               &optional invisible-fields
  87                                               visible-fields)
  88   (let ((the-buf (current-buffer))
  89         (mode-obj (mime-find-field-presentation-method 'wide))
  90         field-decoder
  91         f-b p f-e field-name len field field-body)
  92     (save-excursion
  93       (set-buffer buffer)
  94       (save-restriction
  95         (narrow-to-region start end)
  96         (goto-char start)
  97         (while (re-search-forward std11-field-head-regexp nil t)
  98           (setq f-b (match-beginning 0)
  99                 p (match-end 0)
 100                 field-name (buffer-substring f-b p)
 101                 len (string-width field-name)
 102                 f-e (std11-field-end))
 103           (when (mime-visible-field-p field-name
 104                                       visible-fields invisible-fields)
 105             (setq field (intern
 106                          (capitalize (buffer-substring f-b (1- p))))
 107                   field-body (buffer-substring p f-e)
 108                   field-decoder (inline (mime-find-field-decoder-internal
 109                                          field mode-obj)))
 110             (with-current-buffer the-buf
 111               (insert field-name)
 112               (insert (if field-decoder
 113                           (funcall field-decoder field-body len)
 114                         ;; Don't decode
 115                         field-body))
 116               (insert "\n")
 117               )))))))
 118
 119 (luna-define-method mime-insert-header ((entity mime-dual-entity)
 120                                         &optional invisible-fields
 121                                         visible-fields)
 122   (let* ((buf (mime-dual-entity-header-buffer-internal entity))
 123          header-start header-end)
 124     (with-current-buffer buf
 125       (setq header-start (point-min)
 126             header-end (point-max)))
 127     (mime-insert-header-from-buffer buf header-start header-end
 128                                     invisible-fields visible-fields)
 129     ))
 130
 131 (luna-define-method mime-entity-content ((entity mime-dual-entity))
 132   (mime-decode-string
 133    (with-current-buffer (mime-dual-entity-body-buffer-internal entity)
 134      (buffer-string))
 135    (mime-entity-encoding entity)))
 136
 137 (luna-define-method mime-entity-fetch-field :around
 138   ((entity mime-dual-entity) field-name)
 139   (or (luna-call-next-method)
 140       (with-current-buffer (mime-dual-entity-header-buffer-internal entity)
 141         (let ((ret (std11-fetch-field field-name)))
 142           (when ret
 143             (or (symbolp field-name)
 144                 (setq field-name
 145                       (intern (capitalize (capitalize field-name)))))
 146             (mime-entity-set-original-header-internal
 147              entity
 148              (put-alist field-name ret
 149                         (mime-entity-original-header-internal entity)))
 150             ret)))))
 151
 152 (luna-define-method mime-insert-entity-content ((entity mime-dual-entity))
 153   (insert
 154    (mime-decode-string
 155     (with-current-buffer (mime-dual-entity-body-buffer-internal entity)
 156       (buffer-substring (point-min)(point-max)))
 157     (mime-entity-encoding entity))))
 158
 159 (luna-define-method mime-write-entity-content ((entity mime-dual-entity)
 160                                                filename)
 161   (with-current-buffer (mime-dual-entity-body-buffer-internal entity)
 162     (mime-write-decoded-region (point-min)
 163                                (point-max)
 164                                filename
 165                                (or (mime-entity-encoding entity) "7bit"))))
 166
 167 (luna-define-method mime-insert-entity ((entity mime-dual-entity))
 168   (let (buf)
 169     (setq buf (mime-dual-entity-header-buffer-internal entity))
 170     (when buf
 171       (insert-buffer (mime-dual-entity-header-buffer-internal entity))
 172       (setq buf (mime-dual-entity-body-buffer-internal entity))
 173       (when buf
 174         (insert "\n")
 175         (insert-buffer buf)))))
 176
 177 (luna-define-method mime-write-entity ((entity mime-dual-entity) filename)
 178   (let (buf)
 179     (setq buf (mime-dual-entity-header-buffer-internal entity))
 180     (if (null buf)
 181         (error "No header buffer.")
 182       (with-current-buffer buf
 183         (write-region-as-raw-text-CRLF
 184          (point-min)(point-max) filename))
 185       (setq buf (mime-dual-entity-body-buffer-internal entity))
 186       (when buf
 187         (with-temp-buffer
 188           (insert "\n")
 189           (write-region-as-raw-text-CRLF
 190            (point-min)(point-max)
 191            filename 'append))
 192         (with-current-buffer buf
 193           (write-region-as-raw-text-CRLF
 194            (point-min)(point-max)
 195            filename 'append))))))
 196
 197 (luna-define-method mime-write-entity-body ((entity mime-dual-entity) filename)
 198   (with-current-buffer (mime-dual-entity-body-buffer-internal entity)
 199     (write-region-as-binary (point-min)(point-max)
 200                             filename)))
 201
 202
 203 ;;; @ buffer
 204 ;;;
 205
 206 (luna-define-method mime-entity-header-buffer ((entity mime-dual-entity))
 207   (mime-dual-entity-header-buffer-internal entity))
 208
 209 (luna-define-method mime-entity-body-buffer ((entity mime-dual-entity))
 210   (mime-dual-entity-body-buffer-internal entity))
 211
 212 (luna-define-method mime-entity-buffer ((entity mime-dual-entity))
 213   (message "mime-dual-entity does not have mime-entity-buffer.")
 214   nil)
 215
 216 (luna-define-method mime-entity-body-start-point ((entity mime-dual-entity))
 217   (with-current-buffer (mime-entity-body-buffer entity)
 218     (point-min)))
 219
 220 (luna-define-method mime-entity-body-end-point ((entity mime-dual-entity))
 221   (with-current-buffer (mime-entity-body-buffer entity)
 222     (point-max)))
 223
 224 (luna-define-method mime-entity-point-min ((entity mime-dual-entity))
 225   (message "mime-dual-entity does not have mime-entity-point-min.")
 226   nil)
 227
 228 (luna-define-method mime-entity-point-max ((entity mime-dual-entity))
 229   (message "mime-dual-entity does not have mime-entity-point-max.")
 230   nil)
 231
 232 (luna-define-method mime-goto-header-start-point ((entity mime-dual-entity))
 233   (set-buffer (mime-dual-entity-header-buffer-internal entity))
 234   (goto-char (point-min)))
 235
 236 (luna-define-method mime-goto-body-start-point ((entity mime-dual-entity))
 237   (set-buffer (mime-dual-entity-body-buffer-internal entity))
 238   (goto-char (point-min)))
 239
 240 (luna-define-method mime-goto-body-end-point ((entity mime-dual-entity))
 241   (set-buffer (mime-dual-entity-body-buffer-internal entity))
 242   (goto-char (point-max)))
 243
 244
 245 ;;; @ end
 246 ;;;
 247
 248 (provide 'mmdual)
 249
 250 ;;; mmdual.el ends here