1;;; mm-extern.el --- showing message/external-body 2 3;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 4;; 2005, 2006, 2007 Free Software Foundation, Inc. 5 6;; Author: Shenghuo Zhu <zsh@cs.rochester.edu> 7;; Keywords: message external-body 8 9;; This file is part of GNU Emacs. 10 11;; GNU Emacs is free software; you can redistribute it and/or modify 12;; it under the terms of the GNU General Public License as published 13;; by the Free Software Foundation; either version 2, or (at your 14;; option) any later version. 15 16;; GNU Emacs is distributed in the hope that it will be useful, but 17;; WITHOUT ANY WARRANTY; without even the implied warranty of 18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 19;; General Public License for more details. 20 21;; You should have received a copy of the GNU General Public License 22;; along with GNU Emacs; see the file COPYING. If not, write to the 23;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 24;; Boston, MA 02110-1301, USA. 25 26;;; Commentary: 27 28;;; Code: 29 30(eval-when-compile (require 'cl)) 31 32(require 'mm-util) 33(require 'mm-decode) 34(require 'mm-url) 35 36(defvar gnus-article-mime-handles) 37 38(defvar mm-extern-function-alist 39 '((local-file . mm-extern-local-file) 40 (url . mm-extern-url) 41 (anon-ftp . mm-extern-anon-ftp) 42 (ftp . mm-extern-ftp) 43;;; (tftp . mm-extern-tftp) 44 (mail-server . mm-extern-mail-server) 45;;; (afs . mm-extern-afs)) 46 )) 47 48(defvar mm-extern-anonymous "anonymous") 49 50(defun mm-extern-local-file (handle) 51 (erase-buffer) 52 (let ((name (cdr (assq 'name (cdr (mm-handle-type handle))))) 53 (coding-system-for-read mm-binary-coding-system)) 54 (unless name 55 (error "The filename is not specified")) 56 (mm-disable-multibyte) 57 (if (file-exists-p name) 58 (mm-insert-file-contents name nil nil nil nil t) 59 (error "File %s is gone" name)))) 60 61(defun mm-extern-url (handle) 62 (erase-buffer) 63 (let ((url (cdr (assq 'url (cdr (mm-handle-type handle))))) 64 (name buffer-file-name) 65 (coding-system-for-read mm-binary-coding-system)) 66 (unless url 67 (error "URL is not specified")) 68 (mm-with-unibyte-current-buffer 69 (mm-url-insert-file-contents url)) 70 (mm-disable-multibyte) 71 (setq buffer-file-name name))) 72 73(defun mm-extern-anon-ftp (handle) 74 (erase-buffer) 75 (let* ((params (cdr (mm-handle-type handle))) 76 (name (cdr (assq 'name params))) 77 (site (cdr (assq 'site params))) 78 (directory (cdr (assq 'directory params))) 79 (mode (cdr (assq 'mode params))) 80 (path (concat "/" (or mm-extern-anonymous 81 (read-string (format "ID for %s: " site))) 82 "@" site ":" directory "/" name)) 83 (coding-system-for-read mm-binary-coding-system)) 84 (unless name 85 (error "The filename is not specified")) 86 (mm-disable-multibyte) 87 (mm-insert-file-contents path nil nil nil nil t))) 88 89(defun mm-extern-ftp (handle) 90 (let (mm-extern-anonymous) 91 (mm-extern-anon-ftp handle))) 92 93(defun mm-extern-mail-server (handle) 94 (require 'message) 95 (let* ((params (cdr (mm-handle-type handle))) 96 (server (cdr (assq 'server params))) 97 (subject (or (cdr (assq 'subject params)) "none")) 98 (buf (current-buffer)) 99 info) 100 (if (y-or-n-p (format "Send a request message to %s? " server)) 101 (save-window-excursion 102 (message-mail server subject) 103 (message-goto-body) 104 (delete-region (point) (point-max)) 105 (insert-buffer-substring buf) 106 (message "Requesting external body...") 107 (message-send-and-exit) 108 (setq info "Request is sent.") 109 (message info)) 110 (setq info "Request is not sent.")) 111 (goto-char (point-min)) 112 (insert "[" info "]\n\n"))) 113 114;;;###autoload 115(defun mm-extern-cache-contents (handle) 116 "Put the external-body part of HANDLE into its cache." 117 (let* ((access-type (cdr (assq 'access-type 118 (cdr (mm-handle-type handle))))) 119 (func (cdr (assq (intern 120 (downcase 121 (or access-type 122 (error "Couldn't find access type")))) 123 mm-extern-function-alist))) 124 buf handles) 125 (unless func 126 (error "Access type (%s) is not supported" access-type)) 127 (mm-with-part handle 128 (goto-char (point-max)) 129 (insert "\n\n") 130 ;; It should be just a single MIME handle. 131 (setq handles (mm-dissect-buffer t))) 132 (unless (bufferp (car handles)) 133 (mm-destroy-parts handles) 134 (error "Multipart external body is not supported")) 135 (save-excursion 136 (set-buffer (setq buf (mm-handle-buffer handles))) 137 (let (good) 138 (unwind-protect 139 (progn 140 (funcall func handle) 141 (setq good t)) 142 (unless good 143 (mm-destroy-parts handles)))) 144 (mm-handle-set-cache handle handles)) 145 (setq gnus-article-mime-handles 146 (mm-merge-handles gnus-article-mime-handles handles)))) 147 148;;;###autoload 149(defun mm-inline-external-body (handle &optional no-display) 150 "Show the external-body part of HANDLE. 151This function replaces the buffer of HANDLE with a buffer contains 152the entire message. 153If NO-DISPLAY is nil, display it. Otherwise, do nothing after replacing." 154 (unless (mm-handle-cache handle) 155 (mm-extern-cache-contents handle)) 156 (unless no-display 157 (save-excursion 158 (save-restriction 159 (narrow-to-region (point) (point)) 160 (mm-display-part (mm-handle-cache handle)))) 161 ;; Move undisplayer added to the cached handle to the parent. 162 (mm-handle-set-undisplayer 163 handle (mm-handle-undisplayer (mm-handle-cache handle))) 164 (mm-handle-set-undisplayer (mm-handle-cache handle) nil))) 165 166(provide 'mm-extern) 167 168;;; arch-tag: 9653808e-14d9-4172-86e6-adceaa05378e 169;;; mm-extern.el ends here 170