1 ;;; mm-extern.el --- showing message/external-body
2 ;; Copyright (C) 2000, 2001, 2003 Free Software Foundation, Inc.
4 ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
5 ;; Keywords: message external-body
7 ;; This file is part of GNU Emacs.
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.
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.
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.
28 (eval-when-compile (require 'cl
))
34 (defvar mm-extern-function-alist
35 '((local-file . mm-extern-local-file
)
37 (anon-ftp . mm-extern-anon-ftp
)
39 ;;; (tftp . mm-extern-tftp)
40 (mail-server . mm-extern-mail-server
)
41 ;;; (afs . mm-extern-afs))
44 (defvar mm-extern-anonymous
"anonymous")
46 (defun mm-extern-local-file (handle)
48 (let ((name (cdr (assq 'name
(cdr (mm-handle-type handle
)))))
49 (coding-system-for-read mm-binary-coding-system
))
51 (error "The filename is not specified"))
52 (mm-disable-multibyte)
53 (if (file-exists-p name
)
54 (mm-insert-file-contents name nil nil nil nil t
)
55 (error (format "File %s is gone" name
)))))
57 (defun mm-extern-url (handle)
59 (let ((url (cdr (assq 'url
(cdr (mm-handle-type handle
)))))
60 (name buffer-file-name
)
61 (coding-system-for-read mm-binary-coding-system
))
63 (error "URL is not specified"))
64 (mm-with-unibyte-current-buffer
65 (mm-url-insert-file-contents url
))
66 (mm-disable-multibyte)
67 (setq buffer-file-name name
)))
69 (defun mm-extern-anon-ftp (handle)
71 (let* ((params (cdr (mm-handle-type handle
)))
72 (name (cdr (assq 'name params
)))
73 (site (cdr (assq 'site params
)))
74 (directory (cdr (assq 'directory params
)))
75 (mode (cdr (assq 'mode params
)))
76 (path (concat "/" (or mm-extern-anonymous
77 (read-string (format "ID for %s: " site
)))
78 "@" site
":" directory
"/" name
))
79 (coding-system-for-read mm-binary-coding-system
))
81 (error "The filename is not specified"))
82 (mm-disable-multibyte)
83 (mm-insert-file-contents path nil nil nil nil t
)))
85 (defun mm-extern-ftp (handle)
86 (let (mm-extern-anonymous)
87 (mm-extern-anon-ftp handle
)))
89 (defun mm-extern-mail-server (handle)
91 (let* ((params (cdr (mm-handle-type handle
)))
92 (server (cdr (assq 'server params
)))
93 (subject (or (cdr (assq 'subject params
)) "none"))
94 (buf (current-buffer))
96 (if (y-or-n-p (format "Send a request message to %s?" server
))
97 (save-window-excursion
98 (message-mail server subject
)
100 (delete-region (point) (point-max))
101 (insert-buffer-substring buf
)
102 (message "Requesting external body...")
103 (message-send-and-exit)
104 (setq info
"Request is sent.")
106 (setq info
"Request is not sent."))
107 (goto-char (point-min))
108 (insert "[" info
"]\n\n")))
111 (defun mm-inline-external-body (handle &optional no-display
)
112 "Show the external-body part of HANDLE.
113 This function replaces the buffer of HANDLE with a buffer contains
115 If NO-DISPLAY is nil, display it. Otherwise, do nothing after replacing."
116 (let* ((access-type (cdr (assq 'access-type
117 (cdr (mm-handle-type handle
)))))
118 (func (cdr (assq (intern
121 (error "Couldn't find access type"))))
122 mm-extern-function-alist
)))
123 gnus-displaying-mime buf
125 (unless (mm-handle-cache handle
)
127 (error (format "Access type (%s) is not supported" access-type
)))
129 (mm-insert-part handle
)
130 (goto-char (point-max))
132 (setq handles
(mm-dissect-buffer t
)))
133 (unless (bufferp (car handles
))
134 (mm-destroy-parts handles
)
135 (error "Multipart external body is not supported"))
136 (save-excursion ;; single part
137 (set-buffer (setq buf
(mm-handle-buffer handles
)))
141 (funcall func handle
)
144 (mm-destroy-parts handles
))))
145 (mm-handle-set-cache handle handles
))
146 (setq gnus-article-mime-handles
147 (mm-merge-handles gnus-article-mime-handles handles
)))
151 (narrow-to-region (point) (point))
152 (gnus-display-mime (mm-handle-cache handle
))
153 (mm-handle-set-undisplayer
156 (let (buffer-read-only)
158 ;; This is only valid on XEmacs.
159 (mapcar (lambda (prop)
161 (face-property 'default prop
) (current-buffer)))
162 '(background background-pixmap foreground
))
164 (delete-region ,(point-min-marker) ,(point-max-marker))))))))))
168 ;;; arch-tag: 9653808e-14d9-4172-86e6-adceaa05378e
169 ;;; mm-extern.el ends here