mmexternal.el

   1 ;;; mmexternal.el --- MIME entity module for external buffer
   2
   3 ;; Copyright (C) 1998,1999 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <tomo@m17n.org>
   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 'pces)
  29
  30 (eval-and-compile
  31   (luna-define-class mime-external-entity (mime-entity)
  32                      (body-buffer
  33                       body-file))
  34   (luna-define-internal-accessors 'mime-external-entity)
  35
  36   ;; In an external entity, information of media-type or other
  37   ;; information which are represented in a header in a non-external
  38   ;; entity are in the body of the parent entity.
  39   )
  40
  41 (luna-define-method mime-entity-name ((entity mime-external-entity))
  42   (concat "child of "
  43           (buffer-name
  44            (mime-entity-name
  45             (mime-entity-parent-internal entity)))))
  46
  47
  48 ;; [tomo] We should think about modularity about header presentation...
  49
  50 (defun mime-visible-field-p (field-name visible-fields invisible-fields)
  51   (or (catch 'found
  52         (while visible-fields
  53           (let ((regexp (car visible-fields)))
  54             (if (string-match regexp field-name)
  55                 (throw 'found t)
  56               ))
  57           (setq visible-fields (cdr visible-fields))
  58           ))
  59       (catch 'found
  60         (while invisible-fields
  61           (let ((regexp (car invisible-fields)))
  62             (if (string-match regexp field-name)
  63                 (throw 'found nil)
  64               ))
  65           (setq invisible-fields (cdr invisible-fields))
  66           )
  67         t)))
  68
  69 (defun mime-insert-header-from-buffer (buffer start end
  70                                               &optional invisible-fields
  71                                               visible-fields)
  72   (let ((the-buf (current-buffer))
  73         (mode-obj (mime-find-field-presentation-method 'wide))
  74         field-decoder
  75         f-b p f-e field-name len field field-body)
  76     (save-excursion
  77       (set-buffer buffer)
  78       (save-restriction
  79         (narrow-to-region start end)
  80         (goto-char start)
  81         (while (re-search-forward std11-field-head-regexp nil t)
  82           (setq f-b (match-beginning 0)
  83                 p (match-end 0)
  84                 field-name (buffer-substring f-b p)
  85                 len (string-width field-name)
  86                 f-e (std11-field-end))
  87           (when (mime-visible-field-p field-name
  88                                       visible-fields invisible-fields)
  89             (setq field (intern
  90                          (capitalize (buffer-substring f-b (1- p))))
  91                   field-body (buffer-substring p f-e)
  92                   field-decoder (inline (mime-find-field-decoder-internal
  93                                          field mode-obj)))
  94             (with-current-buffer the-buf
  95               (insert field-name)
  96               (insert (if field-decoder
  97                           (funcall field-decoder field-body len)
  98                         ;; Don't decode
  99                         field-body))
 100               (insert "\n")
 101               )))))))
 102
 103 (luna-define-method mime-insert-header ((entity mime-external-entity)
 104                                         &optional invisible-fields
 105                                         visible-fields)
 106   (mime-insert-header-from-buffer
 107    (mime-entity-body-buffer (mime-entity-parent-internal entity))
 108    (mime-entity-body-start-point (mime-entity-parent-internal entity))
 109    (mime-entity-body-end-point (mime-entity-parent-internal entity))
 110    invisible-fields visible-fields))
 111
 112
 113 (luna-define-method mime-entity-content ((entity mime-external-entity))
 114   (let ((buf (mime-entity-body-buffer entity)))
 115     (if buf
 116         (with-current-buffer buf
 117           (mime-decode-string
 118            (buffer-string)
 119            (mime-entity-encoding entity)))
 120       (message "Cannot get external content")
 121       nil)))
 122
 123 (luna-define-method mime-entity-fetch-field :around
 124   ((entity mime-external-entity) field-name)
 125   (or (luna-call-next-method)
 126       (save-excursion
 127         (mime-goto-body-start-point (mime-entity-parent-internal entity))
 128         (save-restriction
 129           (narrow-to-region
 130            (point)
 131            (mime-entity-body-end-point (mime-entity-parent-internal entity)))
 132           (let ((ret (std11-fetch-field field-name)))
 133             (when ret
 134               (or (symbolp field-name)
 135                   (setq field-name
 136                         (intern (capitalize (capitalize field-name)))))
 137               (mime-entity-set-original-header-internal
 138                entity
 139                (put-alist field-name ret
 140                           (mime-entity-original-header-internal entity)))
 141               ret))))))
 142
 143 (luna-define-method mime-insert-entity-content ((entity mime-external-entity))
 144   (insert
 145    (with-current-buffer (mime-external-entity-body-buffer-internal entity)
 146      (mime-decode-string
 147       (buffer-string)
 148       (mime-entity-encoding entity)))))
 149
 150 (mm-define-method write-entity-content ((entity buffer) filename)
 151   (save-excursion
 152     (set-buffer (mime-external-entity-buffer-internal entity))
 153     (mime-write-decoded-region (mime-external-entity-body-start-internal entity)
 154                                (mime-external-entity-body-end-internal entity)
 155                                filename
 156                                (or (mime-entity-encoding entity) "7bit"))
 157     ))
 158
 159 (mm-define-method insert-entity ((entity buffer))
 160   (insert-buffer-substring (mime-external-entity-buffer-internal entity)
 161                            (mime-external-entity-header-start-internal entity)
 162                            (mime-external-entity-body-end-internal entity))
 163   )
 164
 165 (mm-define-method write-entity ((entity buffer) filename)
 166   (save-excursion
 167     (set-buffer (mime-external-entity-buffer-internal entity))
 168     (write-region-as-raw-text-CRLF
 169      (mime-external-entity-header-start-internal entity)
 170      (mime-external-entity-body-end-internal entity)
 171      filename)
 172     ))
 173
 174 (mm-define-method write-entity-body ((entity buffer) filename)
 175   (save-excursion
 176     (set-buffer (mime-external-entity-buffer-internal entity))
 177     (write-region-as-binary (mime-external-entity-body-start-internal entity)
 178                             (mime-external-entity-body-end-internal entity)
 179                             filename)
 180     ))
 181
 182
 183 ;;; @ header buffer
 184 ;;;
 185
 186 (luna-define-method mime-entity-header-buffer ((entity mime-external-entity))
 187   (mime-entity-body-buffer (mime-entity-parent-internal entity)))
 188
 189 (luna-define-method mime-goto-header-start-point ((entity
 190                                                    mime-external-entity))
 191   (mime-goto-body-start-point (mime-entity-parent-internal entity)))
 192
 193 (luna-define-method mime-entity-header-start-point ((entity
 194                                                      mime-external-entity))
 195   (mime-entity-body-start-point (mime-entity-parent-internal entity)))
 196
 197 (luna-define-method mime-entity-header-end-point ((entity
 198                                                    mime-external-entity))
 199   (mime-entity-body-end-point (mime-entity-parent-internal entity)))
 200
 201
 202 ;;; @ body buffer
 203 ;;;
 204
 205 (luna-define-method mime-entity-body-buffer ((entity mime-external-entity))
 206   (or (mime-external-entity-body-buffer-internal entity)
 207       (let* ((ct
 208               (mime-entity-content-type (mime-entity-parent-internal entity))))
 209         (if (string= (mime-content-type-parameter ct "access-type")
 210                      "anon-ftp")
 211             (let* ((site (mime-content-type-parameter ct "site"))
 212                    (directory (mime-content-type-parameter ct "directory"))
 213                    (name (mime-content-type-parameter ct "name"))
 214                    (pathname
 215                     (expand-file-name
 216                      name (concat "/anonymous@" site ":" directory)))
 217                    (buf (create-file-buffer pathname)))
 218               (condition-case nil
 219                   (with-current-buffer buf
 220                     (insert-file-contents-as-binary pathname)
 221                     (mime-external-entity-set-body-buffer-internal
 222                      entity buf))
 223                 (error (message "Cannot open external buffer")))
 224               buf)))))
 225
 226 (luna-define-method mime-goto-body-start-point ((entity mime-external-entity))
 227   (set-buffer (mime-entity-body-buffer entity))
 228   (goto-char (point-min)))
 229
 230 (luna-define-method mime-goto-body-end-point ((entity mime-external-entity))
 231   (set-buffer (mime-entity-body-buffer entity))
 232   (goto-char (point-max)))
 233
 234 (luna-define-method mime-entity-body-start-point ((entity
 235                                                    mime-external-entity))
 236   (with-current-buffer (mime-entity-body-buffer entity)
 237     (point-min)))
 238
 239 (luna-define-method mime-entity-body-end-point ((entity mime-external-entity))
 240   (with-current-buffer (mime-entity-body-buffer entity)
 241     (point-max)))
 242
 243
 244 ;;; @ buffer (obsolete)
 245 ;;;
 246
 247 (luna-define-method mime-entity-buffer ((entity mime-external-entity))
 248   (mime-entity-body-buffer entity))
 249
 250 (luna-define-method mime-entity-point-min ((entity mime-external-entity))
 251   (mime-entity-body-start-point entity))
 252
 253 (luna-define-method mime-entity-point-max ((entity mime-external-entity))
 254   (mime-entity-body-end-point entity))
 255
 256
 257 ;;; @ end
 258 ;;;
 259
 260 (provide 'mmexternal)
 261
 262 ;;; mmexternal.el ends here