cgit.sxemacs.org Git - gnus/blob - lisp/mm-archive.el

   1 ;;; mm-archive.el --- Functions for parsing archive files as MIME
   2
   3 ;; Copyright (C) 2012  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 <http://www.gnu.org/licenses/>.
  20
  21 ;;; Commentary:
  22
  23 ;;; Code:
  24
  25 (defvar mm-archive-decoders
  26   '(("application/ms-tnef" "tnef" "-f" "-" "-C")
  27     ("application/x-tar" "tar" "xf" "-" "-C")))
  28
  29 (defun mm-dissect-archive (handle)
  30   (let ((decoder (cdr (assoc (car (mm-handle-type handle))
  31                              mm-archive-decoders)))
  32         (dir (mm-make-temp-file
  33               (expand-file-name "emm." mm-tmp-directory) 'dir)))
  34     (set-file-modes dir #o700)
  35     (unwind-protect
  36         (progn
  37           (mm-with-unibyte-buffer
  38             (mm-insert-part handle)
  39             (apply 'call-process-region (point-min) (point-max) (car decoder)
  40                    nil (get-buffer-create "*tnef*")
  41                    nil (append (cdr decoder) (list dir))))
  42           `("multipart/mixed"
  43             ,handle
  44             ,@(mm-archive-list-files dir)))
  45       (dolist (file (directory-files dir))
  46         (unless (member file '("." ".."))
  47           (ignore-errors
  48             (delete-file (expand-file-name file dir)))))
  49       (ignore-errors
  50         (delete-directory dir)))))
  51
  52 (defun mm-archive-list-files (dir)
  53   (let ((handles nil)
  54         type)
  55     (dolist (file (directory-files dir))
  56       (unless (member file '("." ".."))
  57         (with-temp-buffer
  58           (when (string-match "\\.\\([^.]+\\)$" file)
  59             (setq type (mailcap-extension-to-mime (match-string 1 file))))
  60           (unless type
  61             (setq type "application/octet-stream"))
  62           (insert (format "Content-type: %s\n" type))
  63           (insert "Content-Transfer-Encoding: 8bit\n\n")
  64           (insert-file-contents (expand-file-name file dir))
  65           (push
  66            (mm-make-handle (mm-copy-to-buffer)
  67                            (list type)
  68                            '8bit nil
  69                            `("attachment" (filename . ,file))
  70                            nil nil nil)
  71            handles))))
  72     handles))
  73
  74 (provide 'mm-archive)
  75
  76 ;; mm-archive.el ends here