tm-tar.el

   1 ;;;
   2 ;;; $Id: tm-tar.el,v 1.22 1995/10/21 15:34:33 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 ;;;     modified by Tomohiko Morioka <morioka@jaist.ac.jp>
  14 ;;;
  15
  16 ;;; @ required modules
  17 ;;;
  18
  19 (require 'emu)
  20 (require 'tm-view)
  21
  22 ;;; @ constants
  23 ;;;
  24
  25 (defconst tm-tar/list-buffer "*tm-tar/List*")
  26 (defconst tm-tar/view-buffer "*tm-tar/View*")
  27 (defconst tm-tar/file-search-regexp "[0-9]+\:[0-9\:]+[ ]+[0-9]+[ ]+")
  28 (defconst tm-tar/popup-menu-title "Action Menu")
  29
  30 ;;; @ variables
  31 ;;;
  32
  33 (defvar tm-tar/tar-program  "gtar")
  34 (defvar tm-tar/tar-decompress-arg '("-z"))
  35 (defvar tm-tar/gzip-program "gzip")
  36 (defvar tm-tar/mmencode-program "mmencode")
  37 (defvar tm-tar/uudecode-program "uudecode")
  38
  39 (defvar tm-tar/popup-menu-items
  40   '(("View File"         . tm-tar/view-file)
  41     ("Key Help"          . tm-tar/helpful-message)
  42     ("Quit tm-tar Mode"  . exit-recursive-edit)
  43     ))
  44
  45 (cond ((string-match "XEmacs\\|Lucid" emacs-version)
  46        (defvar tm-tar/popup-menu
  47          (cons tm-tar/popup-menu-title
  48                 (mapcar (function
  49                         (lambda (item)
  50                           (vector (car item)(cdr item) t)
  51                           ))
  52                          tm-tar/popup-menu-items)))
  53
  54        (defun tm-tar/mouse-button-2 (event)
  55            (popup-menu tm-tar/popup-menu)
  56            )
  57        )
  58       ((>= emacs-major-version 19)
  59        (defun tm-tar/mouse-button-2 (event)
  60          (let ((menu
  61                 (cons tm-tar/popup-menu-title
  62                         (list (cons "Menu Items" tm-tar/popup-menu-items))
  63                         )))
  64            (let ((func (x-popup-menu event menu)))
  65                  (if func
  66                      (funcall func)
  67                    ))
  68              ))
  69        ))
  70
  71 (defvar tm-tar/tar-mode-map nil)
  72 (if tm-tar/tar-mode-map
  73       nil
  74     (setq tm-tar/tar-mode-map (make-keymap))
  75     (suppress-keymap tm-tar/tar-mode-map)
  76     (define-key tm-tar/tar-mode-map "\C-c"    'exit-recursive-edit)
  77     (define-key tm-tar/tar-mode-map "q"       'exit-recursive-edit)
  78     (define-key tm-tar/tar-mode-map "n"       'tm-tar/next-line)
  79     (define-key tm-tar/tar-mode-map " "       'tm-tar/next-line)
  80     (define-key tm-tar/tar-mode-map "\C-m"    'tm-tar/next-line)
  81     (define-key tm-tar/tar-mode-map "p"       'tm-tar/previous-line)
  82     (define-key tm-tar/tar-mode-map "\177"    'tm-tar/previous-line)
  83     (define-key tm-tar/tar-mode-map "\C-\M-m" 'tm-tar/previous-line)
  84     (define-key tm-tar/tar-mode-map "v"       'tm-tar/view-file)
  85     (define-key tm-tar/tar-mode-map "\C-h"    'Helper-help)
  86     (define-key tm-tar/tar-mode-map "?"       'tm-tar/helpful-message)
  87     (if mouse-button-2
  88         (define-key tm-tar/tar-mode-map
  89                                   mouse-button-2 'tm:button-dispatcher)
  90         )
  91   )
  92
  93 ;;; @@ tm-tar mode functions
  94 ;;;
  95
  96 (defun tm-tar/tar-mode (&optional prev-buf)
  97   "Major mode for listing the contents of a tar archive file."
  98     (unwind-protect
  99         (let ((buffer-read-only t)
 100               (mode-name "tm-tar")
 101               (mode-line-buffer-identification '("%17b"))
 102               )
 103             (goto-char (point-min))
 104             (tm-tar/move-to-filename)
 105             (catch 'tm-tar/tar-mode (tm-tar/command-loop))
 106          )
 107         (if prev-buf
 108             (switch-to-buffer prev-buf)
 109          )
 110      ))
 111
 112 (defun tm-tar/command-loop ()
 113     (let ((old-local-map (current-local-map))
 114           )
 115         (unwind-protect
 116             (progn
 117                 (use-local-map tm-tar/tar-mode-map)
 118                 (tm-tar/helpful-message)
 119                 (recursive-edit)
 120              )
 121             (save-excursion
 122                 (use-local-map old-local-map)
 123              ))
 124      ))
 125
 126 (defun tm-tar/next-line ()
 127     (interactive)
 128     (next-line 1)
 129     (tm-tar/move-to-filename)
 130   )
 131
 132 (defun tm-tar/previous-line ()
 133     (interactive)
 134     (previous-line 1)
 135     (tm-tar/move-to-filename)
 136   )
 137
 138 (defun tm-tar/view-file ()
 139     (interactive)
 140     (let ((name (tm-tar/get-filename))
 141           )
 142       (save-excursion
 143           (switch-to-buffer tm-tar/view-buffer)
 144           (setq buffer-read-only nil)
 145           (erase-buffer)
 146           (message "Reading a file from an archive. Please wait...")
 147           (apply 'call-process tm-tar/tar-program
 148                          nil t nil (append tm-tar/view-args (list name)))
 149           (goto-char (point-min))
 150        )
 151         (view-buffer tm-tar/view-buffer)
 152      ))
 153
 154 (defun tm-tar/get-filename ()
 155     (let (eol)
 156         (save-excursion
 157             (end-of-line)
 158             (setq eol (point))
 159             (beginning-of-line)
 160             (save-excursion
 161                 (if (re-search-forward "^d" eol t)
 162                          (error "Cannot view a directory"))
 163              )
 164             (if (re-search-forward tm-tar/file-search-regexp eol t)
 165                      (progn (let ((beg (point))
 166                                   )
 167                                 (skip-chars-forward "^ \n")
 168                                 (buffer-substring beg (point))
 169                                 ))
 170                      (error "No file on this line")
 171              ))
 172      ))
 173
 174 (defun tm-tar/move-to-filename ()
 175     (let ((eol (progn (end-of-line) (point)))
 176           )
 177         (beginning-of-line)
 178         (re-search-forward tm-tar/file-search-regexp eol t)
 179      ))
 180
 181 (defun tm-tar/set-properties ()
 182     (if mouse-button-2
 183         (let ((beg (point-min))
 184               (end (point-max))
 185               )
 186             (goto-char beg)
 187             (save-excursion
 188                 (while (re-search-forward tm-tar/file-search-regexp end t)
 189                     (tm:add-button (point)
 190                                            (progn
 191                                                 (end-of-line)
 192                                                 (point))
 193                                            'tm-tar/view-file)
 194                  ))
 195          )))
 196
 197 (defun tm-tar/helpful-message ()
 198     (interactive)
 199     (message "Type %s, %s, %s, %s, %s, %s."
 200         (substitute-command-keys "\\[Helper-help] for help")
 201         (substitute-command-keys "\\[tm-tar/helpful-message] for keys")
 202         (substitute-command-keys "\\[tm-tar/next-line] to next")
 203         (substitute-command-keys "\\[tm-tar/previous-line] to prev")
 204         (substitute-command-keys "\\[tm-tar/view-file] to view")
 205         (substitute-command-keys "\\[exit-recursive-edit] to quit")
 206      ))
 207
 208 (defun tm-tar/y-or-n-p (prompt)
 209     (prog1
 210         (y-or-n-p prompt)
 211         (message "")
 212      ))
 213
 214 ;;; @@ tar message decoder
 215 ;;
 216
 217 (defun mime/decode-message/tar (beg end cal)
 218     (if (tm-tar/y-or-n-p "Do you want to enter tm-tar mode? ")
 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             (if mouse-button-2
 286                  (progn
 287                     (make-local-variable 'tm:mother-button-dispatcher)
 288                     (setq tm:mother-button-dispatcher 'tm-tar/mouse-button-2)
 289                  ))
 290             (tm-tar/set-properties)
 291             (tm-tar/tar-mode mime::article/preview-buffer)
 292             (kill-buffer tm-tar/view-buffer)
 293             (kill-buffer tm-tar/list-buffer)
 294             (delete-file tm-tar/tar-file-name)
 295          )
 296      ))
 297
 298 ;;; @@ program/buffer coding system
 299 ;;;
 300
 301 (cond ((boundp 'MULE)
 302        (define-program-coding-system tm-tar/view-buffer nil *autoconv*)
 303        )
 304       ((boundp 'NEMACS)
 305        (define-program-kanji-code tm-tar/view-buffer nil 1)
 306        ))
 307
 308 ;;; @@ message types to use tm-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")
 315              ))
 316
 317 (set-atype 'mime/content-decoding-condition
 318            '((type . "application/octet-stream")
 319              (method . mime/decode-message/tar)
 320              (mode . "play") ("type" . "tar+gzip")
 321              ))
 322
 323 (set-atype 'mime/content-decoding-condition
 324            '((type . "application/x-gzip")
 325              (method . mime/decode-message/tar)
 326              (mode . "play") ("type" . "tar")
 327              ))
 328
 329 (set-atype 'mime/content-decoding-condition
 330            '((type . "application/x-tar")
 331              (method . mime/decode-message/tar)
 332              (mode . "play")
 333              ))
 334
 335 ;;; @ end
 336 ;;;
 337
 338 (provide 'tm-tar)
 339
 340 ;;; Local Variables:
 341 ;;; mode: emacs-lisp
 342 ;;; mode: outline-minor
 343 ;;; outline-regexp: ";;; @+\\|(......"
 344 ;;; End: