1 ;;; jka-compr.el - reading/writing/loading compressed files.
2 ;;; Copyright (C) 1993, 1994 Free Software Foundation, Inc.
4 ;; Author: jka@ece.cmu.edu (Jay K. Adams)
9 ;;; This package implements low-level support for reading, writing,
10 ;;; and loading compressed files. It hooks into the low-level file
11 ;;; I/O functions (including write-region and insert-file-contents) so
12 ;;; that they automatically compress or uncompress a file if the file
13 ;;; appears to need it (based on the extension of the file name).
14 ;;; Packages like Rmail, VM, GNUS, and Info should be able to work
15 ;;; with compressed files without modification.
20 ;;; To use jka-compr, simply load this package, and edit as usual.
21 ;;; Its operation should be transparent to the user (except for
22 ;;; messages appearing when a file is being compressed or
25 ;;; The variable, jka-compr-compression-info-list can be used to
26 ;;; customize jka-compr to work with other compression programs.
27 ;;; The default value of this variable allows jka-compr to work with
28 ;;; Unix compress and gzip.
30 ;;; If you are concerned about the stderr output of gzip and other
31 ;;; compression/decompression programs showing up in your buffers, you
32 ;;; should set the discard-error flag in the compression-info-list.
33 ;;; This will cause the stderr of all programs to be discarded.
34 ;;; However, it also causes emacs to call compression/uncompression
35 ;;; programs through a shell (which is specified by jka-compr-shell).
36 ;;; This may be a drag if, on your system, starting up a shell is
39 ;;; If you don't want messages about compressing and decompressing
40 ;;; to show up in the echo area, you can set the compress-name and
41 ;;; decompress-name fields of the jka-compr-compression-info-list to
45 ;;; APPLICATION NOTES:
48 ;;; jka-compr can coexist with crpyt++ if you take all the decompression
49 ;;; entries out of the crypt-encoding-list. Clearly problems will arise if
50 ;;; you have two programs trying to compress/decompress files. jka-compr
51 ;;; will not "work with" crypt++ in the following sense: you won't be able to
52 ;;; decode encrypted compressed files--that is, files that have been
53 ;;; compressed then encrypted (in that order). Theoretically, crypt++ and
54 ;;; jka-compr could properly handle a file that has been encrypted then
55 ;;; compressed, but there is little point in trying to compress an encrypted
62 ;;; jka-compr is a V19 adaptation of jka-compr for V18 of Emacs. Many people
63 ;;; have made helpful suggestions, reported bugs, and even fixed bugs in
64 ;;; jka-compr. I recall the following people as being particularly helpful.
73 ;;; Andy Norman's ange-ftp was the inspiration for the original jka-compr for
74 ;;; Version 18 of Emacs.
76 ;;; After I had made progress on the original jka-compr for V18, I learned of a
77 ;;; package written by Kazushi Jam Marukawa, called jam-zcat, that did exactly
78 ;;; what I was trying to do. I looked over the jam-zcat source code and
79 ;;; probably got some ideas from it.
84 (defvar jka-compr-shell
"sh"
85 "*Shell to be used for calling compression programs.
86 The value of this variable only matters if you want to discard the
87 stderr of a compression/decompression program (see the documentation
88 for `jka-compr-compression-info-list').")
91 (defvar jka-compr-use-shell t
)
94 ;;; I have this defined so that .Z files are assumed to be in unix
95 ;;; compress format; and .gz files, in gzip format.
96 (defvar jka-compr-compression-info-list
98 ;; compr-message compr-prog compr-args
99 ;; uncomp-message uncomp-prog uncomp-args
100 ;; can-append auto-mode-flag]
101 '(["\\.Z\\(~\\|\\.~[0-9]+~\\)?\\'"
102 "compressing" "compress" ("-c")
103 "uncompressing" "uncompress" ("-c")
106 "zipping" "gzip" ("-c" "-q")
107 "unzipping" "gzip" ("-c" "-q" "-d")
109 ["\\.gz\\(~\\|\\.~[0-9]+~\\)?\\'"
110 "zipping" "gzip" ("-c" "-q")
111 "unzipping" "gzip" ("-c" "-q" "-d")
114 "List of vectors that describe available compression techniques.
115 Each element, which describes a compression technique, is a vector of
116 the form [REGEXP COMPRESS-MSG COMPRESS-PROGRAM COMPRESS-ARGS
117 UNCOMPRESS-MSG UNCOMPRESS-PROGRAM UNCOMPRESS-ARGS
118 APPEND-FLAG EXTENSION], where:
120 regexp is a regexp that matches filenames that are
121 compressed with this format
123 compress-msg is the message to issue to the user when doing this
124 type of compression (nil means no message)
126 compress-program is a program that performs this compression
128 compress-args is a list of args to pass to the compress program
130 uncompress-msg is the message to issue to the user when doing this
131 type of uncompression (nil means no message)
133 uncompress-program is a program that performs this compression
135 uncompress-args is a list of args to pass to the uncompress program
137 append-flag is non-nil if this compression technique can be
140 auto-mode flag non-nil means strip the regexp from file names
141 before attempting to set the mode.
143 Because of the way `call-process' is defined, discarding the stderr output of
144 a program adds the overhead of starting a shell each time the program is
147 (defvar jka-compr-mode-alist-additions
148 (list (cons "\\.tgz\\'" 'tar-mode
))
149 "A list of pairs to add to auto-mode-alist when jka-compr is installed.")
151 (defvar jka-compr-file-name-handler-entry
153 "The entry in `file-name-handler-alist' used by the jka-compr I/O functions.")
155 ;;; Functions for accessing the return value of jka-get-compression-info
156 (defun jka-compr-info-regexp (info) (aref info
0))
157 (defun jka-compr-info-compress-message (info) (aref info
1))
158 (defun jka-compr-info-compress-program (info) (aref info
2))
159 (defun jka-compr-info-compress-args (info) (aref info
3))
160 (defun jka-compr-info-uncompress-message (info) (aref info
4))
161 (defun jka-compr-info-uncompress-program (info) (aref info
5))
162 (defun jka-compr-info-uncompress-args (info) (aref info
6))
163 (defun jka-compr-info-can-append (info) (aref info
7))
164 (defun jka-compr-info-strip-extension (info) (aref info
8))
167 (defun jka-compr-get-compression-info (filename)
168 "Return information about the compression scheme of FILENAME.
169 The determination as to which compression scheme, if any, to use is
170 based on the filename itself and `jka-compr-compression-info-list'."
171 (catch 'compression-info
172 (let ((case-fold-search nil
))
174 (function (lambda (x)
175 (and (string-match (jka-compr-info-regexp x
) filename
)
176 (throw 'compression-info x
))))
177 jka-compr-compression-info-list
)
181 (put 'compression-error
'error-conditions
'(compression-error file-error error
))
184 (defvar jka-compr-acceptable-retval-list
'(0 141))
187 (defun jka-compr-error (prog args infile message
&optional errfile
)
189 (let ((errbuf (get-buffer-create " *jka-compr-error*"))
190 (curbuf (current-buffer)))
192 (widen) (erase-buffer)
193 (insert (format "Error while executing \"%s %s < %s\"\n\n"
195 (mapconcat 'identity args
" ")
199 (insert-file-contents errfile
))
202 (display-buffer errbuf
))
204 (signal 'compression-error
(list "Opening input file" (format "error %s" message
) infile
)))
207 (defvar jka-compr-dd-program
211 (defvar jka-compr-dd-blocksize
256)
214 (defun jka-compr-partial-uncompress (prog message args infile beg len
)
215 "Call program PROG with ARGS args taking input from INFILE.
216 Fourth and fifth args, BEG and LEN, specify which part of the output
217 to keep: LEN chars starting BEG chars from the beginning."
218 (let* ((skip (/ beg jka-compr-dd-blocksize
))
219 (prefix (- beg
(* skip jka-compr-dd-blocksize
)))
220 (count (and len
(1+ (/ (+ len prefix
) jka-compr-dd-blocksize
))))
222 (err-file (jka-compr-make-temp-name))
223 (run-string (format "%s %s 2> %s | %s bs=%d skip=%d %s 2> /dev/null"
225 (mapconcat 'identity args
" ")
228 jka-compr-dd-blocksize
230 ;; dd seems to be unreliable about
231 ;; providing the last block. So, always
232 ;; read one more than you think you need.
233 (if count
(concat "count=" (1+ count
)) ""))))
236 (or (memq (call-process jka-compr-shell
239 jka-compr-acceptable-retval-list
)
241 (jka-compr-error prog args infile message err-file
))
243 (jka-compr-delete-temp-file err-file
))
245 ;; Delete the stuff after what we want, if there is any.
248 (< (+ start prefix len
) (point))
249 (delete-region (+ start prefix len
) (point)))
251 ;; Delete the stuff before what we want.
252 (delete-region start
(+ start prefix
))))
255 (defun jka-compr-call-process (prog message infile output temp args
)
256 (if jka-compr-use-shell
258 (let ((err-file (jka-compr-make-temp-name)))
263 (call-process jka-compr-shell infile
264 (if (stringp output
) nil output
)
267 (format "%s %s 2> %s %s"
269 (mapconcat 'identity args
" ")
274 jka-compr-acceptable-retval-list
)
276 (jka-compr-error prog args infile message err-file
))
278 (jka-compr-delete-temp-file err-file
)))
284 (if (stringp output
) temp output
)
287 (jka-compr-error prog args infile message
))
289 (and (stringp output
)
290 (let ((cbuf (current-buffer)))
292 (write-region (point-min) (point-max) output
)
294 (set-buffer cbuf
)))))
297 ;;; Support for temp files. Much of this was inspired if not lifted
300 (defvar jka-compr-temp-name-template
302 "Prefix added to all temp files created by jka-compr.
303 There should be no more than seven characters after the final `/'")
305 (defvar jka-compr-temp-name-table
(make-vector 31 nil
))
307 (defun jka-compr-make-temp-name (&optional local-copy
)
308 "This routine will return the name of a new file."
311 (template (concat jka-compr-temp-name-template
"aa"))
312 (lastpos (1- (length template
)))
318 (aset template lastpos lastchar
)
319 (setq file
(concat (make-temp-name template
) "#"))
320 (setq entry
(intern file jka-compr-temp-name-table
))
321 (if (or (get entry
'active
)
322 (file-exists-p file
))
325 (setq lastchar
(1+ lastchar
))
328 (setq prevchar
(1+ prevchar
))
331 (error "Can't allocate temp file.")
332 (aset template
(1- lastpos
) prevchar
)))))
334 (put entry
'active
(not local-copy
))
335 (setq not-done nil
)))
340 (defun jka-compr-delete-temp-file (temp)
342 (put (intern temp jka-compr-temp-name-table
)
350 (defun jka-compr-write-region (start end file
&optional append visit
)
351 (let* ((filename (expand-file-name file
))
352 (visit-file (if (stringp visit
) (expand-file-name visit
) filename
))
353 (info (jka-compr-get-compression-info visit-file
)))
357 (let ((can-append (jka-compr-info-can-append info
))
358 (compress-program (jka-compr-info-compress-program info
))
359 (compress-message (jka-compr-info-compress-message info
))
360 (uncompress-program (jka-compr-info-uncompress-program info
))
361 (uncompress-message (jka-compr-info-uncompress-message info
))
362 (compress-args (jka-compr-info-compress-args info
))
363 (uncompress-args (jka-compr-info-uncompress-args info
))
364 (temp-file (jka-compr-make-temp-name))
365 (base-name (file-name-nondirectory visit-file
))
368 (setq cbuf
(current-buffer)
369 temp-buffer
(get-buffer-create " *jka-compr-temp*"))
370 (set-buffer temp-buffer
)
371 (widen) (erase-buffer)
376 (file-exists-p filename
)
377 (let* ((local-copy (file-local-copy filename
))
378 (local-file (or local-copy filename
)))
386 (message "%s %s..." uncompress-message base-name
))
388 (jka-compr-call-process uncompress-program
389 (concat uncompress-message
397 (message "%s %s...done" uncompress-message base-name
)))
401 (file-exists-p local-copy
)
402 (delete-file local-copy
)))))
406 (message "%s %s..." compress-message base-name
))
408 (jka-compr-run-real-handler 'write-region
409 (list start end temp-file t
'dont
))
411 (jka-compr-call-process compress-program
412 (concat compress-message
419 (set-buffer temp-buffer
)
420 (jka-compr-run-real-handler 'write-region
421 (list (point-min) (point-max)
423 (and append can-append
) 'dont
))
427 (jka-compr-delete-temp-file temp-file
)
431 (message "%s %s...done" compress-message base-name
))
435 (setq buffer-file-name filename
)
436 (set-visited-file-modtime))
438 (setq buffer-file-name visit
)
439 (let ((buffer-file-name filename
))
440 (set-visited-file-modtime))))
442 (and (or (eq visit t
)
445 (message "Wrote %s" visit-file
))
449 (jka-compr-run-real-handler 'write-region
450 (list start end filename append visit
)))))
453 (defun jka-compr-insert-file-contents (file &optional visit beg end replace
)
454 (barf-if-buffer-read-only)
458 (error "Attempt to visit less than an entire file"))
460 (let* ((filename (expand-file-name file
))
461 (info (jka-compr-get-compression-info filename
)))
465 (let ((uncompress-message (jka-compr-info-uncompress-message info
))
466 (uncompress-program (jka-compr-info-uncompress-program info
))
467 (uncompress-args (jka-compr-info-uncompress-args info
))
468 (base-name (file-name-nondirectory filename
))
471 (jka-compr-run-real-handler 'file-local-copy
(list filename
)))
475 (setq local-file
(or local-copy filename
))
479 (setq buffer-file-name filename
))
481 (unwind-protect ; to make sure local-copy gets deleted
487 (message "%s %s..." uncompress-message base-name
))
489 (condition-case error-code
493 (goto-char (point-min)))
496 (jka-compr-partial-uncompress uncompress-program
497 (concat uncompress-message
505 (jka-compr-call-process uncompress-program
506 (concat uncompress-message
512 (setq size
(- (point) start
))
514 (let* ((del-beg (point))
515 (del-end (+ del-beg size
)))
516 (delete-region del-beg
517 (min del-end
(point-max)))))
520 (if (and (eq (car error-code
) 'file-error
)
521 (eq (nth 3 error-code
) local-file
))
523 (setq notfound error-code
)
525 (cons "Opening input file"
526 (nthcdr 2 error-code
))))
527 (signal (car error-code
) (cdr error-code
))))))
531 (file-exists-p local-copy
)
532 (delete-file local-copy
)))
538 (setq buffer-file-name filename
)
539 (set-visited-file-modtime)))
543 (message "%s %s...done" uncompress-message base-name
))
549 (cons "Opening input file" (nth 2 notfound
))))
551 ;; Run the functions that insert-file-contents would.
552 (let ((p after-insert-file-functions
)
555 (setq insval
(funcall (car p
) size
))
558 (or (integerp insval
)
559 (signal 'wrong-type-argument
560 (list 'integerp insval
)))
564 (list filename size
))
566 (jka-compr-run-real-handler 'insert-file-contents
567 (list file visit beg end replace
)))))
570 (defun jka-compr-file-local-copy (file)
571 (let* ((filename (expand-file-name file
))
572 (info (jka-compr-get-compression-info filename
)))
576 (let ((uncompress-message (jka-compr-info-uncompress-message info
))
577 (uncompress-program (jka-compr-info-uncompress-program info
))
578 (uncompress-args (jka-compr-info-uncompress-args info
))
579 (base-name (file-name-nondirectory filename
))
581 (jka-compr-run-real-handler 'file-local-copy
(list filename
)))
582 (temp-file (jka-compr-make-temp-name t
))
583 (temp-buffer (get-buffer-create " *jka-compr-temp*"))
585 (cbuf (current-buffer))
588 (setq local-file
(or local-copy filename
))
596 (message "%s %s..." uncompress-message base-name
))
598 (set-buffer temp-buffer
)
600 (jka-compr-call-process uncompress-program
601 (concat uncompress-message
610 (message "%s %s...done" uncompress-message base-name
))
613 (point-min) (point-max) temp-file nil
'dont
))
617 (file-exists-p local-copy
)
618 (delete-file local-copy
))
621 (kill-buffer temp-buffer
))
625 (jka-compr-run-real-handler 'file-local-copy
(list filename
)))))
628 ;;; Support for loading compressed files.
629 (defun jka-compr-load (file &optional noerror nomessage nosuffix
)
630 "Documented as original."
632 (let* ((local-copy (jka-compr-file-local-copy file
))
633 (load-file (or local-copy file
)))
637 (let (inhibit-file-name-operation
638 inhibit-file-name-handlers
)
640 (message "Loading %s..." file
))
642 (load load-file noerror t t
)
645 (message "Loading %s...done." file
)))
647 (jka-compr-delete-temp-file local-copy
))
651 (put 'write-region
'jka-compr
'jka-compr-write-region
)
652 (put 'insert-file-contents
'jka-compr
'jka-compr-insert-file-contents
)
653 (put 'file-local-copy
'jka-compr
'jka-compr-file-local-copy
)
654 (put 'load
'jka-compr
'jka-compr-load
)
656 (defun jka-compr-handler (operation &rest args
)
658 (let ((jka-op (get operation
'jka-compr
)))
661 (jka-compr-run-real-handler operation args
)))))
663 ;; If we are given an operation that we don't handle,
664 ;; call the Emacs primitive for that operation,
665 ;; and manipulate the inhibit variables
666 ;; to prevent the primitive from calling our handler again.
667 (defun jka-compr-run-real-handler (operation args
)
668 (let ((inhibit-file-name-handlers
669 (cons 'jka-compr-handler
670 (and (eq inhibit-file-name-operation operation
)
671 inhibit-file-name-handlers
)))
672 (inhibit-file-name-operation operation
))
673 (apply operation args
)))
675 (defun toggle-auto-compression (arg)
676 "Toggle automatic file compression and decompression.
677 With prefix argument ARG, turn auto compression on if positive, else off.
678 Returns the new status of auto compression (non-nil means on)."
680 (let* ((installed (jka-compr-installed-p))
683 (or (eq arg t
) (listp arg
) (and (integerp arg
) (> arg
0))))))
686 ((and flag installed
) t
) ; already installed
688 ((and (not flag
) (not installed
)) nil
) ; already not installed
694 (jka-compr-uninstall)))
699 (message "Automatic file (de)compression is now ON.")
700 (message "Automatic file (de)compression is now OFF.")))
705 (defun jka-compr-build-file-regexp ()
709 'jka-compr-info-regexp
710 jka-compr-compression-info-list
715 (defun jka-compr-install ()
717 This adds entries to `file-name-handler-alist' and `auto-mode-alist'."
719 (setq jka-compr-file-name-handler-entry
720 (cons (jka-compr-build-file-regexp) 'jka-compr-handler
))
722 (setq file-name-handler-alist
(cons jka-compr-file-name-handler-entry
723 file-name-handler-alist
))
725 ;; Make entries in auto-mode-alist so that modes are chosen right
726 ;; according to the file names sans `.gz'.
728 (function (lambda (x)
730 (jka-compr-info-strip-extension x
)
731 (setq auto-mode-alist
(cons (list (jka-compr-info-regexp x
)
735 jka-compr-compression-info-list
)
736 (setq auto-mode-alist
737 (append auto-mode-alist jka-compr-mode-alist-additions
)))
740 (defun jka-compr-uninstall ()
741 "Uninstall jka-compr.
742 This removes the entries in `file-name-handler-alist' and `auto-mode-alist'
743 that were created by `jka-compr-installed'."
745 (let* ((fnha (cons nil file-name-handler-alist
))
749 (if (eq (cdr (car (cdr last
))) 'jka-compr-handler
)
750 (setcdr last
(cdr (cdr last
)))
751 (setq last
(cdr last
))))
753 (setq file-name-handler-alist
(cdr fnha
)))
755 (let* ((ama (cons nil auto-mode-alist
))
760 (setq entry
(car (cdr last
)))
761 (if (or (member entry jka-compr-mode-alist-additions
)
762 (and (consp (cdr entry
))
763 (eq (nth 2 entry
) 'jka-compr
)))
764 (setcdr last
(cdr (cdr last
)))
765 (setq last
(cdr last
))))
767 (setq auto-mode-alist
(cdr ama
))))
770 (defun jka-compr-installed-p ()
771 "Return non-nil if jka-compr is installed.
772 The return value is the entry in `file-name-handler-alist' for jka-compr."
774 (let ((fnha file-name-handler-alist
)
777 (while (and fnha
(not installed
))
778 (and (eq (cdr (car fnha
)) 'jka-compr-handler
)
779 (setq installed
(car fnha
)))
780 (setq fnha
(cdr fnha
)))
785 ;;; Add the file I/O hook if it does not already exist.
786 ;;; Make sure that jka-compr-file-name-handler-entry is eq to the
787 ;;; entry for jka-compr in file-name-handler-alist.
788 (and (jka-compr-installed-p)
789 (jka-compr-uninstall))
796 ;; jka-compr.el ends here.