6002
|
1 ;;; jka-compr.el - reading/writing/loading compressed files.
|
|
2 ;;; Copyright (C) 1993, 1994 Free Software Foundation, Inc.
|
|
3
|
|
4 ;; Author: jka@ece.cmu.edu (Jay K. Adams)
|
|
5 ;; Version: 0.10
|
|
6 ;; Keywords: data
|
|
7
|
|
8 ;;; Commentary:
|
|
9
|
|
10 ;;; This package implements low-level support for reading, writing,
|
|
11 ;;; and loading compressed files. It hooks into the low-level file
|
|
12 ;;; I/O functions (including write-region and insert-file-contents) so
|
|
13 ;;; that they automatically compress or uncompress a file if the file
|
|
14 ;;; appears to need it (based on the extension of the file name).
|
|
15 ;;; Packages like Rmail, Vm, Gnus, and Info should be able to work
|
|
16 ;;; with compressed files without modification.
|
|
17
|
|
18
|
|
19 ;;; INSTRUCTIONS:
|
|
20 ;;;
|
|
21 ;;; To use jka-compr, simply load this package, and edit as usual.
|
|
22 ;;; Its operation should be transparent to the user (except for
|
|
23 ;;; messages appearing when a file is being compressed or
|
|
24 ;;; uncompressed).
|
|
25 ;;;
|
|
26 ;;; The variable, jka-compr-compression-info-list can be used to
|
|
27 ;;; customize jka-compr to work with other compression programs.
|
|
28 ;;; The default value of this variable allows jka-compr to work with
|
|
29 ;;; Unix compress and gzip.
|
|
30 ;;;
|
|
31 ;;; If you are concerned about the stderr output of gzip and other
|
|
32 ;;; compression/decompression programs showing up in your buffers, you
|
|
33 ;;; should set the discard-error flag in the compression-info-list.
|
|
34 ;;; This will cause the stderr of all programs to be discarded.
|
|
35 ;;; However, it also causes emacs to call compression/uncompression
|
|
36 ;;; programs through a shell (which is specified by jka-compr-shell).
|
|
37 ;;; This may be a drag if, on your system, starting up a shell is
|
|
38 ;;; slow.
|
|
39 ;;;
|
|
40 ;;; If you don't want messages about compressing and decompressing
|
|
41 ;;; to show up in the echo area, you can set the compress-name and
|
|
42 ;;; decompress-name fields of the jka-compr-compression-info-list to
|
|
43 ;;; nil.
|
|
44
|
|
45
|
|
46 ;;; APPLICATION NOTES:
|
|
47 ;;;
|
|
48 ;;; rmail, vm, gnus, etc.
|
|
49 ;;; To use compressed mail folders, .newsrc files, etc., you need
|
|
50 ;;; only compress the file. Since jka-compr searches for .gz
|
|
51 ;;; versions of the files it's finding, you need not change
|
|
52 ;;; variables within rmail, gnus, etc.
|
|
53 ;;;
|
|
54 ;;;
|
|
55 ;;; crypt++
|
|
56 ;;; jka-compr can coexist with crpyt++ if you take all the decompression
|
|
57 ;;; entries out of the crypt-encoding-list. Clearly problems will arise if
|
|
58 ;;; you have two programs trying to compress/decompress files. jka-compr
|
|
59 ;;; will not "work with" crypt++ in the following sense: you won't be able to
|
|
60 ;;; decode encrypted compressed files--that is, files that have been
|
|
61 ;;; compressed then encrypted (in that order). Theoretically, crypt++ and
|
|
62 ;;; jka-compr could properly handle a file that has been encrypted then
|
|
63 ;;; compressed, but there is little point in trying to compress an encrypted
|
|
64 ;;; file.
|
|
65 ;;;
|
|
66 ;;;
|
|
67 ;;; tar-mode
|
|
68 ;;; Some people like to use extensions like .trz for compressed tar files.
|
|
69 ;;; To handle these sorts of files, you have to add an entry to
|
|
70 ;;; jka-compr-compression-info-list that looks something like this:
|
|
71 ;;;
|
|
72 ;;; ["\\.trz\\'" "\037\213"
|
|
73 ;;; "zip" "gzip" nil ("-q")
|
|
74 ;;; "unzip" "gzip" nil ("-q" "-d")
|
|
75 ;;; t
|
|
76 ;;; nil]
|
|
77 ;;;
|
|
78 ;;; The last nil in the vector (the "extension" field) prevents jka-compr
|
|
79 ;;; from attempting to add .trz to an ordinary file name when it is looking
|
|
80 ;;; for a compressed version of that file (i.e. don't look for things like
|
|
81 ;;; foobar.c.trz).
|
|
82 ;;;
|
|
83 ;;; Finally, to make tar-mode start up automatically, you have to add an
|
|
84 ;;; entry to auto-mode-alist that looks like this
|
|
85 ;;;
|
|
86 ;;; ("\\.trz\\'" . tar-mode)
|
|
87 ;;;
|
|
88
|
|
89
|
|
90 ;;; ACKNOWLEDGMENTS
|
|
91 ;;;
|
|
92 ;;; jka-compr is a V19 adaptation of jka-compr for V18 of Emacs. Many people
|
|
93 ;;; have made helpful suggestions, reported bugs, and even fixed bugs in
|
|
94 ;;; jka-compr. I recall the following people as being particularly helpful.
|
|
95 ;;;
|
|
96 ;;; Jean-loup Gailly
|
|
97 ;;; David Hughes
|
|
98 ;;; Richard Pieri
|
|
99 ;;; Daniel Quinlan
|
|
100 ;;; Chris P. Ross
|
|
101 ;;; Rick Sladkey
|
|
102 ;;;
|
|
103 ;;; Andy Norman's ange-ftp was the inspiration for the original jka-compr for
|
|
104 ;;; Version 18 of Emacs.
|
|
105 ;;;
|
|
106 ;;; After I had made progress on the original jka-compr for V18, I learned of a
|
|
107 ;;; package written by Kazushi Jam Marukawa, called jam-zcat, that did exactly
|
|
108 ;;; what I was trying to do. I looked over the jam-zcat source code and
|
|
109 ;;; probably got some ideas from it.
|
|
110 ;;;
|
|
111
|
|
112 ;;; Code:
|
|
113
|
|
114 (defvar jka-compr-shell "sh"
|
|
115 "*Shell to be used for calling compression programs.
|
|
116 The value of this variable only matters if you want to discard the
|
|
117 stderr of a compression/decompression program (see the documentation
|
|
118 for jka-compr-compression-info-list).")
|
|
119
|
|
120
|
|
121 (defvar jka-compr-use-shell t)
|
|
122
|
|
123
|
|
124 ;;; I have this defined so that .Z files are assumed to be in unix
|
|
125 ;;; compress format; and .gz files, in gzip format.
|
|
126 (defvar jka-compr-compression-info-list
|
|
127 ;;[regexp
|
|
128 ;; compr-message compr-prog compr-discard compr-args
|
|
129 ;; uncomp-message uncomp-prog uncomp-discard uncomp-args
|
|
130 ;; can-append auto-mode-flag]
|
|
131 '(["\\.Z~?\\'"
|
|
132 "compressing" "compress" ("-c")
|
|
133 "uncompressing" "uncompress" ("-c")
|
|
134 nil t]
|
|
135 ["\\.gz~?\\'"
|
|
136 "zipping" "gzip" ("-c" "-q")
|
|
137 "unzipping" "gzip" ("-c" "-q" "-d")
|
|
138 t t])
|
|
139
|
|
140 "List of vectors that describe available compression techniques.
|
|
141 Each element, which describes a compression technique, is a vector of
|
|
142 the form [regexp magic compress-name compress-program compress-discard-err
|
|
143 compress-args uncompress-name uncompress-program uncompress-discard-err
|
|
144 uncompress-args append-flag extension] where:
|
|
145
|
|
146 regexp is a regexp that matches filenames that are
|
|
147 compressed with this format
|
|
148
|
|
149 compress-program is a program that performs this compression
|
|
150
|
|
151 compress-args is a list of args to pass to the compress program
|
|
152
|
|
153 uncompress-message is the message to issue to the user when this
|
|
154 type of uncompression is taking place (nil
|
|
155 means don't issue any message)
|
|
156
|
|
157 uncompress-program is a program that performs this compression
|
|
158
|
|
159 uncompress-args is a list of args to pass to the uncompress program
|
|
160
|
|
161 append-flag is non-nil if this compression technique can be
|
|
162 appended
|
|
163
|
|
164 auto-mode flag non-nil means strip the regexp from file names
|
|
165 before attempting to set the mode.
|
|
166
|
|
167 Because of the way call-process is defined, discarding the stderr output of
|
|
168 a program adds the overhead of starting a shell each time the program is
|
|
169 invoked.")
|
|
170
|
|
171
|
|
172 ;;; Functions for accessing the return value of jka-get-compression-info
|
|
173 (defun jka-compr-info-regexp (info) (aref info 0))
|
|
174 (defun jka-compr-info-compress-message (info) (aref info 1))
|
|
175 (defun jka-compr-info-compress-program (info) (aref info 2))
|
|
176 (defun jka-compr-info-compress-args (info) (aref info 3))
|
|
177 (defun jka-compr-info-uncompress-message (info) (aref info 4))
|
|
178 (defun jka-compr-info-uncompress-program (info) (aref info 5))
|
|
179 (defun jka-compr-info-uncompress-args (info) (aref info 6))
|
|
180 (defun jka-compr-info-can-append (info) (aref info 7))
|
|
181 (defun jka-compr-info-strip-extension (info) (aref info 8))
|
|
182
|
|
183
|
|
184 (defun jka-compr-get-compression-info (filename)
|
|
185 "Return information about the compression scheme of FILENAME.
|
|
186 The determination as to which compression scheme, if any, to use is
|
|
187 based on the filename itself and jka-compr-compression-info-list."
|
|
188 (catch 'compression-info
|
|
189 (let ((case-fold-search nil))
|
|
190 (mapcar
|
|
191 (function (lambda (x)
|
|
192 (and (string-match (jka-compr-info-regexp x) filename)
|
|
193 (throw 'compression-info x))))
|
|
194 jka-compr-compression-info-list)
|
|
195 nil)))
|
|
196
|
|
197
|
|
198 (put 'compression-error 'error-conditions '(compression-error file-error error))
|
|
199
|
|
200
|
|
201 (defvar jka-compr-acceptable-retval-list '(0 141))
|
|
202
|
|
203
|
|
204 (defun jka-compr-error (prog args infile message &optional errfile)
|
|
205
|
|
206 (let ((errbuf (get-buffer-create " *jka-compr-error*"))
|
|
207 (curbuf (current-buffer)))
|
|
208 (set-buffer errbuf)
|
|
209 (widen) (erase-buffer)
|
|
210 (insert (format "Error while executing \"%s %s < %s\"\n\n"
|
|
211 prog
|
|
212 (mapconcat 'identity args " ")
|
|
213 infile))
|
|
214
|
|
215 (and errfile
|
|
216 (insert-file-contents errfile))
|
|
217
|
|
218 (set-buffer curbuf)
|
|
219 (display-buffer errbuf))
|
|
220
|
|
221 (signal 'compression-error (list "Opening input file" (format "error %s" message) infile)))
|
|
222
|
|
223
|
|
224 (defvar jka-compr-dd-program
|
|
225 "/bin/dd")
|
|
226
|
|
227
|
|
228 (defvar jka-compr-dd-blocksize 512)
|
|
229
|
|
230
|
|
231 (defun jka-compr-partial-uncompress (prog message args infile beg len)
|
|
232 "Call program PROG with ARGS args taking input from INFILE.
|
|
233 Fourth and fifth args, BEG and LEN, specify which part of the output
|
|
234 to discard. All output is discarded unless it comes within LEN chars after
|
|
235 the BEGth char."
|
|
236
|
|
237 (let* ((skip (/ beg jka-compr-dd-blocksize))
|
|
238 (prefix (- beg (* skip jka-compr-dd-blocksize)))
|
|
239 (count (and len (1+ (/ (+ len prefix) jka-compr-dd-blocksize))))
|
|
240 (start (point))
|
|
241 (end (and count (+ start (* count jka-compr-dd-blocksize))))
|
|
242 (err-file (jka-compr-make-temp-name))
|
|
243 (run-string (format "%s %s 2> %s | %s bs=%d skip=%d %s 2> /dev/null"
|
|
244 prog
|
|
245 (mapconcat 'identity args " ")
|
|
246 err-file
|
|
247 jka-compr-dd-program
|
|
248 jka-compr-dd-blocksize
|
|
249 skip
|
|
250 (if count (concat "count=" count) ""))))
|
|
251
|
|
252 (unwind-protect
|
|
253 (or (memq (call-process jka-compr-shell
|
|
254 infile t nil "-c"
|
|
255 run-string)
|
|
256 jka-compr-acceptable-retval-list)
|
|
257
|
|
258 (jka-compr-error prog args infile message err-file))
|
|
259
|
|
260 (jka-compr-delete-temp-file err-file))
|
|
261
|
|
262 (and
|
|
263 end
|
|
264 (delete-region (+ start prefix len) end))
|
|
265
|
|
266 (delete-region start (+ start prefix))))
|
|
267
|
|
268
|
|
269 (defun jka-compr-call-process (prog message infile output temp args)
|
|
270 (if jka-compr-use-shell
|
|
271
|
|
272 (let ((err-file (jka-compr-make-temp-name)))
|
|
273
|
|
274 (unwind-protect
|
|
275
|
|
276 (or (memq
|
|
277 (call-process jka-compr-shell infile
|
|
278 (if (stringp output) nil output)
|
|
279 nil
|
|
280 "-c"
|
|
281 (format "%s %s 2> %s %s"
|
|
282 prog
|
|
283 (mapconcat 'identity args " ")
|
|
284 err-file
|
|
285 (if (stringp output)
|
|
286 (concat "> " output)
|
|
287 "")))
|
|
288 jka-compr-acceptable-retval-list)
|
|
289
|
|
290 (jka-compr-error prog args infile message err-file))
|
|
291
|
|
292 (jka-compr-delete-temp-file err-file)))
|
|
293
|
|
294 (or (zerop
|
|
295 (apply 'call-process
|
|
296 prog
|
|
297 infile
|
|
298 (if (stringp output) temp output)
|
|
299 nil
|
|
300 args))
|
|
301 (jka-compr-error prog args infile message))
|
|
302
|
|
303 (and (stringp output)
|
|
304 (let ((cbuf (current-buffer)))
|
|
305 (set-buffer temp)
|
|
306 (write-region (point-min) (point-max) output)
|
|
307 (erase-buffer)
|
|
308 (set-buffer cbuf)))))
|
|
309
|
|
310
|
|
311 ;;; Support for temp files. Much of this was inspired if not lifted
|
|
312 ;;; from ange-ftp.
|
|
313
|
|
314 (defvar jka-compr-temp-name-template
|
|
315 "/tmp/jka-com"
|
|
316 "Prefix added to all temp files created by jka-compr.
|
|
317 There should be no more than seven characters after the final '/'")
|
|
318
|
|
319 (defvar jka-compr-temp-name-table (make-vector 31 nil))
|
|
320
|
|
321 (defun jka-compr-make-temp-name (&optional local-copy)
|
|
322 "This routine will return the name of a new file."
|
|
323 (let* ((lastchar ?a)
|
|
324 (prevchar ?a)
|
|
325 (template (concat jka-compr-temp-name-template "aa"))
|
|
326 (lastpos (1- (length template)))
|
|
327 (not-done t)
|
|
328 file
|
|
329 entry)
|
|
330
|
|
331 (while not-done
|
|
332 (aset template lastpos lastchar)
|
|
333 (setq file (concat (make-temp-name template) "#"))
|
|
334 (setq entry (intern file jka-compr-temp-name-table))
|
|
335 (if (or (get entry 'active)
|
|
336 (file-exists-p file))
|
|
337
|
|
338 (progn
|
|
339 (setq lastchar (1+ lastchar))
|
|
340 (if (> lastchar ?z)
|
|
341 (progn
|
|
342 (setq prevchar (1+ prevchar))
|
|
343 (setq lastchar ?a)
|
|
344 (if (> prevchar ?z)
|
|
345 (error "Can't allocate temp file.")
|
|
346 (aset template (1- lastpos) prevchar)))))
|
|
347
|
|
348 (put entry 'active (not local-copy))
|
|
349 (setq not-done nil)))
|
|
350
|
|
351 file))
|
|
352
|
|
353
|
|
354 (defun jka-compr-delete-temp-file (temp)
|
|
355
|
|
356 (put (intern temp jka-compr-temp-name-table)
|
|
357 'active nil)
|
|
358
|
|
359 (condition-case ()
|
|
360 (delete-file temp)
|
|
361 (error nil)))
|
|
362
|
|
363
|
|
364 (defun jka-compr-write-region (start end file &optional append visit)
|
|
365 "Documented as original."
|
|
366 (interactive "r\nFWrite region to file: ")
|
|
367
|
|
368 (let* ((filename (expand-file-name file))
|
|
369 (visit-file (if (stringp visit) (expand-file-name visit) filename))
|
|
370 (info (jka-compr-get-compression-info visit-file)))
|
|
371
|
|
372 (if info
|
|
373
|
|
374 (let ((can-append (jka-compr-info-can-append info))
|
|
375 (compress-program (jka-compr-info-compress-program info))
|
|
376 (compress-message (jka-compr-info-compress-message info))
|
|
377 (uncompress-program (jka-compr-info-uncompress-program info))
|
|
378 (uncompress-message (jka-compr-info-uncompress-message info))
|
|
379 (compress-args (jka-compr-info-compress-args info))
|
|
380 (uncompress-args (jka-compr-info-uncompress-args info))
|
|
381 (temp-file (jka-compr-make-temp-name))
|
|
382 (base-name (file-name-nondirectory visit-file))
|
|
383 cbuf temp-buffer)
|
|
384
|
|
385 (setq cbuf (current-buffer)
|
|
386 temp-buffer (get-buffer-create " *jka-compr-temp*"))
|
|
387 (set-buffer temp-buffer)
|
|
388 (widen) (erase-buffer)
|
|
389 (set-buffer cbuf)
|
|
390
|
|
391 (and append
|
|
392 (not can-append)
|
|
393 (file-exists-p filename)
|
|
394 (let* ((local-copy (file-local-copy filename))
|
|
395 (local-file (or local-copy filename)))
|
|
396
|
|
397 (unwind-protect
|
|
398
|
|
399 (progn
|
|
400
|
|
401 (and
|
|
402 uncompress-message
|
|
403 (message "%s %s..." uncompress-message base-name))
|
|
404
|
|
405 (jka-compr-call-process uncompress-program
|
|
406 (concat uncompress-message
|
|
407 " " base-name)
|
|
408 local-file
|
|
409 temp-file
|
|
410 temp-buffer
|
|
411 uncompress-args)
|
|
412 (and
|
|
413 uncompress-message
|
|
414 (message "%s %s...done" uncompress-message base-name)))
|
|
415
|
|
416 (and
|
|
417 local-copy
|
|
418 (file-exists-p local-copy)
|
|
419 (delete-file local-copy)))))
|
|
420
|
|
421 (and
|
|
422 compress-message
|
|
423 (message "%s %s..." compress-message base-name))
|
|
424
|
|
425 (write-region start end temp-file t 'dont)
|
|
426
|
|
427 (jka-compr-call-process compress-program
|
|
428 (concat compress-message
|
|
429 " " base-name)
|
|
430 temp-file
|
|
431 temp-buffer
|
|
432 nil
|
|
433 compress-args)
|
|
434
|
|
435 (set-buffer temp-buffer)
|
|
436 (write-region (point-min) (point-max)
|
|
437 filename (and append can-append) 'dont)
|
|
438 (erase-buffer)
|
|
439 (set-buffer cbuf)
|
|
440
|
|
441 (jka-compr-delete-temp-file temp-file)
|
|
442
|
|
443 (and
|
|
444 compress-message
|
|
445 (message "%s %s...done" compress-message base-name))
|
|
446
|
|
447 (cond
|
|
448 ((eq visit t)
|
|
449 (setq buffer-file-name filename)
|
|
450 (set-visited-file-modtime))
|
|
451 ((stringp visit)
|
|
452 (setq buffer-file-name visit)
|
|
453 (let ((buffer-file-name filename))
|
|
454 (set-visited-file-modtime))))
|
|
455
|
|
456 (and (or (eq visit t)
|
|
457 (eq visit nil)
|
|
458 (stringp visit))
|
|
459 (message "Wrote %s" visit-file))
|
|
460
|
|
461 nil)
|
|
462
|
|
463 (write-region start end filename append visit))))
|
|
464
|
|
465
|
|
466 (defun jka-compr-insert-file-contents (file &optional visit beg end)
|
|
467 "Documented as original."
|
|
468
|
|
469 (barf-if-buffer-read-only)
|
|
470
|
|
471 (and (or beg end)
|
|
472 visit
|
|
473 (error "Attempt to visit less than an entire file"))
|
|
474
|
|
475 (let* ((filename (expand-file-name file))
|
|
476 (info (jka-compr-get-compression-info filename)))
|
|
477
|
|
478 (if info
|
|
479
|
|
480 (let ((uncompress-message (jka-compr-info-uncompress-message info))
|
|
481 (uncompress-program (jka-compr-info-uncompress-program info))
|
|
482 (uncompress-args (jka-compr-info-uncompress-args info))
|
|
483 (base-name (file-name-nondirectory filename))
|
|
484 (notfound nil)
|
|
485 (local-copy (file-local-copy filename))
|
|
486 local-file
|
|
487 size start)
|
|
488
|
|
489 (setq local-file (or local-copy filename))
|
|
490
|
|
491 (and
|
|
492 visit
|
|
493 (setq buffer-file-name filename))
|
|
494
|
|
495 (unwind-protect ; to make sure local-copy gets deleted
|
|
496
|
|
497 (progn
|
|
498
|
|
499 (and
|
|
500 uncompress-message
|
|
501 (message "%s %s..." uncompress-message base-name))
|
|
502
|
|
503 (condition-case error-code
|
|
504
|
|
505 (progn
|
|
506 (setq start (point))
|
|
507 (if (or beg end)
|
|
508 (jka-compr-partial-uncompress uncompress-program
|
|
509 (concat uncompress-message
|
|
510 " " base-name)
|
|
511 uncompress-args
|
|
512 local-file
|
|
513 (or beg 0)
|
|
514 (if (and beg end)
|
|
515 (- end beg)
|
|
516 end))
|
|
517 (jka-compr-call-process uncompress-program
|
|
518 (concat uncompress-message
|
|
519 " " base-name)
|
|
520 local-file
|
|
521 t
|
|
522 nil
|
|
523 uncompress-args))
|
|
524 (setq size (- (point) start))
|
|
525 (goto-char start))
|
|
526
|
|
527
|
|
528 (error
|
|
529 (if (and (eq (car error-code) 'file-error)
|
|
530 (eq (nth 3 error-code) local-file))
|
|
531 (if visit
|
|
532 (setq notfound error-code)
|
|
533 (signal 'file-error
|
|
534 (cons "Opening input file"
|
|
535 (nthcdr 2 error-code))))
|
|
536 (signal (car error-code) (cdr error-code))))))
|
|
537
|
|
538 (and
|
|
539 local-copy
|
|
540 (file-exists-p local-copy)
|
|
541 (delete-file local-copy)))
|
|
542
|
|
543 (and
|
|
544 visit
|
|
545 (progn
|
|
546 (setq buffer-file-name filename)
|
|
547 (set-visited-file-modtime)))
|
|
548
|
|
549 (and
|
|
550 uncompress-message
|
|
551 (message "%s %s...done" uncompress-message base-name))
|
|
552
|
|
553 (and
|
|
554 visit
|
|
555 notfound
|
|
556 (signal 'file-error
|
|
557 (cons "Opening input file" (nth 2 notfound))))
|
|
558
|
|
559 (list filename size))
|
|
560
|
|
561 (insert-file-contents file visit beg end))))
|
|
562
|
|
563
|
|
564 (defun jka-compr-file-local-copy (file)
|
|
565 "Documented as original."
|
|
566
|
|
567 (let* ((filename (expand-file-name file))
|
|
568 (info (jka-compr-get-compression-info filename)))
|
|
569
|
|
570 (if info
|
|
571
|
|
572 (let ((uncompress-message (jka-compr-info-uncompress-message info))
|
|
573 (uncompress-program (jka-compr-info-uncompress-program info))
|
|
574 (uncompress-args (jka-compr-info-uncompress-args info))
|
|
575 (base-name (file-name-nondirectory filename))
|
|
576 (local-copy (file-local-copy filename))
|
|
577 (temp-file (jka-compr-make-temp-name t))
|
|
578 (temp-buffer (get-buffer-create " *jka-compr-temp*"))
|
|
579 (notfound nil)
|
|
580 (cbuf (current-buffer))
|
|
581 local-file)
|
|
582
|
|
583 (setq local-file (or local-copy filename))
|
|
584
|
|
585 (unwind-protect
|
|
586
|
|
587 (progn
|
|
588
|
|
589 (and
|
|
590 uncompress-message
|
|
591 (message "%s %s..." uncompress-message base-name))
|
|
592
|
|
593 (set-buffer temp-buffer)
|
|
594
|
|
595 (jka-compr-call-process uncompress-program
|
|
596 (concat uncompress-message
|
|
597 " " base-name)
|
|
598 local-file
|
|
599 t
|
|
600 nil
|
|
601 uncompress-args)
|
|
602
|
|
603 (and
|
|
604 uncompress-message
|
|
605 (message "%s %s...done" uncompress-message base-name))
|
|
606
|
|
607 (write-region
|
|
608 (point-min) (point-max) temp-file nil 'dont))
|
|
609
|
|
610 (and
|
|
611 local-copy
|
|
612 (file-exists-p local-copy)
|
|
613 (delete-file local-copy))
|
|
614
|
|
615 (set-buffer cbuf)
|
|
616 (kill-buffer temp-buffer))
|
|
617
|
|
618 temp-file)
|
|
619
|
|
620 (file-local-copy filename))))
|
|
621
|
|
622
|
|
623 ;;; Support for loading compressed files.
|
|
624 (defun jka-compr-load (file &optional noerror nomessage nosuffix)
|
|
625 "Documented as original."
|
|
626
|
|
627 (let* ((local-copy (jka-compr-file-local-copy file))
|
|
628 (load-file (or local-copy file)))
|
|
629
|
|
630 (unwind-protect
|
|
631
|
|
632 (progn
|
|
633
|
|
634 (setq file-name-handler-alist
|
|
635 (cons jka-compr-file-name-handler-entry
|
|
636 file-name-handler-alist))
|
|
637
|
|
638 (or nomessage
|
|
639 (message "Loading %s..." file))
|
|
640
|
|
641 (load load-file noerror t t)
|
|
642
|
|
643 (or nomessage
|
|
644 (message "Loading %s...done." file)))
|
|
645
|
|
646 (setq file-name-handler-alist
|
|
647 (delq jka-compr-file-name-handler-entry
|
|
648 file-name-handler-alist))
|
|
649
|
|
650 (jka-compr-delete-temp-file local-copy))
|
|
651
|
|
652 t))
|
|
653
|
|
654
|
|
655 (defvar jka-compr-file-name-handler-entry
|
|
656 nil
|
|
657 "The entry in file-name-handler-alist used by the jka-compr I/O functions.")
|
|
658
|
|
659
|
|
660 (defun jka-compr-handler (operation &rest args)
|
|
661
|
|
662 (let ((jka-op (intern-soft (symbol-name operation) jka-compr-op-table)))
|
|
663
|
|
664 (unwind-protect
|
|
665 (progn
|
|
666 (setq file-name-handler-alist
|
|
667 (delq jka-compr-file-name-handler-entry
|
|
668 file-name-handler-alist))
|
|
669 (if jka-op
|
|
670 (apply jka-op args)
|
|
671 (apply operation args)))
|
|
672
|
|
673 (setq file-name-handler-alist
|
|
674 (cons jka-compr-file-name-handler-entry
|
|
675 file-name-handler-alist)))))
|
|
676
|
|
677
|
|
678 (defvar jka-compr-op-table
|
|
679 (make-vector 127 0)
|
|
680 "Hash table of operations supported by jka-compr")
|
|
681
|
|
682
|
|
683 (defun jka-compr-intern-operation (op)
|
|
684 (let ((opsym (intern (symbol-name op) jka-compr-op-table))
|
|
685 (jka-fn (intern (concat "jka-compr-" (symbol-name op)))))
|
|
686 (fset opsym jka-fn)))
|
|
687
|
|
688
|
|
689 (defvar jka-compr-operation-list
|
|
690 '(
|
|
691 write-region
|
|
692 insert-file-contents
|
|
693 file-local-copy
|
|
694 load
|
|
695 )
|
|
696 "List of file operations implemented by jka-compr.")
|
|
697
|
|
698
|
|
699 (mapcar
|
|
700 (function
|
|
701 (lambda (fn)
|
|
702 (jka-compr-intern-operation fn)))
|
|
703 jka-compr-operation-list)
|
|
704
|
|
705
|
|
706 (defun toggle-auto-compression (arg)
|
|
707 "Toggle automatic file compression and decompression.
|
|
708 With prefix argument ARG, turn auto compression on if positive, else off.
|
|
709 Returns the new status of auto compression (non-nil means on)."
|
|
710 (interactive "P")
|
|
711 (let* ((installed (jka-compr-installed-p))
|
|
712 (flag (if (null arg)
|
|
713 (not installed)
|
|
714 (or (eq arg t) (listp arg) (and (integerp arg) (> arg 0))))))
|
|
715
|
|
716 (cond
|
|
717 ((and flag installed) t) ; already installed
|
|
718
|
|
719 ((and (not flag) (not installed)) nil) ; already not installed
|
|
720
|
|
721 (flag
|
|
722 (jka-compr-install))
|
|
723
|
|
724 (t
|
|
725 (jka-compr-uninstall)))
|
|
726
|
|
727
|
|
728 (and (interactive-p)
|
|
729 (if flag
|
|
730 (message "Automatic file (de)compression is now ON.")
|
|
731 (message "Automatic file (de)compression is now OFF.")))
|
|
732
|
|
733 flag))
|
|
734
|
|
735
|
|
736 (defun jka-compr-build-file-regexp ()
|
|
737 (concat
|
|
738 "\\("
|
|
739 (mapconcat
|
|
740 'jka-compr-info-regexp
|
|
741 jka-compr-compression-info-list
|
|
742 "\\)\\|\\(")
|
|
743 "\\)"))
|
|
744
|
|
745
|
|
746 (defun jka-compr-install ()
|
|
747 "Install jka-compr.
|
|
748 Appropriate entries are added to file-name-handler-alist and auto-mode-alist."
|
|
749
|
|
750 (setq jka-compr-file-name-handler-entry
|
|
751 (cons (jka-compr-build-file-regexp) 'jka-compr-handler))
|
|
752
|
|
753 (setq file-name-handler-alist (cons jka-compr-file-name-handler-entry
|
|
754 file-name-handler-alist))
|
|
755
|
|
756 (mapcar
|
|
757 (function (lambda (x)
|
|
758 (and
|
|
759 (jka-compr-info-strip-extension x)
|
|
760 (setq auto-mode-alist (cons (list (jka-compr-info-regexp x)
|
|
761 nil 'jka-compr)
|
|
762 auto-mode-alist)))))
|
|
763
|
|
764 jka-compr-compression-info-list))
|
|
765
|
|
766
|
|
767 (defun jka-compr-uninstall ()
|
|
768 "Uninstall jka-compr.
|
|
769 Entries in file-name-handler-alist and auto-mode-alist that were created by
|
|
770 jka-compr-installed are removed."
|
|
771
|
|
772 (let* ((fnha (cons nil file-name-handler-alist))
|
|
773 (last fnha))
|
|
774
|
|
775 (while (cdr last)
|
|
776 (if (eq (cdr (car (cdr last))) 'jka-compr-handler)
|
|
777 (setcdr last (cdr (cdr last)))
|
|
778 (setq last (cdr last))))
|
|
779
|
|
780 (setq file-name-handler-alist (cdr fnha)))
|
|
781
|
|
782 (let* ((ama (cons nil auto-mode-alist))
|
|
783 (last ama)
|
|
784 entry)
|
|
785
|
|
786 (while (cdr last)
|
|
787 (setq entry (car (cdr last)))
|
|
788 (if (and (consp (cdr entry))
|
|
789 (eq (nth 2 entry) 'jka-compr))
|
|
790 (setcdr last (cdr (cdr last)))
|
|
791 (setq last (cdr last))))
|
|
792
|
|
793 (setq auto-mode-alist (cdr ama))))
|
|
794
|
|
795
|
|
796 (defun jka-compr-installed-p ()
|
|
797 "Return non-nil if jka-compr is installed.
|
|
798 The return value is the entry in file-name-handler-alist for jka-compr."
|
|
799
|
|
800 (let ((fnha file-name-handler-alist)
|
|
801 (installed nil))
|
|
802
|
|
803 (while (and fnha (not installed))
|
|
804 (and (eq (cdr (car fnha)) 'jka-compr-handler)
|
|
805 (setq installed (car fnha)))
|
|
806 (setq fnha (cdr fnha)))
|
|
807
|
|
808 installed))
|
|
809
|
|
810
|
|
811 ;;; Add the file I/O hook if it does not already exist.
|
|
812 ;;; Make sure that jka-compr-file-name-handler-entry is eq to the
|
|
813 ;;; entry for jka-compr in file-name-handler-alist.
|
|
814 (and (jka-compr-installed-p)
|
|
815 (jka-compr-uninstall))
|
|
816
|
|
817 (jka-compr-install)
|
|
818
|
|
819
|
|
820 (provide 'jka-compr)
|
|
821
|
|
822 ;; jka-compr.el ends here.
|