lisp/gnus/mm-archive.el

   1 ;;; mm-archive.el --- Functions for parsing archive files as MIME
   2
   3 ;; Copyright (C) 2012-2018 Free Software Foundation, Inc.
   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 <https://www.gnu.org/licenses/>.
  20
  21 ;;; Commentary:
  22
  23 ;;; Code:
  24
  25 (require 'mm-decode)
  26 (autoload 'gnus-recursive-directory-files "gnus-util")
  27 (autoload 'mailcap-extension-to-mime "mailcap")
  28
  29 (defvar mm-archive-decoders
  30   '(("application/ms-tnef" t "tnef" "-f" "-" "-C")
  31     ("application/zip" nil "unzip" "-j" "-x" "%f" "-d")
  32     ("application/x-gtar-compressed" nil "tar" "xzf" "-" "-C")
  33     ("application/x-tar-gz" 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* ((type (car (mm-handle-type handle)))
  40          (decoder (cddr (assoc type mm-archive-decoders)))
  41          dir)
  42     (unless decoder
  43       (error "No decoder found for %s" type))
  44     (setq dir (make-temp-file (expand-file-name "emm." mm-tmp-directory) 'dir))
  45     (set-file-modes dir #o700)
  46     (unwind-protect
  47         (progn
  48           (mm-with-unibyte-buffer
  49             (mm-insert-part handle)
  50             (if (member "%f" decoder)
  51                 (let ((file (expand-file-name "mail.zip" dir)))
  52                   (write-region (point-min) (point-max) file nil 'silent)
  53                   (setq decoder (copy-sequence decoder))
  54                   (setcar (member "%f" decoder) file)
  55                   (apply 'call-process (car decoder) nil nil nil
  56                          (append (cdr decoder) (list dir)))
  57                   (delete-file file))
  58               (apply 'call-process-region (point-min) (point-max) (car decoder)
  59                      nil (get-buffer-create "*tnef*")
  60                      nil (append (cdr decoder) (list dir)))))
  61           `("multipart/mixed"
  62             ,handle
  63             ,@(mm-archive-list-files (gnus-recursive-directory-files dir))))
  64       (delete-directory dir t))))
  65
  66 (defun mm-archive-list-files (files)
  67   (let ((handles nil)
  68         type disposition)
  69     (dolist (file files)
  70       (with-temp-buffer
  71         (when (string-match "\\.\\([^.]+\\)$" file)
  72           (setq type (mailcap-extension-to-mime (match-string 1 file))))
  73         (unless type
  74           (setq type "application/octet-stream"))
  75         (setq disposition
  76               (if (string-match "^image/\\|^text/" type)
  77                   "inline"
  78                 "attachment"))
  79         (insert (format "Content-type: %s\n" type))
  80         (insert "Content-Transfer-Encoding: 8bit\n\n")
  81         (insert-file-contents file)
  82         (push
  83          (mm-make-handle (mm-copy-to-buffer)
  84                          (list type)
  85                          '8bit nil
  86                          `(,disposition (filename . ,file))
  87                          nil nil nil)
  88          handles)))
  89     handles))
  90
  91 (defun mm-archive-dissect-and-inline (handle)
  92   (let ((start (point-marker)))
  93     (save-restriction
  94       (narrow-to-region (point) (point))
  95       (dolist (handle (cddr (mm-dissect-archive handle)))
  96         (goto-char (point-max))
  97         (mm-display-inline handle))
  98       (goto-char (point-max))
  99       (mm-handle-set-undisplayer
 100        handle
 101        `(lambda ()
 102           (let ((inhibit-read-only t)
 103                 (end ,(point-marker)))
 104             (remove-images ,start end)
 105             (delete-region ,start end)))))))
 106
 107 (provide 'mm-archive)
 108
 109 ;; mm-archive.el ends here