tm-tar.el

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