Suppress localized settings in Tramp test.
[emacs.git] / lisp / gnus / mm-archive.el
blobd88e159900bd405955da43ae14fe384196708c30
1 ;;; mm-archive.el --- Functions for parsing archive files as MIME
3 ;; Copyright (C) 2012-2015 Free Software Foundation, Inc.
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
6 ;; This file is part of GNU Emacs.
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.
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.
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/>.
21 ;;; Commentary:
23 ;;; Code:
25 (require 'mm-decode)
26 (eval-when-compile
27 (autoload 'gnus-recursive-directory-files "gnus-util")
28 (autoload 'mailcap-extension-to-mime "mailcap"))
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")))
36 (defun mm-archive-decoders () mm-archive-decoders)
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))))
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))
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)))))))
105 (provide 'mm-archive)
107 ;; mm-archive.el ends here