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)
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.
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
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.
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
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
46 ;;; APPLICATION NOTES:
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.
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
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:
72 ;;; ["\\.trz\\'" "\037\213"
73 ;;; "zip" "gzip" nil ("-q")
74 ;;; "unzip" "gzip" nil ("-q" "-d")
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
83 ;;; Finally, to make tar-mode start up automatically, you have to add an
84 ;;; entry to auto-mode-alist that looks like this
86 ;;; ("\\.trz\\'" . tar-mode)
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.
103 ;;; Andy Norman's ange-ftp was the inspiration for the original jka-compr for
104 ;;; Version 18 of Emacs.
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.
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').")
121 (defvar jka-compr-use-shell t
)
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
128 ;; compr-message compr-prog compr-args
129 ;; uncomp-message uncomp-prog uncomp-args
130 ;; can-append auto-mode-flag]
132 "compressing" "compress" ("-c")
133 "uncompressing" "uncompress" ("-c")
136 "zipping" "gzip" ("-c" "-q")
137 "unzipping" "gzip" ("-c" "-q" "-d")
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 COMPRESS-MSG COMPRESS-PROGRAM COMPRESS-ARGS
143 UNCOMPRESS-MSG UNCOMPRESS-PROGRAM UNCOMPRESS-ARGS
144 APPEND-FLAG EXTENSION], where:
146 regexp is a regexp that matches filenames that are
147 compressed with this format
149 compress-msg is the message to issue to the user when doing this
150 type of compression (nil means no message)
152 compress-program is a program that performs this compression
154 compress-args is a list of args to pass to the compress program
156 uncompress-msg is the message to issue to the user when doing this
157 type of uncompression (nil means no message)
159 uncompress-program is a program that performs this compression
161 uncompress-args is a list of args to pass to the uncompress program
163 append-flag is non-nil if this compression technique can be
166 auto-mode flag non-nil means strip the regexp from file names
167 before attempting to set the mode.
169 Because of the way call-process is defined, discarding the stderr output of
170 a program adds the overhead of starting a shell each time the program is
174 (defvar jka-compr-file-name-handler-entry
176 "The entry in `file-name-handler-alist' used by the jka-compr I/O functions.")
178 (defvar jka-compr-op-table
180 "Hash table of operations supported by jka-compr.")
182 ;;; Functions for accessing the return value of jka-get-compression-info
183 (defun jka-compr-info-regexp (info) (aref info
0))
184 (defun jka-compr-info-compress-message (info) (aref info
1))
185 (defun jka-compr-info-compress-program (info) (aref info
2))
186 (defun jka-compr-info-compress-args (info) (aref info
3))
187 (defun jka-compr-info-uncompress-message (info) (aref info
4))
188 (defun jka-compr-info-uncompress-program (info) (aref info
5))
189 (defun jka-compr-info-uncompress-args (info) (aref info
6))
190 (defun jka-compr-info-can-append (info) (aref info
7))
191 (defun jka-compr-info-strip-extension (info) (aref info
8))
194 (defun jka-compr-get-compression-info (filename)
195 "Return information about the compression scheme of FILENAME.
196 The determination as to which compression scheme, if any, to use is
197 based on the filename itself and `jka-compr-compression-info-list'."
198 (catch 'compression-info
199 (let ((case-fold-search nil
))
201 (function (lambda (x)
202 (and (string-match (jka-compr-info-regexp x
) filename
)
203 (throw 'compression-info x
))))
204 jka-compr-compression-info-list
)
208 (put 'compression-error
'error-conditions
'(compression-error file-error error
))
211 (defvar jka-compr-acceptable-retval-list
'(0 141))
214 (defun jka-compr-error (prog args infile message
&optional errfile
)
216 (let ((errbuf (get-buffer-create " *jka-compr-error*"))
217 (curbuf (current-buffer)))
219 (widen) (erase-buffer)
220 (insert (format "Error while executing \"%s %s < %s\"\n\n"
222 (mapconcat 'identity args
" ")
226 (insert-file-contents errfile
))
229 (display-buffer errbuf
))
231 (signal 'compression-error
(list "Opening input file" (format "error %s" message
) infile
)))
234 (defvar jka-compr-dd-program
238 (defvar jka-compr-dd-blocksize
256)
241 (defun jka-compr-partial-uncompress (prog message args infile beg len
)
242 "Call program PROG with ARGS args taking input from INFILE.
243 Fourth and fifth args, BEG and LEN, specify which part of the output
244 to discard. All output is discarded unless it comes within LEN chars after
247 (let* ((skip (/ beg jka-compr-dd-blocksize
))
248 (prefix (- beg
(* skip jka-compr-dd-blocksize
)))
249 (count (and len
(1+ (/ (+ len prefix
) jka-compr-dd-blocksize
))))
251 (err-file (jka-compr-make-temp-name))
252 (run-string (format "%s %s 2> %s | %s bs=%d skip=%d %s 2> /dev/null"
254 (mapconcat 'identity args
" ")
257 jka-compr-dd-blocksize
259 ;; dd seems to be unreliable about
260 ;; providing the last block. So, always
261 ;; read one more than you think you need.
262 (if count
(concat "count=" (1+ count
)) ""))))
265 (or (memq (call-process jka-compr-shell
268 jka-compr-acceptable-retval-list
)
270 (jka-compr-error prog args infile message err-file
))
272 (jka-compr-delete-temp-file err-file
))
276 (delete-region (+ start prefix len
) (point)))
278 (delete-region start
(+ start prefix
))))
281 (defun jka-compr-call-process (prog message infile output temp args
)
282 (if jka-compr-use-shell
284 (let ((err-file (jka-compr-make-temp-name)))
289 (call-process jka-compr-shell infile
290 (if (stringp output
) nil output
)
293 (format "%s %s 2> %s %s"
295 (mapconcat 'identity args
" ")
300 jka-compr-acceptable-retval-list
)
302 (jka-compr-error prog args infile message err-file
))
304 (jka-compr-delete-temp-file err-file
)))
310 (if (stringp output
) temp output
)
313 (jka-compr-error prog args infile message
))
315 (and (stringp output
)
316 (let ((cbuf (current-buffer)))
318 (write-region (point-min) (point-max) output
)
320 (set-buffer cbuf
)))))
323 ;;; Support for temp files. Much of this was inspired if not lifted
326 (defvar jka-compr-temp-name-template
328 "Prefix added to all temp files created by jka-compr.
329 There should be no more than seven characters after the final `/'")
331 (defvar jka-compr-temp-name-table
(make-vector 31 nil
))
333 (defun jka-compr-make-temp-name (&optional local-copy
)
334 "This routine will return the name of a new file."
337 (template (concat jka-compr-temp-name-template
"aa"))
338 (lastpos (1- (length template
)))
344 (aset template lastpos lastchar
)
345 (setq file
(concat (make-temp-name template
) "#"))
346 (setq entry
(intern file jka-compr-temp-name-table
))
347 (if (or (get entry
'active
)
348 (file-exists-p file
))
351 (setq lastchar
(1+ lastchar
))
354 (setq prevchar
(1+ prevchar
))
357 (error "Can't allocate temp file.")
358 (aset template
(1- lastpos
) prevchar
)))))
360 (put entry
'active
(not local-copy
))
361 (setq not-done nil
)))
366 (defun jka-compr-delete-temp-file (temp)
368 (put (intern temp jka-compr-temp-name-table
)
376 (defun jka-compr-write-region (start end file
&optional append visit
)
377 "Documented as original."
378 (interactive "r\nFWrite region to file: ")
380 (let* ((filename (expand-file-name file
))
381 (visit-file (if (stringp visit
) (expand-file-name visit
) filename
))
382 (info (jka-compr-get-compression-info visit-file
)))
386 (let ((can-append (jka-compr-info-can-append info
))
387 (compress-program (jka-compr-info-compress-program info
))
388 (compress-message (jka-compr-info-compress-message info
))
389 (uncompress-program (jka-compr-info-uncompress-program info
))
390 (uncompress-message (jka-compr-info-uncompress-message info
))
391 (compress-args (jka-compr-info-compress-args info
))
392 (uncompress-args (jka-compr-info-uncompress-args info
))
393 (temp-file (jka-compr-make-temp-name))
394 (base-name (file-name-nondirectory visit-file
))
397 (setq cbuf
(current-buffer)
398 temp-buffer
(get-buffer-create " *jka-compr-temp*"))
399 (set-buffer temp-buffer
)
400 (widen) (erase-buffer)
405 (file-exists-p filename
)
406 (let* ((local-copy (file-local-copy filename
))
407 (local-file (or local-copy filename
)))
415 (message "%s %s..." uncompress-message base-name
))
417 (jka-compr-call-process uncompress-program
418 (concat uncompress-message
426 (message "%s %s...done" uncompress-message base-name
)))
430 (file-exists-p local-copy
)
431 (delete-file local-copy
)))))
435 (message "%s %s..." compress-message base-name
))
437 (write-region start end temp-file t
'dont
)
439 (jka-compr-call-process compress-program
440 (concat compress-message
447 (set-buffer temp-buffer
)
448 (write-region (point-min) (point-max)
449 filename
(and append can-append
) 'dont
)
453 (jka-compr-delete-temp-file temp-file
)
457 (message "%s %s...done" compress-message base-name
))
461 (setq buffer-file-name filename
)
462 (set-visited-file-modtime))
464 (setq buffer-file-name visit
)
465 (let ((buffer-file-name filename
))
466 (set-visited-file-modtime))))
468 (and (or (eq visit t
)
471 (message "Wrote %s" visit-file
))
475 (write-region start end filename append visit
))))
478 (defun jka-compr-insert-file-contents (file &optional visit beg end replace
)
479 "Documented as original."
481 (barf-if-buffer-read-only)
485 (error "Attempt to visit less than an entire file"))
487 (let* ((filename (expand-file-name file
))
488 (info (jka-compr-get-compression-info filename
)))
492 (let ((uncompress-message (jka-compr-info-uncompress-message info
))
493 (uncompress-program (jka-compr-info-uncompress-program info
))
494 (uncompress-args (jka-compr-info-uncompress-args info
))
495 (base-name (file-name-nondirectory filename
))
497 (local-copy (file-local-copy filename
))
501 (setq local-file
(or local-copy filename
))
505 (setq buffer-file-name filename
))
507 (unwind-protect ; to make sure local-copy gets deleted
513 (message "%s %s..." uncompress-message base-name
))
515 (condition-case error-code
520 (jka-compr-partial-uncompress uncompress-program
521 (concat uncompress-message
529 (jka-compr-call-process uncompress-program
530 (concat uncompress-message
536 (setq size
(- (point) start
))
541 (if (and (eq (car error-code
) 'file-error
)
542 (eq (nth 3 error-code
) local-file
))
544 (setq notfound error-code
)
546 (cons "Opening input file"
547 (nthcdr 2 error-code
))))
548 (signal (car error-code
) (cdr error-code
))))))
552 (file-exists-p local-copy
)
553 (delete-file local-copy
)))
558 (setq buffer-file-name filename
)
559 (set-visited-file-modtime)))
563 (message "%s %s...done" uncompress-message base-name
))
569 (cons "Opening input file" (nth 2 notfound
))))
571 (list filename size
))
573 (insert-file-contents file visit beg end replace
))))
576 (defun jka-compr-file-local-copy (file)
577 "Documented as original."
579 (let* ((filename (expand-file-name file
))
580 (info (jka-compr-get-compression-info filename
)))
584 (let ((uncompress-message (jka-compr-info-uncompress-message info
))
585 (uncompress-program (jka-compr-info-uncompress-program info
))
586 (uncompress-args (jka-compr-info-uncompress-args info
))
587 (base-name (file-name-nondirectory filename
))
588 (local-copy (file-local-copy filename
))
589 (temp-file (jka-compr-make-temp-name t
))
590 (temp-buffer (get-buffer-create " *jka-compr-temp*"))
592 (cbuf (current-buffer))
595 (setq local-file
(or local-copy filename
))
603 (message "%s %s..." uncompress-message base-name
))
605 (set-buffer temp-buffer
)
607 (jka-compr-call-process uncompress-program
608 (concat uncompress-message
617 (message "%s %s...done" uncompress-message base-name
))
620 (point-min) (point-max) temp-file nil
'dont
))
624 (file-exists-p local-copy
)
625 (delete-file local-copy
))
628 (kill-buffer temp-buffer
))
632 (file-local-copy filename
))))
635 ;;; Support for loading compressed files.
636 (defun jka-compr-load (file &optional noerror nomessage nosuffix
)
637 "Documented as original."
639 (let* ((local-copy (jka-compr-file-local-copy file
))
640 (load-file (or local-copy file
)))
646 (setq file-name-handler-alist
647 (cons jka-compr-file-name-handler-entry
648 file-name-handler-alist
))
651 (message "Loading %s..." file
))
653 (load load-file noerror t t
)
656 (message "Loading %s...done." file
)))
658 (setq file-name-handler-alist
659 (delq jka-compr-file-name-handler-entry
660 file-name-handler-alist
))
662 (jka-compr-delete-temp-file local-copy
))
667 (defun jka-compr-handler (operation &rest args
)
669 (let ((jka-op (intern-soft (symbol-name operation
) jka-compr-op-table
))
670 (match-data (match-data)))
674 (setq file-name-handler-alist
675 (delq jka-compr-file-name-handler-entry
676 file-name-handler-alist
))
679 (jka-compr-run-real-handler operation args
)))
681 (setq file-name-handler-alist
682 (cons jka-compr-file-name-handler-entry
683 file-name-handler-alist
))
684 (store-match-data match-data
))))
686 ;; If we are given an operation that we don't handle,
687 ;; call the Emacs primitive for that operation,
688 ;; and manipulate the inhibit variables
689 ;; to prevent the primitive from calling our handler again.
690 (defun jka-compr-run-real-handler (operation args
)
691 (let ((inhibit-file-name-handlers
692 (cons 'jka-compr-handler
693 (and (eq inhibit-file-name-operation operation
)
694 inhibit-file-name-handlers
)))
695 (inhibit-file-name-operation operation
))
696 (apply operation args
)))
699 (defun jka-compr-intern-operation (op)
700 (let ((opsym (intern (symbol-name op
) jka-compr-op-table
))
701 (jka-fn (intern (concat "jka-compr-" (symbol-name op
)))))
702 (fset opsym jka-fn
)))
705 (defvar jka-compr-operation-list
712 "List of file operations implemented by jka-compr.")
718 (jka-compr-intern-operation fn
)))
719 jka-compr-operation-list
)
722 (defun toggle-auto-compression (arg)
723 "Toggle automatic file compression and decompression.
724 With prefix argument ARG, turn auto compression on if positive, else off.
725 Returns the new status of auto compression (non-nil means on)."
727 (let* ((installed (jka-compr-installed-p))
730 (or (eq arg t
) (listp arg
) (and (integerp arg
) (> arg
0))))))
733 ((and flag installed
) t
) ; already installed
735 ((and (not flag
) (not installed
)) nil
) ; already not installed
741 (jka-compr-uninstall)))
746 (message "Automatic file (de)compression is now ON.")
747 (message "Automatic file (de)compression is now OFF.")))
752 (defun jka-compr-build-file-regexp ()
756 'jka-compr-info-regexp
757 jka-compr-compression-info-list
762 (defun jka-compr-install ()
764 This adds entries to `file-name-handler-alist' and `auto-mode-alist'."
766 (setq jka-compr-file-name-handler-entry
767 (cons (jka-compr-build-file-regexp) 'jka-compr-handler
))
769 (setq file-name-handler-alist
(cons jka-compr-file-name-handler-entry
770 file-name-handler-alist
))
773 (function (lambda (x)
775 (jka-compr-info-strip-extension x
)
776 (setq auto-mode-alist
(cons (list (jka-compr-info-regexp x
)
780 jka-compr-compression-info-list
))
783 (defun jka-compr-uninstall ()
784 "Uninstall jka-compr.
785 This removes the entries in `file-name-handler-alist' and `auto-mode-alist'
786 that were created by `jka-compr-installed'."
788 (let* ((fnha (cons nil file-name-handler-alist
))
792 (if (eq (cdr (car (cdr last
))) 'jka-compr-handler
)
793 (setcdr last
(cdr (cdr last
)))
794 (setq last
(cdr last
))))
796 (setq file-name-handler-alist
(cdr fnha
)))
798 (let* ((ama (cons nil auto-mode-alist
))
803 (setq entry
(car (cdr last
)))
804 (if (and (consp (cdr entry
))
805 (eq (nth 2 entry
) 'jka-compr
))
806 (setcdr last
(cdr (cdr last
)))
807 (setq last
(cdr last
))))
809 (setq auto-mode-alist
(cdr ama
))))
812 (defun jka-compr-installed-p ()
813 "Return non-nil if jka-compr is installed.
814 The return value is the entry in `file-name-handler-alist' for jka-compr."
816 (let ((fnha file-name-handler-alist
)
819 (while (and fnha
(not installed
))
820 (and (eq (cdr (car fnha
)) 'jka-compr-handler
)
821 (setq installed
(car fnha
)))
822 (setq fnha
(cdr fnha
)))
827 ;;; Add the file I/O hook if it does not already exist.
828 ;;; Make sure that jka-compr-file-name-handler-entry is eq to the
829 ;;; entry for jka-compr in file-name-handler-alist.
830 (and (jka-compr-installed-p)
831 (jka-compr-uninstall))
838 ;; jka-compr.el ends here.