Commit | Line | Data |
---|---|---|
3ea82dff G |
1 | ;;; mm-archive.el --- Functions for parsing archive files as MIME |
2 | ||
ba318903 | 3 | ;; Copyright (C) 2012-2014 Free Software Foundation, Inc. |
3ea82dff G |
4 | |
5 | ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> | |
6 | ;; This file is part of GNU Emacs. | |
7 | ||
8 | ;; GNU Emacs is free software: you can redistribute it and/or modify | |
9 | ;; it under the terms of the GNU General Public License as published by | |
10 | ;; the Free Software Foundation, either version 3 of the License, or | |
11 | ;; (at your option) any later version. | |
12 | ||
13 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
16 | ;; GNU General Public License for more details. | |
17 | ||
18 | ;; You should have received a copy of the GNU General Public License | |
19 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | |
20 | ||
21 | ;;; Commentary: | |
22 | ||
23 | ;;; Code: | |
24 | ||
25 | (require 'mm-decode) | |
26 | (eval-when-compile | |
27 | (autoload 'gnus-recursive-directory-files "gnus-util") | |
28 | (autoload 'mailcap-extension-to-mime "mailcap")) | |
29 | ||
30 | (defvar mm-archive-decoders | |
31 | '(("application/ms-tnef" t "tnef" "-f" "-" "-C") | |
32 | ("application/zip" nil "unzip" "-j" "-x" "%f" "-d") | |
33 | ("application/x-gtar-compressed" nil "tar" "xzf" "-" "-C") | |
34 | ("application/x-tar" nil "tar" "xf" "-" "-C"))) | |
35 | ||
36 | (defun mm-archive-decoders () mm-archive-decoders) | |
37 | ||
38 | (defun mm-dissect-archive (handle) | |
39 | (let ((decoder (cddr (assoc (car (mm-handle-type handle)) | |
40 | mm-archive-decoders))) | |
41 | (dir (mm-make-temp-file | |
42 | (expand-file-name "emm." mm-tmp-directory) 'dir))) | |
43 | (set-file-modes dir #o700) | |
44 | (unwind-protect | |
45 | (progn | |
46 | (mm-with-unibyte-buffer | |
47 | (mm-insert-part handle) | |
48 | (if (member "%f" decoder) | |
49 | (let ((file (expand-file-name "mail.zip" dir))) | |
50 | (write-region (point-min) (point-max) file nil 'silent) | |
51 | (setq decoder (copy-sequence decoder)) | |
52 | (setcar (member "%f" decoder) file) | |
53 | (apply 'call-process (car decoder) nil nil nil | |
54 | (append (cdr decoder) (list dir))) | |
55 | (delete-file file)) | |
56 | (apply 'call-process-region (point-min) (point-max) (car decoder) | |
57 | nil (get-buffer-create "*tnef*") | |
58 | nil (append (cdr decoder) (list dir))))) | |
59 | `("multipart/mixed" | |
60 | ,handle | |
61 | ,@(mm-archive-list-files (gnus-recursive-directory-files dir)))) | |
62 | (delete-directory dir t)))) | |
63 | ||
64 | (defun mm-archive-list-files (files) | |
65 | (let ((handles nil) | |
66 | type disposition) | |
67 | (dolist (file files) | |
68 | (with-temp-buffer | |
69 | (when (string-match "\\.\\([^.]+\\)$" file) | |
70 | (setq type (mailcap-extension-to-mime (match-string 1 file)))) | |
71 | (unless type | |
72 | (setq type "application/octet-stream")) | |
73 | (setq disposition | |
74 | (if (string-match "^image/\\|^text/" type) | |
75 | "inline" | |
76 | "attachment")) | |
77 | (insert (format "Content-type: %s\n" type)) | |
78 | (insert "Content-Transfer-Encoding: 8bit\n\n") | |
79 | (insert-file-contents file) | |
80 | (push | |
81 | (mm-make-handle (mm-copy-to-buffer) | |
82 | (list type) | |
83 | '8bit nil | |
84 | `(,disposition (filename . ,file)) | |
85 | nil nil nil) | |
86 | handles))) | |
87 | handles)) | |
88 | ||
89 | (defun mm-archive-dissect-and-inline (handle) | |
90 | (let ((start (point-marker))) | |
91 | (save-restriction | |
92 | (narrow-to-region (point) (point)) | |
93 | (dolist (handle (cddr (mm-dissect-archive handle))) | |
94 | (goto-char (point-max)) | |
95 | (mm-display-inline handle)) | |
96 | (goto-char (point-max)) | |
97 | (mm-handle-set-undisplayer | |
98 | handle | |
99 | `(lambda () | |
100 | (let ((inhibit-read-only t) | |
101 | (end ,(point-marker))) | |
102 | (remove-images ,start end) | |
103 | (delete-region ,start end))))))) | |
104 | ||
105 | (provide 'mm-archive) | |
106 | ||
107 | ;; mm-archive.el ends here |