mime-tar.el

   1 ;;; mime-tar.el --- mime-view internal method for tar or tar+gzip format
   2
   3 ;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
   4
   5 ;; Author: Hiroshi Ueno <zodiac@ibm.net>
   6 ;;      modified by MORIOKA Tomohiko <morioka@jaist.ac.jp>
   7 ;; Renamed: 1997/2/26 from tm-tar.el
   8 ;; Version: $Id: mime-tar.el,v 0.2 1997-02-27 08:36:01 tmorioka Exp $
   9 ;; Keywords: tar, tar+gzip, MIME, multimedia, mail, news
  10
  11 ;; This file is part of SEMI (SEMI is Emacs MIME Interfaces).
  12
  13 ;; This program is free software; you can redistribute it and/or
  14 ;; modify it under the terms of the GNU General Public License as
  15 ;; published by the Free Software Foundation; either version 2, or (at
  16 ;; your option) any later version.
  17
  18 ;; This program is distributed in the hope that it will be useful, but
  19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21 ;; General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26 ;; Boston, MA 02111-1307, USA.
  27
  28 ;;; Commentary:
  29
  30 ;; Internal viewer for
  31 ;;    - application/x-tar
  32 ;;    - application/x-gzip, type="tar"
  33 ;;    - aplication/octet-stream, type="tar"
  34 ;;    - aplication/octet-stream, type="tar+gzip"
  35
  36 ;;; Code:
  37
  38 (require 'mime-view)
  39
  40
  41 ;;; @ constants
  42 ;;;
  43
  44 (defconst mime-tar-list-buffer "*mime-tar-List*")
  45 (defconst mime-tar-view-buffer "*mime-tar-View*")
  46 (defconst mime-tar-file-search-regexp "[0-9]+\:[0-9\:]+[ ]+[0-9]+[ ]+")
  47 (defconst mime-tar-popup-menu-title "Action Menu")
  48
  49
  50 ;;; @ variables
  51 ;;;
  52
  53 (defvar mime-tar-program "gtar")
  54 (defvar mime-tar-decompress-arg '("-z"))
  55 (defvar mime-tar-gzip-program "gzip")
  56 (defvar mime-tar-mmencode-program "mmencode")
  57 (defvar mime-tar-uudecode-program "uudecode")
  58
  59 (defvar mime-tar-popup-menu-items
  60   '(("View File"                . mime-tar-view-file)
  61     ("Key Help"                 . mime-tar-helpful-message)
  62     ("Quit mime-tar Mode"       . exit-recursive-edit)
  63     ))
  64
  65 (cond ((string-match "XEmacs\\|Lucid" emacs-version)
  66        (defvar mime-tar-popup-menu
  67          (cons mime-tar-popup-menu-title
  68                (mapcar (function
  69                         (lambda (item)
  70                           (vector (car item)(cdr item) t)
  71                           ))
  72                        mime-tar-popup-menu-items)))
  73
  74        (defun mime-tar-mouse-button-2 (event)
  75          (popup-menu mime-tar-popup-menu)
  76          )
  77        )
  78       ((>= emacs-major-version 19)
  79        (defun mime-tar-mouse-button-2 (event)
  80          (let ((menu
  81                 (cons mime-tar-popup-menu-title
  82                       (list (cons "Menu Items" mime-tar-popup-menu-items))
  83                       )))
  84            (let ((func (x-popup-menu event menu)))
  85              (if func
  86                  (funcall func)
  87                ))
  88            ))
  89        ))
  90
  91 (defvar mime-tar-mode-map nil)
  92 (if mime-tar-mode-map
  93     nil
  94   (setq mime-tar-mode-map (make-keymap))
  95   (suppress-keymap mime-tar-mode-map)
  96   (define-key mime-tar-mode-map "\C-c"    'exit-recursive-edit)
  97   (define-key mime-tar-mode-map "q"       'exit-recursive-edit)
  98   (define-key mime-tar-mode-map "n"       'mime-tar-next-line)
  99   (define-key mime-tar-mode-map " "       'mime-tar-next-line)
 100   (define-key mime-tar-mode-map "\C-m"    'mime-tar-next-line)
 101   (define-key mime-tar-mode-map "p"       'mime-tar-previous-line)
 102   (define-key mime-tar-mode-map "\177"    'mime-tar-previous-line)
 103   (define-key mime-tar-mode-map "\C-\M-m" 'mime-tar-previous-line)
 104   (define-key mime-tar-mode-map "v"       'mime-tar-view-file)
 105   (define-key mime-tar-mode-map "\C-h"    'Helper-help)
 106   (define-key mime-tar-mode-map "?"       'mime-tar-helpful-message)
 107   (if mouse-button-2
 108       (define-key mime-tar-mode-map
 109         mouse-button-2 'mime-button-dispatcher))
 110   )
 111
 112
 113 ;;; @@ mime-tar mode functions
 114 ;;;
 115
 116 (defun mime-tar-mode (&optional prev-buf)
 117   "Major mode for listing the contents of a tar archive file."
 118   (unwind-protect
 119       (let ((buffer-read-only t)
 120             (mode-name "mime-tar")
 121             (mode-line-buffer-identification '("%17b"))
 122             )
 123         (goto-char (point-min))
 124         (mime-tar-move-to-filename)
 125         (catch 'mime-tar-mode (mime-tar-command-loop))
 126         )
 127     (if prev-buf
 128         (switch-to-buffer prev-buf)
 129       )
 130     ))
 131
 132 (defun mime-tar-command-loop ()
 133   (let ((old-local-map (current-local-map)))
 134     (unwind-protect
 135         (progn
 136           (use-local-map mime-tar-mode-map)
 137           (mime-tar-helpful-message)
 138           (recursive-edit)
 139           )
 140       (save-excursion
 141         (use-local-map old-local-map)
 142         ))
 143     ))
 144
 145 (defun mime-tar-next-line ()
 146   (interactive)
 147   (next-line 1)
 148   (mime-tar-move-to-filename)
 149   )
 150
 151 (defun mime-tar-previous-line ()
 152   (interactive)
 153   (previous-line 1)
 154   (mime-tar-move-to-filename)
 155   )
 156
 157 (defun mime-tar-view-file ()
 158   (interactive)
 159   (let ((name (mime-tar-get-filename))
 160         )
 161     (save-excursion
 162       (switch-to-buffer mime-tar-view-buffer)
 163       (setq buffer-read-only nil)
 164       (erase-buffer)
 165       (message "Reading a file from an archive. Please wait...")
 166       (apply 'call-process mime-tar-program
 167              nil t nil (append mime-tar-view-args (list name)))
 168       (goto-char (point-min))
 169       )
 170     (view-buffer mime-tar-view-buffer)
 171     ))
 172
 173 (defun mime-tar-get-filename ()
 174   (let (eol)
 175     (save-excursion
 176       (end-of-line)
 177       (setq eol (point))
 178       (beginning-of-line)
 179       (save-excursion
 180         (if (re-search-forward "^d" eol t)
 181             (error "Cannot view a directory"))
 182         )
 183       (if (re-search-forward mime-tar-file-search-regexp eol t)
 184           (let ((beg (point)))
 185             (skip-chars-forward "^ \n")
 186             (buffer-substring beg (point))
 187             )
 188         (error "No file on this line")
 189         ))
 190     ))
 191
 192 (defun mime-tar-move-to-filename ()
 193   (let ((eol (progn (end-of-line) (point))))
 194     (beginning-of-line)
 195     (re-search-forward mime-tar-file-search-regexp eol t)
 196     ))
 197
 198 (defun mime-tar-set-properties ()
 199   (if mouse-button-2
 200       (let ((beg (point-min))
 201             (end (point-max))
 202             )
 203         (goto-char beg)
 204         (save-excursion
 205           (while (re-search-forward mime-tar-file-search-regexp end t)
 206             (mime-add-button (point)
 207                              (progn
 208                                (end-of-line)
 209                                (point))
 210                              'mime-tar-view-file)
 211             ))
 212         )))
 213
 214 (defun mime-tar-helpful-message ()
 215   (interactive)
 216   (message "Type %s, %s, %s, %s, %s, %s."
 217            (substitute-command-keys "\\[Helper-help] for help")
 218            (substitute-command-keys "\\[mime-tar-helpful-message] for keys")
 219            (substitute-command-keys "\\[mime-tar-next-line] to next")
 220            (substitute-command-keys "\\[mime-tar-previous-line] to prev")
 221            (substitute-command-keys "\\[mime-tar-view-file] to view")
 222            (substitute-command-keys "\\[exit-recursive-edit] to quit")
 223            ))
 224
 225 (defun mime-tar-y-or-n-p (prompt)
 226   (prog1
 227       (y-or-n-p prompt)
 228     (message "")
 229     ))
 230
 231 ;;; @@ tar message decoder
 232 ;;
 233
 234 (defun mime-decode-message/tar (beg end cal)
 235   (if (mime-tar-y-or-n-p "Do you want to enter mime-tar mode? ")
 236       (let ((coding (cdr (assoc 'encoding cal)))
 237             (cur-buf (current-buffer))
 238             (mime-tar-file-name
 239              (expand-file-name
 240               (concat (make-temp-name
 241                        (expand-file-name "tm" mime/tmp-dir)) ".tar")))
 242             (mime-tar-tmp-file-name
 243              (expand-file-name (make-temp-name
 244                                 (expand-file-name "tm" mime/tmp-dir))))
 245             new-buf)
 246         (find-file mime-tar-tmp-file-name)
 247         (setq new-buf (current-buffer))
 248         (setq buffer-read-only nil)
 249         (erase-buffer)
 250         (save-excursion
 251           (set-buffer cur-buf)
 252           (goto-char beg)
 253           (re-search-forward "^$")
 254           (append-to-buffer new-buf (+ (match-end 0) 1) end)
 255           )
 256         (if (member coding mime-viewer/uuencode-encoding-name-list)
 257             (progn
 258               (goto-char (point-min))
 259               (if (re-search-forward "^begin [0-9]+ " nil t)
 260                   (progn
 261                     (kill-line)
 262                     (insert mime-tar-file-name)
 263                     )
 264                 (progn
 265                   (set-buffer-modified-p nil)
 266                   (kill-buffer new-buf)
 267                   (error "uuencode file signature was not found")
 268                   ))))
 269         (save-buffer)
 270         (kill-buffer new-buf)
 271         (message "Listing the contents of an archive.  Please wait...")
 272         (cond ((string-equal coding "base64")
 273                (call-process mime-tar-mmencode-program nil nil nil "-u"
 274                              "-o" mime-tar-file-name mime-tar-tmp-file-name)
 275                )
 276               ((string-equal coding "quoted-printable")
 277                (call-process mime-tar-mmencode-program nil nil nil "-u" "-q"
 278                              "-o" mime-tar-file-name mime-tar-tmp-file-name)
 279                )
 280               ((member coding mime-viewer/uuencode-encoding-name-list)
 281                (call-process mime-tar-uudecode-program nil nil nil
 282                              mime-tar-tmp-file-name)
 283                )
 284               (t
 285                (copy-file mime-tar-tmp-file-name mime-tar-file-name t)
 286                ))
 287         (delete-file mime-tar-tmp-file-name)
 288         (setq mime-tar-list-args (list "-tvf" mime-tar-file-name))
 289         (setq mime-tar-view-args (list "-xOf" mime-tar-file-name))
 290         (if (eq 0 (call-process mime-tar-gzip-program
 291                                 nil nil nil "-t" mime-tar-file-name))
 292             (progn
 293               (setq mime-tar-list-args
 294                     (append mime-tar-decompress-arg mime-tar-list-args))
 295               (setq mime-tar-view-args
 296                     (append mime-tar-decompress-arg mime-tar-view-args))
 297               ))
 298         (switch-to-buffer mime-tar-view-buffer)
 299         (switch-to-buffer mime-tar-list-buffer)
 300         (setq buffer-read-only nil)
 301         (erase-buffer)
 302         (apply 'call-process mime-tar-program
 303                nil t nil mime-tar-list-args)
 304         (if mouse-button-2
 305             (progn
 306               (make-local-variable 'mime-button-mother-dispatcher)
 307               (setq mime-button-mother-dispatcher 'mime-tar-mouse-button-2)
 308               ))
 309         (mime-tar-set-properties)
 310         (mime-tar-mode mime::article/preview-buffer)
 311         (kill-buffer mime-tar-view-buffer)
 312         (kill-buffer mime-tar-list-buffer)
 313         (delete-file mime-tar-file-name)
 314         )
 315     ))
 316
 317 ;;; @@ program/buffer coding system
 318 ;;;
 319
 320 (cond ((boundp 'MULE)
 321        (define-program-coding-system mime-tar-view-buffer nil *autoconv*)
 322        )
 323       ((boundp 'NEMACS)
 324        (define-program-kanji-code mime-tar-view-buffer nil 1)
 325        ))
 326
 327 ;;; @@ message types to use mime-tar
 328 ;;;
 329
 330 (set-atype 'mime/content-decoding-condition
 331            '((type . "application/octet-stream")
 332              (method . mime-decode-message/tar)
 333              (mode . "play") ("type" . "tar")
 334              ))
 335
 336 (set-atype 'mime/content-decoding-condition
 337            '((type . "application/octet-stream")
 338              (method . mime-decode-message/tar)
 339              (mode . "play") ("type" . "tar+gzip")
 340              ))
 341
 342 (set-atype 'mime/content-decoding-condition
 343            '((type . "application/x-gzip")
 344              (method . mime-decode-message/tar)
 345              (mode . "play") ("type" . "tar")
 346              ))
 347
 348 (set-atype 'mime/content-decoding-condition
 349            '((type . "application/x-tar")
 350              (method . mime-decode-message/tar)
 351              (mode . "play")
 352              ))
 353
 354 ;;; @ end
 355 ;;;
 356
 357 (provide 'mime-tar)
 358
 359 ;;; mime-tar.el ends here