cgit.sxemacs.org Git - gnus/blob - lisp/mm-extern.el

   1 ;;; mm-extern.el --- showing message/external-body
   2 ;; Copyright (C) 2000 Free Software Foundation, Inc.
   3
   4 ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
   5 ;; Keywords: message external-body
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published
  11 ;; by the Free Software Foundation; either version 2, or (at your
  12 ;; option) any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful, but
  15 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17 ;; General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (eval-when-compile
  29   (require 'cl))
  30
  31 (require 'mm-util)
  32 (require 'mm-decode)
  33
  34 (defvar mm-extern-function-alist
  35   '((local-file . mm-extern-local-file)
  36     (url . mm-extern-url)
  37     (anon-ftp . mm-extern-anon-ftp)
  38     (ftp . mm-extern-ftp)
  39 ;;;     (tftp . mm-extern-tftp)
  40 ;;;     (mail-server . mm-extern-mail-server))
  41 ;;;     (afs . mm-extern-afs))
  42     ))
  43
  44 (defvar mm-extern-anonymous "anonymous")
  45
  46 (defun mm-extern-local-file (handle)
  47   (let ((name (cdr (assq 'name (cdr (mm-handle-type handle)))))
  48         (coding-system-for-read mm-binary-coding-system))
  49     (unless name
  50       (error "The filename is not specified."))
  51     (mm-disable-multibyte-mule4)
  52     (mm-insert-file-contents name nil nil nil nil t)))
  53
  54 (defun mm-extern-url (handle)
  55   (require 'url)
  56   (let ((url (cdr (assq 'url (cdr (mm-handle-type handle)))))
  57         (name buffer-file-name)
  58         (coding-system-for-read mm-binary-coding-system))
  59     (unless url
  60       (error "URL is not specified."))
  61     (mm-with-unibyte-current-buffer-mule4
  62       (url-insert-file-contents url))
  63     (mm-disable-multibyte-mule4)
  64     (setq buffer-file-name name)))
  65
  66 (defun mm-extern-anon-ftp (handle)
  67   (let* ((params (cdr (mm-handle-type handle)))
  68          (name (cdr (assq 'name params)))
  69          (site (cdr (assq 'site params)))
  70          (directory (cdr (assq 'directory params)))
  71          (mode (cdr (assq 'mode params)))
  72          (path (concat "/" (or mm-extern-anonymous
  73                                (read-string (format "ID for %s: " site)))
  74                        "@" site ":" directory "/" name))
  75          (coding-system-for-read mm-binary-coding-system))
  76     (unless name
  77       (error "The filename is not specified."))
  78     (mm-disable-multibyte-mule4)
  79     (mm-insert-file-contents path nil nil nil nil t)))
  80
  81 (defun mm-extern-ftp (handle)
  82   (let (mm-extern-anonymous)
  83     (mm-extern-anon-ftp handle)))
  84
  85 ;;;###autoload
  86 (defun mm-inline-external-body (handle &optional no-display)
  87   "Show the external-body part of HANDLE.
  88 This function replaces the buffer of HANDLE with a buffer contains
  89 the entire message.
  90 If NO-DISPLAY is nil, display it. Otherwise, do nothing after replacing."
  91   (let* ((access-type (cdr (assq 'access-type
  92                                  (cdr (mm-handle-type handle)))))
  93          (func (cdr (assq (intern (downcase access-type))
  94                           mm-extern-function-alist)))
  95          gnus-displaying-mime buf
  96          handles)
  97     (unless (mm-handle-cache handle)
  98       (unless func
  99         (error (format "Access type (%s) is not supported." access-type)))
 100       (with-temp-buffer
 101         (mm-insert-part handle)
 102         (goto-char (point-max))
 103         (insert "\n\n")
 104         (setq handles (mm-dissect-buffer t)))
 105       (unless (bufferp (car handles))
 106         (mm-destroy-parts handles)
 107         (error "Multipart external body is not supported."))
 108       (save-excursion ;; single part
 109         (kill-buffer (mm-handle-buffer handles))
 110         (set-buffer (setq buf (generate-new-buffer " *mm*")))
 111         (condition-case err
 112             (funcall func handle)
 113           (error
 114            ;; Don't require gnus-util
 115            (when (gnus-buffer-exists-p buf)
 116              (kill-buffer buf))
 117            (error err)))
 118         (setcar handles (current-buffer))
 119         (mm-handle-set-cache handle handles))
 120       (push handles gnus-article-mime-handles))
 121     (unless no-display
 122       (save-excursion
 123         (save-restriction
 124           (narrow-to-region (point) (point))
 125           (gnus-display-mime (mm-handle-cache handle))
 126           (mm-handle-set-undisplayer
 127            handle
 128            `(lambda ()
 129               (let (buffer-read-only)
 130                 (condition-case nil
 131                     ;; This is only valid on XEmacs.
 132                     (mapcar (lambda (prop)
 133                             (remove-specifier
 134                              (face-property 'default prop) (current-buffer)))
 135                             '(background background-pixmap foreground))
 136                   (error nil))
 137                 (delete-region ,(point-min-marker) ,(point-max-marker))))))))))
 138
 139 ;; mm-extern.el ends here