1 ;;; mm-extern.el --- showing message/external-body -*- lexical-binding:t -*-
3 ;; Copyright (C) 2000-2018 Free Software Foundation, Inc.
5 ;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
6 ;; Keywords: message external-body
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
31 (defvar gnus-article-mime-handles
)
33 (defvar mm-extern-function-alist
34 `((local-file .
,#'mm-extern-local-file
)
35 (url .
,#'mm-extern-url
)
36 (anon-ftp .
,#'mm-extern-anon-ftp
)
37 (ftp .
,#'mm-extern-ftp
)
38 ;; (tftp . ,#'mm-extern-tftp)
39 (mail-server .
,#'mm-extern-mail-server
)
40 ;; (afs . ,#'mm-extern-afs))
43 (defvar mm-extern-anonymous
"anonymous")
45 (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
))
50 (error "The filename is not specified"))
51 (mm-disable-multibyte)
52 (if (file-exists-p name
)
53 (mm-insert-file-contents name nil nil nil nil t
)
54 (error "File %s is gone" name
))))
56 (defun mm-extern-url (handle)
58 (let ((url (cdr (assq 'url
(cdr (mm-handle-type handle
)))))
59 (name buffer-file-name
)
60 (coding-system-for-read mm-binary-coding-system
))
62 (error "URL is not specified"))
63 (mm-disable-multibyte)
64 (mm-url-insert-file-contents url
)
65 (setq buffer-file-name name
)))
67 (defun mm-extern-anon-ftp (handle)
69 (let* ((params (cdr (mm-handle-type handle
)))
70 (name (cdr (assq 'name params
)))
71 (site (cdr (assq 'site params
)))
72 (directory (cdr (assq 'directory params
)))
73 (path (concat "/" (or mm-extern-anonymous
74 (read-string (format "ID for %s: " site
)))
75 "@" site
":" directory
"/" name
))
76 (coding-system-for-read mm-binary-coding-system
))
78 (error "The filename is not specified"))
79 (mm-disable-multibyte)
80 (mm-insert-file-contents path nil nil nil nil t
)))
82 (defun mm-extern-ftp (handle)
83 (let (mm-extern-anonymous)
84 (mm-extern-anon-ftp handle
)))
86 (declare-function message-goto-body
"message" (&optional interactive
))
88 (defun mm-extern-mail-server (handle)
90 (let* ((params (cdr (mm-handle-type handle
)))
91 (server (cdr (assq 'server params
)))
92 (subject (or (cdr (assq 'subject params
)) "none"))
93 (buf (current-buffer))
95 (if (y-or-n-p (format "Send a request message to %s? " server
))
96 (save-window-excursion
97 (message-mail server subject
)
99 (delete-region (point) (point-max))
100 (insert-buffer-substring buf
)
101 (message "Requesting external body...")
102 (message-send-and-exit)
103 (setq info
"Request is sent.")
105 (setq info
"Request is not sent."))
106 (goto-char (point-min))
107 (insert "[" info
"]\n\n")))
110 (defun mm-extern-cache-contents (handle)
111 "Put the external-body part of HANDLE into its cache."
112 (let* ((access-type (cdr (assq 'access-type
113 (cdr (mm-handle-type handle
)))))
114 (func (cdr (assq (intern
117 (error "Couldn't find access type"))))
118 mm-extern-function-alist
)))
121 (error "Access type (%s) is not supported" access-type
))
123 (goto-char (point-max))
125 ;; It should be just a single MIME handle.
126 (setq handles
(mm-dissect-buffer t
)))
127 (unless (bufferp (car handles
))
128 (mm-destroy-parts handles
)
129 (error "Multipart external body is not supported"))
130 (with-current-buffer (mm-handle-buffer handles
)
134 (funcall func handle
)
137 (mm-destroy-parts handles
))))
138 (mm-handle-set-cache handle handles
))
139 (setq gnus-article-mime-handles
140 (mm-merge-handles gnus-article-mime-handles handles
))))
143 (defun mm-inline-external-body (handle &optional no-display
)
144 "Show the external-body part of HANDLE.
145 This function replaces the buffer of HANDLE with a buffer contains
147 If NO-DISPLAY is nil, display it. Otherwise, do nothing after replacing."
148 (unless (mm-handle-cache handle
)
149 (mm-extern-cache-contents handle
))
153 (narrow-to-region (point) (point))
154 (mm-display-part (mm-handle-cache handle
))))
155 ;; Move undisplayer added to the cached handle to the parent.
156 (mm-handle-set-undisplayer
157 handle
(mm-handle-undisplayer (mm-handle-cache handle
)))
158 (mm-handle-set-undisplayer (mm-handle-cache handle
) nil
)))
162 ;;; mm-extern.el ends here