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