1 ;;; jka-compr.el --- reading/writing/loading compressed files
3 ;; Copyright (C) 1993-1995, 1997, 1999-2011 Free Software Foundation, Inc.
5 ;; Author: jka@ece.cmu.edu (Jay K. Adams)
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software: you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
26 ;; This package implements low-level support for reading, writing,
27 ;; and loading compressed files. It hooks into the low-level file
28 ;; I/O functions (including write-region and insert-file-contents) so
29 ;; that they automatically compress or uncompress a file if the file
30 ;; appears to need it (based on the extension of the file name).
31 ;; Packages like Rmail, VM, GNUS, and Info should be able to work
32 ;; with compressed files without modification.
37 ;; To use jka-compr, invoke the command `auto-compression-mode' (which
38 ;; see), or customize the variable of the same name. Its operation
39 ;; should be transparent to the user (except for messages appearing when
40 ;; a file is being compressed or uncompressed).
42 ;; The variable, jka-compr-compression-info-list can be used to
43 ;; customize jka-compr to work with other compression programs.
44 ;; The default value of this variable allows jka-compr to work with
45 ;; Unix compress and gzip.
47 ;; If you don't want messages about compressing and decompressing
48 ;; to show up in the echo area, you can set the compress-msg and
49 ;; decompress-msg fields of the jka-compr-compression-info-list to
56 ;; jka-compr can coexist with crypt++ 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
70 ;; jka-compr is a V19 adaptation of jka-compr for V18 of Emacs. Many people
71 ;; have made helpful suggestions, reported bugs, and even fixed bugs in
72 ;; jka-compr. I recall the following people as being particularly helpful.
81 ;; Andy Norman's ange-ftp was the inspiration for the original jka-compr for
82 ;; Version 18 of Emacs.
84 ;; After I had made progress on the original jka-compr for V18, I learned of a
85 ;; package written by Kazushi Jam Marukawa, called jam-zcat, that did exactly
86 ;; what I was trying to do. I looked over the jam-zcat source code and
87 ;; probably got some ideas from it.
92 (require 'jka-cmpr-hook
)
94 (defcustom jka-compr-shell
"sh"
95 "Shell to be used for calling compression programs.
96 NOTE: Not used in MS-DOS and Windows systems."
100 (defcustom jka-compr-verbose t
101 "If non-nil, output messages whenever compressing or uncompressing files."
105 (defvar jka-compr-use-shell
106 (not (memq system-type
'(ms-dos windows-nt
))))
108 (defvar jka-compr-really-do-compress nil
109 "Non-nil in a buffer whose visited file was uncompressed on visiting it.
110 This means compress the data on writing the file, even if the
111 data appears to be compressed already.")
112 (make-variable-buffer-local 'jka-compr-really-do-compress
)
113 (put 'jka-compr-really-do-compress
'permanent-local t
)
116 (put 'compression-error
'error-conditions
'(compression-error file-error error
))
119 (defvar jka-compr-acceptable-retval-list
'(0 2 141))
122 (defun jka-compr-error (prog args infile message
&optional errfile
)
124 (let ((errbuf (get-buffer-create " *jka-compr-error*")))
125 (with-current-buffer errbuf
126 (widen) (erase-buffer)
127 (insert (format "Error while executing \"%s %s < %s\"\n\n"
129 (mapconcat 'identity args
" ")
133 (insert-file-contents errfile
)))
134 (display-buffer errbuf
))
136 (signal 'compression-error
137 (list "Opening input file" (format "error %s" message
) infile
)))
140 (defcustom jka-compr-dd-program
"/bin/dd"
141 "How to invoke `dd'."
146 (defvar jka-compr-dd-blocksize
256)
149 (defun jka-compr-partial-uncompress (prog message args infile beg len
)
150 "Call program PROG with ARGS args taking input from INFILE.
151 Fourth and fifth args, BEG and LEN, specify which part of the output
152 to keep: LEN chars starting BEG chars from the beginning."
153 (let ((start (point))
155 (if (and jka-compr-use-shell jka-compr-dd-program
)
156 ;; Put the uncompression output through dd
157 ;; to discard the part we don't want.
158 (let ((skip (/ beg jka-compr-dd-blocksize
))
159 (err-file (jka-compr-make-temp-name))
160 ;; call-process barfs if default-directory is inaccessible.
162 (if (and default-directory
163 (file-accessible-directory-p default-directory
))
165 (file-name-directory infile
)))
167 ;; Update PREFIX based on the text that we won't read in.
168 (setq prefix
(- beg
(* skip jka-compr-dd-blocksize
))
169 count
(and len
(1+ (/ (+ len prefix
) jka-compr-dd-blocksize
))))
171 (or (memq (call-process
172 jka-compr-shell infile t nil
"-c"
173 ;; Windows shells need the program file name
174 ;; after the pipe symbol be quoted if they use
175 ;; forward slashes as directory separators.
177 "%s %s 2> %s | \"%s\" bs=%d skip=%d %s 2> %s"
179 (mapconcat 'identity args
" ")
182 jka-compr-dd-blocksize
184 ;; dd seems to be unreliable about
185 ;; providing the last block. So, always
186 ;; read one more than you think you need.
187 (if count
(format "count=%d" (1+ count
)) "")
189 jka-compr-acceptable-retval-list
)
190 (jka-compr-error prog args infile message err-file
))
191 (delete-file err-file
)))
193 ;; Run the uncompression program directly.
194 ;; We get the whole file and must delete what we don't want.
195 (jka-compr-call-process prog message infile t nil args
))
197 ;; Delete the stuff after what we want, if there is any.
200 (< (+ start prefix len
) (point))
201 (delete-region (+ start prefix len
) (point)))
203 ;; Delete the stuff before what we want.
204 (delete-region start
(+ start prefix
))))
207 (defun jka-compr-call-process (prog message infile output temp args
)
208 ;; call-process barfs if default-directory is inaccessible.
209 (let ((default-directory
210 (if (and default-directory
211 (file-accessible-directory-p default-directory
))
213 (file-name-directory infile
))))
214 (if jka-compr-use-shell
215 (let ((err-file (jka-compr-make-temp-name))
216 (coding-system-for-read (or coding-system-for-read
'undecided
))
217 (coding-system-for-write 'no-conversion
))
220 (call-process jka-compr-shell infile
221 (if (stringp output
) nil output
)
224 (format "%s %s 2> %s %s"
226 (mapconcat 'identity args
" ")
231 jka-compr-acceptable-retval-list
)
232 (jka-compr-error prog args infile message err-file
))
233 (delete-file err-file
)))
236 prog infile
(if (stringp output
) temp output
)
238 (jka-compr-error prog args infile message
))
239 (and (stringp output
)
240 (with-current-buffer temp
241 (write-region (point-min) (point-max) output
)
245 ;; Support for temp files. Much of this was inspired if not lifted
248 (defcustom jka-compr-temp-name-template
249 (expand-file-name "jka-com" temporary-file-directory
)
250 "Prefix added to all temp files created by jka-compr.
251 There should be no more than seven characters after the final `/'."
255 (defun jka-compr-make-temp-name (&optional _local-copy
)
256 "This routine will return the name of a new file."
257 (make-temp-file jka-compr-temp-name-template
))
259 (defun jka-compr-write-region (start end file
&optional append visit
)
260 (let* ((filename (expand-file-name file
))
261 (visit-file (if (stringp visit
) (expand-file-name visit
) filename
))
262 (info (jka-compr-get-compression-info visit-file
))
263 (magic (and info
(jka-compr-info-file-magic-bytes info
))))
265 ;; If we uncompressed this file when visiting it,
266 ;; then recompress it when writing it
267 ;; even if the contents look compressed already.
268 (if (and jka-compr-really-do-compress
270 (= (- end start
) (buffer-size))))
274 ;; If the contents to be written out
275 ;; are properly compressed already,
276 ;; don't try to compress them over again.
278 (equal (if (stringp start
)
279 (substring start
0 (min (length start
)
281 (let* ((from (or start
(point-min)))
282 (to (min (or end
(point-max))
283 (+ from
(length magic
)))))
284 (buffer-substring from to
)))
286 (let ((can-append (jka-compr-info-can-append info
))
287 (compress-program (jka-compr-info-compress-program info
))
288 (compress-message (jka-compr-info-compress-message info
))
289 (compress-args (jka-compr-info-compress-args info
))
290 (base-name (file-name-nondirectory visit-file
))
291 temp-file temp-buffer
292 ;; we need to leave `last-coding-system-used' set to its
293 ;; value after calling write-region the first time, so
294 ;; that `basic-save-buffer' sees the right value.
295 (coding-system-used last-coding-system-used
))
298 (error "No compression program defined"))
300 (setq temp-buffer
(get-buffer-create " *jka-compr-wr-temp*"))
301 (with-current-buffer temp-buffer
302 (widen) (erase-buffer))
306 (file-exists-p filename
))
308 (let* ((local-copy (file-local-copy filename
))
309 (local-file (or local-copy filename
)))
311 (setq temp-file local-file
))
313 (setq temp-file
(jka-compr-make-temp-name)))
318 (message "%s %s..." compress-message base-name
))
320 (jka-compr-run-real-handler 'write-region
321 (list start end temp-file t
'dont
))
322 ;; save value used by the real write-region
323 (setq coding-system-used last-coding-system-used
)
325 ;; Here we must read the output of compress program as is
326 ;; without any code conversion.
327 (let ((coding-system-for-read 'no-conversion
))
328 (jka-compr-call-process compress-program
329 (concat compress-message
336 (with-current-buffer temp-buffer
337 (let ((coding-system-for-write 'no-conversion
))
338 (if (memq system-type
'(ms-dos windows-nt
))
339 (setq buffer-file-type t
) )
340 (jka-compr-run-real-handler 'write-region
341 (list (point-min) (point-max)
343 (and append can-append
) 'dont
))
346 (delete-file temp-file
)
351 (message "%s %s...done" compress-message base-name
))
355 (setq buffer-file-name filename
)
356 (setq jka-compr-really-do-compress t
)
357 (set-visited-file-modtime))
359 (setq buffer-file-name visit
)
360 (let ((buffer-file-name filename
))
361 (set-visited-file-modtime))))
363 (and (or (eq visit t
)
366 (message "Wrote %s" visit-file
))
368 ;; ensure `last-coding-system-used' has an appropriate value
369 (setq last-coding-system-used coding-system-used
)
373 (jka-compr-run-real-handler 'write-region
374 (list start end filename append visit
)))))
377 (defun jka-compr-insert-file-contents (file &optional visit beg end replace
)
378 (barf-if-buffer-read-only)
382 (error "Attempt to visit less than an entire file"))
384 (let* ((filename (expand-file-name file
))
385 (info (jka-compr-get-compression-info filename
)))
389 (jka-compr-run-real-handler 'insert-file-contents
390 (list file visit beg end replace
))
392 (let ((uncompress-message (jka-compr-info-uncompress-message info
))
393 (uncompress-program (jka-compr-info-uncompress-program info
))
394 (uncompress-args (jka-compr-info-uncompress-args info
))
395 (base-name (file-name-nondirectory filename
))
398 (jka-compr-run-real-handler 'file-local-copy
(list filename
)))
402 (setq local-file
(or local-copy filename
))
406 (setq buffer-file-name filename
))
408 (unwind-protect ; to make sure local-copy gets deleted
415 (message "%s %s..." uncompress-message base-name
))
417 (condition-case error-code
419 (let ((coding-system-for-read 'no-conversion
))
421 (goto-char (point-min)))
424 (jka-compr-partial-uncompress uncompress-program
425 (concat uncompress-message
433 ;; If visiting, bind off buffer-file-name so that
434 ;; file-locking will not ask whether we should
435 ;; really edit the buffer.
436 (let ((buffer-file-name
437 (if visit nil buffer-file-name
)))
438 (jka-compr-call-process uncompress-program
439 (concat uncompress-message
445 (setq size
(- (point) start
))
447 (delete-region (point) (point-max)))
450 ;; If the file we wanted to uncompress does not exist,
451 ;; handle that according to VISIT as `insert-file-contents'
452 ;; would, maybe signaling the same error it normally would.
453 (if (and (eq (car error-code
) 'file-error
)
454 (eq (nth 3 error-code
) local-file
))
456 (setq notfound error-code
)
458 (cons "Opening input file"
459 (nthcdr 2 error-code
))))
460 ;; If the uncompression program can't be found,
461 ;; signal that as a non-file error
462 ;; so that find-file-noselect-1 won't handle it.
463 (if (and (eq (car error-code
) 'file-error
)
464 (equal (cadr error-code
) "Searching for program"))
465 (error "Uncompression program `%s' not found"
467 (signal (car error-code
) (cdr error-code
))))))
471 (file-exists-p local-copy
)
472 (delete-file local-copy
)))
475 (decode-coding-inserted-region
476 (point) (+ (point) size
)
477 (jka-compr-byte-compiler-base-file-name file
)
478 visit beg end replace
))
484 (setq buffer-file-name filename
)
485 (setq jka-compr-really-do-compress t
)
486 (set-visited-file-modtime)))
491 (message "%s %s...done" uncompress-message base-name
))
497 (cons "Opening input file" (nth 2 notfound
))))
499 ;; This is done in insert-file-contents after we return.
500 ;; That is a little weird, but better to go along with it now
501 ;; than to change it now.
503 ;; ;; Run the functions that insert-file-contents would.
504 ;; (let ((p after-insert-file-functions)
507 ;; (setq insval (funcall (car p) size))
510 ;; (or (integerp insval)
511 ;; (signal 'wrong-type-argument
512 ;; (list 'integerp insval)))
513 ;; (setq size insval)))
514 ;; (setq p (cdr p))))
516 (or (jka-compr-info-compress-program info
)
517 (message "You can't save this buffer because compression program is not defined"))
519 (list filename size
)))))
522 (defun jka-compr-file-local-copy (file)
523 (let* ((filename (expand-file-name file
))
524 (info (jka-compr-get-compression-info filename
)))
528 (let ((uncompress-message (jka-compr-info-uncompress-message info
))
529 (uncompress-program (jka-compr-info-uncompress-program info
))
530 (uncompress-args (jka-compr-info-uncompress-args info
))
531 (base-name (file-name-nondirectory filename
))
533 (jka-compr-run-real-handler 'file-local-copy
(list filename
)))
534 (temp-file (jka-compr-make-temp-name t
))
535 (temp-buffer (get-buffer-create " *jka-compr-flc-temp*"))
538 (setq local-file
(or local-copy filename
))
542 (with-current-buffer temp-buffer
547 (message "%s %s..." uncompress-message base-name
))
549 ;; Here we must read the output of uncompress program
550 ;; and write it to TEMP-FILE without any code
551 ;; conversion. An appropriate code conversion (if
552 ;; necessary) is done by the later I/O operation
554 (let ((coding-system-for-read 'no-conversion
)
555 (coding-system-for-write 'no-conversion
))
557 (jka-compr-call-process uncompress-program
558 (concat uncompress-message
568 (message "%s %s...done" uncompress-message base-name
))
571 (point-min) (point-max) temp-file nil
'dont
)))
575 (file-exists-p local-copy
)
576 (delete-file local-copy
))
578 (kill-buffer temp-buffer
))
582 (jka-compr-run-real-handler 'file-local-copy
(list filename
)))))
585 ;; Support for loading compressed files.
586 (defun jka-compr-load (file &optional noerror nomessage _nosuffix
)
587 "Documented as original."
589 (let* ((local-copy (jka-compr-file-local-copy file
))
590 (load-file (or local-copy file
)))
594 (let (inhibit-file-name-operation
595 inhibit-file-name-handlers
)
597 (message "Loading %s..." file
))
599 (let ((load-force-doc-strings t
))
600 (load load-file noerror t t
))
602 (message "Loading %s...done." file
))
603 ;; Fix up the load history to point at the right library.
604 (let ((l (or (assoc load-file load-history
)
605 ;; On MS-Windows, if load-file is in
606 ;; temporary-file-directory, it will look like
607 ;; "c:/DOCUME~1/USER/LOCALS~1/foo", whereas
608 ;; readevalloop will record its truename in
609 ;; load-history. Therefore try truename if the
610 ;; original name is not in load-history.
611 (assoc (file-truename load-file
) load-history
))))
612 ;; Remove .gz and .elc?.
613 (while (file-name-extension file
)
614 (setq file
(file-name-sans-extension file
)))
617 (delete-file local-copy
))
621 (defun jka-compr-byte-compiler-base-file-name (file)
622 (let ((info (jka-compr-get-compression-info file
)))
623 (if (and info
(jka-compr-info-strip-extension info
))
625 (substring file
0 (string-match (jka-compr-info-regexp info
) file
)))
628 (put 'write-region
'jka-compr
'jka-compr-write-region
)
629 (put 'insert-file-contents
'jka-compr
'jka-compr-insert-file-contents
)
630 (put 'file-local-copy
'jka-compr
'jka-compr-file-local-copy
)
631 (put 'load
'jka-compr
'jka-compr-load
)
632 (put 'byte-compiler-base-file-name
'jka-compr
633 'jka-compr-byte-compiler-base-file-name
)
636 (defvar jka-compr-inhibit nil
637 "Non-nil means inhibit automatic uncompression temporarily.
638 Lisp programs can bind this to t to do that.
639 It is not recommended to set this variable permanently to anything but nil.")
642 (defun jka-compr-handler (operation &rest args
)
644 (let ((jka-op (get operation
'jka-compr
)))
645 (if (and jka-op
(not jka-compr-inhibit
))
647 (jka-compr-run-real-handler operation args
)))))
649 ;; If we are given an operation that we don't handle,
650 ;; call the Emacs primitive for that operation,
651 ;; and manipulate the inhibit variables
652 ;; to prevent the primitive from calling our handler again.
653 (defun jka-compr-run-real-handler (operation args
)
654 (let ((inhibit-file-name-handlers
655 (cons 'jka-compr-handler
656 (and (eq inhibit-file-name-operation operation
)
657 inhibit-file-name-handlers
)))
658 (inhibit-file-name-operation operation
))
659 (apply operation args
)))
662 (defun jka-compr-uninstall ()
663 "Uninstall jka-compr.
664 This removes the entries in `file-name-handler-alist' and `auto-mode-alist'
665 and `inhibit-first-line-modes-suffixes' that were added
666 by `jka-compr-installed'."
667 ;; Delete from inhibit-first-line-modes-suffixes
668 ;; what jka-compr-install added.
670 (function (lambda (x)
671 (and (jka-compr-info-strip-extension x
)
672 (setq inhibit-first-line-modes-suffixes
673 (delete (jka-compr-info-regexp x
)
674 inhibit-first-line-modes-suffixes
)))))
675 jka-compr-compression-info-list--internal
)
677 (let* ((fnha (cons nil file-name-handler-alist
))
681 (if (eq (cdr (car (cdr last
))) 'jka-compr-handler
)
682 (setcdr last
(cdr (cdr last
)))
683 (setq last
(cdr last
))))
685 (setq file-name-handler-alist
(cdr fnha
)))
687 (let* ((ama (cons nil auto-mode-alist
))
692 (setq entry
(car (cdr last
)))
693 (if (or (member entry jka-compr-mode-alist-additions--internal
)
694 (and (consp (cdr entry
))
695 (eq (nth 2 entry
) 'jka-compr
)))
696 (setcdr last
(cdr (cdr last
)))
697 (setq last
(cdr last
))))
699 (setq auto-mode-alist
(cdr ama
)))
701 (while jka-compr-added-to-file-coding-system-alist
702 (setq file-coding-system-alist
703 (delq (car (member (pop jka-compr-added-to-file-coding-system-alist
)
704 file-coding-system-alist
))
705 file-coding-system-alist
)))
707 ;; Remove the suffixes that were added by jka-compr.
708 (dolist (suff jka-compr-load-suffixes--internal
)
709 (setq load-file-rep-suffixes
(delete suff load-file-rep-suffixes
)))
711 (setq jka-compr-compression-info-list--internal nil
712 jka-compr-mode-alist-additions--internal nil
713 jka-compr-load-suffixes--internal nil
))
717 ;;; jka-compr.el ends here