tm-tar.el

   1 ;;;
   2 ;;; $Id: tm-tar.el,v 1.1 1995/09/18 17:09:19 H.Ueno Exp $
   3 ;;;
   4 ;;; tm-tar.el
   5 ;;;
   6 ;;; Internal viewer for
   7 ;;;    - application/x-tar
   8 ;;;    - application/x-gzip, type="tar"
   9 ;;;    - aplication/octet-stream, type="tar"
  10 ;;;    - aplication/octet-stream, type="tar+gzip"
  11 ;;;
  12 ;;; by Hiroshi Ueno <zodiac@ibm.net>
  13 ;;;
  14
  15 ;;; @ required modules
  16 ;;;
  17
  18 (require 'emu)
  19 (require 'tm-view)
  20
  21 ;;; @ constants
  22 ;;;
  23
  24 (defconst tm-tar/list-buffer "*tm-tar/List*")
  25 (defconst tm-tar/view-buffer "*tm-tar/View*")
  26 (defconst tm-tar/file-search-regexp "[0-9]+\:[0-9\:]+[ ]+[0-9]+[ ]+")
  27
  28 ;;; @ variables
  29 ;;;
  30
  31 (defvar tm-tar/tar-program  "gtar")
  32 (defvar tm-tar/tar-compress-arg '("-z"))
  33 (defvar tm-tar/gzip-program "gzip")
  34 (defvar tm-tar/mmencode-program "mmencode")
  35 (defvar tm-tar/uudecode-program "uudecode")
  36
  37 (defvar mime/tm-tar-mode-map nil)
  38 (if mime/tm-tar-mode-map
  39       nil
  40     (setq mime/tm-tar-mode-map (make-keymap))
  41     (suppress-keymap mime/tm-tar-mode-map)
  42     (define-key mime/tm-tar-mode-map "\C-c"    'exit-recursive-edit)
  43     (define-key mime/tm-tar-mode-map "q"       'exit-recursive-edit)
  44     (define-key mime/tm-tar-mode-map "n"       'mime/tm-tar/next-line)
  45     (define-key mime/tm-tar-mode-map " "       'mime/tm-tar/next-line)
  46     (define-key mime/tm-tar-mode-map "\C-m"    'mime/tm-tar/next-line)
  47     (define-key mime/tm-tar-mode-map "p"       'mime/tm-tar/previous-line)
  48     (define-key mime/tm-tar-mode-map "\177"    'mime/tm-tar/previous-line)
  49     (define-key mime/tm-tar-mode-map "\C-\M-m" 'mime/tm-tar/previous-line)
  50     (define-key mime/tm-tar-mode-map "v"       'mime/tm-tar/view-file)
  51     (define-key mime/tm-tar-mode-map "\C-h"    'Helper-help)
  52     (define-key mime/tm-tar-mode-map "?"       'mime/tm-tar/helpful-message)
  53     (cond ((string-match "XEmacs\\|Lucid" emacs-version)
  54            (define-key mime/tm-tar-mode-map
  55                                      'button2  'mime/tm-tar/view-file-mouse)
  56            )
  57           ((> emacs-major-version 18)
  58            (define-key mime/tm-tar-mode-map
  59                                      [mouse-2] 'mime/tm-tar/view-file-mouse)
  60            ))
  61   )
  62
  63 ;;; @@ tm-tar mode functions
  64 ;;;
  65
  66 (defun mime/tm-tar-mode (&optional prev-buf)
  67   "Major mode for listing the contents of a tar archive file."
  68     (unwind-protect
  69         (let ((buffer-read-only t)
  70               (mode-name "tm-tar")
  71               (mode-line-buffer-identification '("%17b"))
  72               )
  73             (goto-char (point-min))
  74             (mime/tm-tar/move-to-filename)
  75             (catch 'mime/tm-tar-mode (mime/tm-tar-mode/command-loop))
  76          )
  77         (if prev-buf
  78             (switch-to-buffer prev-buf)
  79          )
  80      ))
  81
  82 (defun mime/tm-tar-mode/command-loop ()
  83     (let ((old-local-map (current-local-map))
  84           )
  85         (unwind-protect
  86             (progn
  87                 (use-local-map mime/tm-tar-mode-map)
  88                 (mime/tm-tar/helpful-message)
  89                 (recursive-edit)
  90              )
  91             (save-excursion
  92                 (use-local-map old-local-map)
  93              ))
  94      ))
  95
  96 (defun mime/tm-tar/next-line ()
  97     (interactive)
  98     (next-line 1)
  99     (mime/tm-tar/move-to-filename)
 100   )
 101
 102 (defun mime/tm-tar/previous-line ()
 103     (interactive)
 104     (previous-line 1)
 105     (mime/tm-tar/move-to-filename)
 106   )
 107
 108 (defun mime/tm-tar/view-file ()
 109     (interactive)
 110     (let ((name (mime/tm-tar/get-filename))
 111           )
 112       (save-excursion
 113           (switch-to-buffer tm-tar/view-buffer)
 114           (setq buffer-read-only nil)
 115           (erase-buffer)
 116           (message "Reading a file from the archive. Please wait...")
 117           (apply 'call-process tm-tar/tar-program
 118                        nil t nil (append tm-tar/view-args (list name)))
 119           (goto-char (point-min))
 120        )
 121         (view-buffer tm-tar/view-buffer)
 122      ))
 123
 124 (defun mime/tm-tar/view-file-mouse (e)
 125     (interactive "e")
 126     (mouse-set-point e)
 127     (mime/tm-tar/view-file)
 128   )
 129
 130 (defun mime/tm-tar/get-filename ()
 131     (let (eol)
 132         (save-excursion
 133             (end-of-line)
 134             (setq eol (point))
 135             (beginning-of-line)
 136             (save-excursion
 137                 (if (re-search-forward "^d" eol t)
 138                        (error "Cannot view a directory"))
 139              )
 140             (if (re-search-forward tm-tar/file-search-regexp eol t)
 141                      (progn (let ((beg (point))
 142                                   )
 143                                 (skip-chars-forward "^ \n")
 144                                 (buffer-substring beg (point))
 145                              ))
 146                      (error "No file on this line")
 147              ))
 148      ))
 149
 150 (defun mime/tm-tar/move-to-filename ()
 151     (let ((eol (progn (end-of-line) (point)))
 152           )
 153         (beginning-of-line)
 154         (re-search-forward tm-tar/file-search-regexp eol t)
 155      ))
 156
 157 (defun mime/tm-tar/set-properties ()
 158     (if (> emacs-major-version 18)
 159         (let ((beg (point-min))
 160               (end (point-max))
 161               )
 162             (goto-char beg)
 163             (save-excursion
 164                 (while (re-search-forward tm-tar/file-search-regexp end t)
 165                     (put-text-property (point)
 166                                        (progn
 167                                            (end-of-line)
 168                                            (point))
 169                                        'mouse-face 'highlight)
 170                  ))
 171          )))
 172
 173 (defun mime/tm-tar/helpful-message ()
 174     (interactive)
 175     (message "Type %s, %s, %s, %s, %s, %s."
 176         (substitute-command-keys "\\[Helper-help] for help")
 177         (substitute-command-keys "\\[mime/tm-tar/helpful-message] for key")
 178         (substitute-command-keys "\\[mime/tm-tar/next-line] to next")
 179         (substitute-command-keys "\\[mime/tm-tar/previous-line] to prev")
 180         (substitute-command-keys "\\[mime/tm-tar/view-file] to view")
 181         (substitute-command-keys "\\[exit-recursive-edit] to quit")
 182      ))
 183
 184 ;;; @@ tar message decoder
 185 ;;
 186
 187 (defun mime/decode-message/tar (beg end cal)
 188     (let ((coding (cdr (assoc 'encoding cal)))
 189           (cur-buf (current-buffer))
 190           (tm-tar/tar-file-name (expand-file-name (concat (make-temp-name
 191                       (expand-file-name "tm" mime/tmp-dir)) ".tar")))
 192           (tm-tar/tmp-file-name (expand-file-name (make-temp-name
 193                       (expand-file-name "tm" mime/tmp-dir))))
 194           new-buf
 195           )
 196         (find-file tm-tar/tmp-file-name)
 197         (setq new-buf (current-buffer))
 198         (setq buffer-read-only nil)
 199         (erase-buffer)
 200         (save-excursion
 201             (set-buffer cur-buf)
 202             (goto-char beg)
 203             (re-search-forward "^$")
 204             (append-to-buffer new-buf (+ (match-end 0) 1) end)
 205          )
 206         (if (member coding mime-viewer/uuencode-encoding-name-list)
 207             (progn
 208                 (goto-char (point-min))
 209                 (if (re-search-forward "^begin [0-9]+ " nil t)
 210                     (progn
 211                         (kill-line)
 212                         (insert tm-tar/tar-file-name)
 213                      )
 214                     (progn
 215                         (set-buffer-modified-p nil)
 216                         (kill-buffer new-buf)
 217                         (error "uuencode file signature was not found")
 218                      ))))
 219         (save-buffer)
 220         (kill-buffer new-buf)
 221         (message "Listing the contents of archive.  Please wait...")
 222         (cond ((string-equal coding "base64")
 223                  (call-process tm-tar/mmencode-program nil nil nil "-u"
 224                              "-o" tm-tar/tar-file-name tm-tar/tmp-file-name)
 225                 )
 226               ((string-equal coding "quoted-printable")
 227                  (call-process tm-tar/mmencode-program nil nil nil "-u" "-q"
 228                              "-o" tm-tar/tar-file-name tm-tar/tmp-file-name)
 229                 )
 230               ((member coding mime-viewer/uuencode-encoding-name-list)
 231                  (call-process tm-tar/uudecode-program nil nil nil
 232                              tm-tar/tmp-file-name)
 233                 )
 234               (t
 235                  (copy-file tm-tar/tmp-file-name tm-tar/tar-file-name t)
 236                 ))
 237         (delete-file tm-tar/tmp-file-name)
 238         (setq tm-tar/list-args (list "-tvf" tm-tar/tar-file-name))
 239         (setq tm-tar/view-args (list "-xOf" tm-tar/tar-file-name))
 240         (if (eq 0 (call-process tm-tar/gzip-program
 241                             nil nil nil "-t" tm-tar/tar-file-name))
 242             (progn
 243                 (setq tm-tar/list-args
 244                       (append tm-tar/tar-compress-arg tm-tar/list-args))
 245                 (setq tm-tar/view-args
 246                       (append tm-tar/tar-compress-arg tm-tar/view-args))
 247              ))
 248         (switch-to-buffer tm-tar/view-buffer)
 249         (switch-to-buffer tm-tar/list-buffer)
 250         (setq buffer-read-only nil)
 251         (erase-buffer)
 252         (apply 'call-process tm-tar/tar-program
 253                              nil t nil tm-tar/list-args)
 254         (mime/tm-tar/set-properties)
 255         (mime/tm-tar-mode cur-buf)
 256         (kill-buffer tm-tar/view-buffer)
 257         (kill-buffer tm-tar/list-buffer)
 258         (delete-file tm-tar/tar-file-name)
 259      ))
 260
 261 ;;; @@ program/buffer coding system
 262 ;;;
 263
 264 (cond ((boundp 'MULE)
 265        (define-program-coding-system tm-tar/view-buffer nil *autoconv*)
 266        )
 267       ((boundp 'NEMACS)
 268        (define-program-kanji-code tm-tar/view-buffer nil 1)
 269        ))
 270
 271 ;;; @@ message types to use tm-tar
 272 ;;;
 273
 274 (set-atype 'mime/content-decoding-condition
 275            '((type . "application/octet-stream")
 276              (method . mime/decode-message/tar)
 277              (mode . "play") ("type" . "tar")
 278              ))
 279
 280 (set-atype 'mime/content-decoding-condition
 281            '((type . "application/octet-stream")
 282              (method . mime/decode-message/tar)
 283              (mode . "play") ("type" . "tar+gzip")
 284              ))
 285
 286 (set-atype 'mime/content-decoding-condition
 287            '((type . "application/x-gzip")
 288              (method . mime/decode-message/tar)
 289              (mode . "play") ("type" . "tar")
 290              ))
 291
 292 (set-atype 'mime/content-decoding-condition
 293            '((type . "application/x-tar")
 294              (method . mime/decode-message/tar)
 295              (mode . "play")
 296              ))
 297
 298 ;;; @ end
 299 ;;;
 300
 301 (provide 'tm-tar)
 302