Mercurial > hg > xemacs-beta

comparison lisp/tm/tm-tar.el @ 4:b82b59fe008d r19-15b3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b3
author cvs
date Mon, 13 Aug 2007 08:46:56 +0200
parents
children 4b173ad71786
comparison
equal deleted inserted replaced
3:30df88044ec6 4:b82b59fe008d
1 ;;;
2 ;;; $Id: tm-tar.el,v 1.1.1.1 1996/12/18 03:55:32 steve 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: