1 ;;; jka-compr.el --- reading/writing/loading compressed files
3 ;; Copyright (C) 1993, 1994, 1995, 1997, 1999, 2000, 2001, 2002, 2003,
4 ;; 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
6 ;; Author: jka@ece.cmu.edu (Jay K. Adams)
10 ;; This file is part of GNU Emacs.
12 ;; GNU Emacs is free software; you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation; either version 3, or (at your option)
17 ;; GNU Emacs is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;; GNU General Public License for more details.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs; see the file COPYING. If not, write to the
24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
25 ;; Boston, MA 02110-1301, USA.
29 ;; This package implements low-level support for reading, writing,
30 ;; and loading compressed files. It hooks into the low-level file
31 ;; I/O functions (including write-region and insert-file-contents) so
32 ;; that they automatically compress or uncompress a file if the file
33 ;; appears to need it (based on the extension of the file name).
34 ;; Packages like Rmail, VM, GNUS, and Info should be able to work
35 ;; with compressed files without modification.
40 ;; To use jka-compr, invoke the command `auto-compression-mode' (which
41 ;; see), or customize the variable of the same name. Its operation
42 ;; should be transparent to the user (except for messages appearing when
43 ;; a file is being compressed or uncompressed).
45 ;; The variable, jka-compr-compression-info-list can be used to
46 ;; customize jka-compr to work with other compression programs.
47 ;; The default value of this variable allows jka-compr to work with
48 ;; Unix compress and gzip.
50 ;; If you don't want messages about compressing and decompressing
51 ;; to show up in the echo area, you can set the compress-msg and
52 ;; decompress-msg fields of the jka-compr-compression-info-list to
59 ;; jka-compr can coexist with crypt++ if you take all the decompression
60 ;; entries out of the crypt-encoding-list. Clearly problems will arise if
61 ;; you have two programs trying to compress/decompress files. jka-compr
62 ;; will not "work with" crypt++ in the following sense: you won't be able to
63 ;; decode encrypted compressed files--that is, files that have been
64 ;; compressed then encrypted (in that order). Theoretically, crypt++ and
65 ;; jka-compr could properly handle a file that has been encrypted then
66 ;; compressed, but there is little point in trying to compress an encrypted
73 ;; jka-compr is a V19 adaptation of jka-compr for V18 of Emacs. Many people
74 ;; have made helpful suggestions, reported bugs, and even fixed bugs in
75 ;; jka-compr. I recall the following people as being particularly helpful.
84 ;; Andy Norman's ange-ftp was the inspiration for the original jka-compr for
85 ;; Version 18 of Emacs.
87 ;; After I had made progress on the original jka-compr for V18, I learned of a
88 ;; package written by Kazushi Jam Marukawa, called jam-zcat, that did exactly
89 ;; what I was trying to do. I looked over the jam-zcat source code and
90 ;; probably got some ideas from it.
95 (require 'jka-cmpr-hook
)
97 (defcustom jka-compr-shell
"sh"
98 "*Shell to be used for calling compression programs.
99 NOTE: Not used in MS-DOS and Windows systems."
103 (defvar jka-compr-use-shell
104 (not (memq system-type
'(ms-dos windows-nt
))))
106 (defvar jka-compr-really-do-compress nil
107 "Non-nil in a buffer whose visited file was uncompressed on visiting it.
108 This means compress the data on writing the file, even if the
109 data appears to be compressed already.")
110 (make-variable-buffer-local 'jka-compr-really-do-compress
)
111 (put 'jka-compr-really-do-compress
'permanent-local t
)
114 (put 'compression-error
'error-conditions
'(compression-error file-error error
))
117 (defvar jka-compr-acceptable-retval-list
'(0 2 141))
120 (defun jka-compr-error (prog args infile message
&optional errfile
)
122 (let ((errbuf (get-buffer-create " *jka-compr-error*")))
123 (with-current-buffer errbuf
124 (widen) (erase-buffer)
125 (insert (format "Error while executing \"%s %s < %s\"\n\n"
127 (mapconcat 'identity args
" ")
131 (insert-file-contents errfile
)))
132 (display-buffer errbuf
))
134 (signal 'compression-error
135 (list "Opening input file" (format "error %s" message
) infile
)))
138 (defcustom jka-compr-dd-program
"/bin/dd"
139 "How to invoke `dd'."
144 (defvar jka-compr-dd-blocksize
256)
147 (defun jka-compr-partial-uncompress (prog message args infile beg len
)
148 "Call program PROG with ARGS args taking input from INFILE.
149 Fourth and fifth args, BEG and LEN, specify which part of the output
150 to keep: LEN chars starting BEG chars from the beginning."
151 (let ((start (point))
153 (if (and jka-compr-use-shell jka-compr-dd-program
)
154 ;; Put the uncompression output through dd
155 ;; to discard the part we don't want.
156 (let ((skip (/ beg jka-compr-dd-blocksize
))
157 (err-file (jka-compr-make-temp-name))
158 ;; call-process barfs if default-directory is inaccessible.
160 (if (and default-directory
161 (file-accessible-directory-p default-directory
))
163 (file-name-directory infile
)))
165 ;; Update PREFIX based on the text that we won't read in.
166 (setq prefix
(- beg
(* skip jka-compr-dd-blocksize
))
167 count
(and len
(1+ (/ (+ len prefix
) jka-compr-dd-blocksize
))))
169 (or (memq (call-process
170 jka-compr-shell infile t nil
"-c"
172 "%s %s 2> %s | %s bs=%d skip=%d %s 2> %s"
174 (mapconcat 'identity args
" ")
177 jka-compr-dd-blocksize
179 ;; dd seems to be unreliable about
180 ;; providing the last block. So, always
181 ;; read one more than you think you need.
182 (if count
(format "count=%d" (1+ count
)) "")
184 jka-compr-acceptable-retval-list
)
185 (jka-compr-error prog args infile message err-file
))
186 (jka-compr-delete-temp-file err-file
)))
187 ;; Run the uncompression program directly.
188 ;; We get the whole file and must delete what we don't want.
189 (jka-compr-call-process prog message infile t nil args
))
191 ;; Delete the stuff after what we want, if there is any.
194 (< (+ start prefix len
) (point))
195 (delete-region (+ start prefix len
) (point)))
197 ;; Delete the stuff before what we want.
198 (delete-region start
(+ start prefix
))))
201 (defun jka-compr-call-process (prog message infile output temp args
)
202 ;; call-process barfs if default-directory is inaccessible.
203 (let ((default-directory
204 (if (and default-directory
205 (file-accessible-directory-p default-directory
))
207 (file-name-directory infile
))))
208 (if jka-compr-use-shell
209 (let ((err-file (jka-compr-make-temp-name))
210 (coding-system-for-read (or coding-system-for-read
'undecided
))
211 (coding-system-for-write 'no-conversion
))
214 (call-process jka-compr-shell infile
215 (if (stringp output
) nil output
)
218 (format "%s %s 2> %s %s"
220 (mapconcat 'identity args
" ")
225 jka-compr-acceptable-retval-list
)
226 (jka-compr-error prog args infile message err-file
))
227 (jka-compr-delete-temp-file err-file
)))
230 prog infile
(if (stringp output
) temp output
)
232 (jka-compr-error prog args infile message
))
233 (and (stringp output
)
234 (with-current-buffer temp
235 (write-region (point-min) (point-max) output
)
239 ;; Support for temp files. Much of this was inspired if not lifted
242 (defcustom jka-compr-temp-name-template
243 (expand-file-name "jka-com" temporary-file-directory
)
244 "Prefix added to all temp files created by jka-compr.
245 There should be no more than seven characters after the final `/'."
249 (defun jka-compr-make-temp-name (&optional local-copy
)
250 "This routine will return the name of a new file."
251 (make-temp-file jka-compr-temp-name-template
))
253 (defalias 'jka-compr-delete-temp-file
'delete-file
)
256 (defun jka-compr-write-region (start end file
&optional append visit
)
257 (let* ((filename (expand-file-name file
))
258 (visit-file (if (stringp visit
) (expand-file-name visit
) filename
))
259 (info (jka-compr-get-compression-info visit-file
))
260 (magic (and info
(jka-compr-info-file-magic-bytes info
))))
262 ;; If START is nil, use the whole buffer.
264 (setq start
1 end
(1+ (buffer-size))))
266 ;; If we uncompressed this file when visiting it,
267 ;; then recompress it when writing it
268 ;; even if the contents look compressed already.
269 (if (and jka-compr-really-do-compress
271 (eq end
(1+ (buffer-size))))
275 ;; If the contents to be written out
276 ;; are properly compressed already,
277 ;; don't try to compress them over again.
279 (equal (if (stringp start
)
280 (substring start
0 (min (length start
)
282 (buffer-substring start
284 (+ start
(length magic
)))))
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)))
317 (message "%s %s..." compress-message base-name
))
319 (jka-compr-run-real-handler 'write-region
320 (list start end temp-file t
'dont
))
321 ;; save value used by the real write-region
322 (setq coding-system-used last-coding-system-used
)
324 ;; Here we must read the output of compress program as is
325 ;; without any code conversion.
326 (let ((coding-system-for-read 'no-conversion
))
327 (jka-compr-call-process compress-program
328 (concat compress-message
335 (with-current-buffer temp-buffer
336 (let ((coding-system-for-write 'no-conversion
))
337 (if (memq system-type
'(ms-dos windows-nt
))
338 (setq buffer-file-type t
) )
339 (jka-compr-run-real-handler 'write-region
340 (list (point-min) (point-max)
342 (and append can-append
) 'dont
))
345 (jka-compr-delete-temp-file temp-file
)
349 (message "%s %s...done" compress-message base-name
))
353 (setq buffer-file-name filename
)
354 (setq jka-compr-really-do-compress t
)
355 (set-visited-file-modtime))
357 (setq buffer-file-name visit
)
358 (let ((buffer-file-name filename
))
359 (set-visited-file-modtime))))
361 (and (or (eq visit t
)
364 (message "Wrote %s" visit-file
))
366 ;; ensure `last-coding-system-used' has an appropriate value
367 (setq last-coding-system-used coding-system-used
)
371 (jka-compr-run-real-handler 'write-region
372 (list start end filename append visit
)))))
375 (defun jka-compr-insert-file-contents (file &optional visit beg end replace
)
376 (barf-if-buffer-read-only)
380 (error "Attempt to visit less than an entire file"))
382 (let* ((filename (expand-file-name file
))
383 (info (jka-compr-get-compression-info filename
)))
387 (jka-compr-run-real-handler 'insert-file-contents
388 (list file visit beg end replace
))
390 (let ((uncompress-message (jka-compr-info-uncompress-message info
))
391 (uncompress-program (jka-compr-info-uncompress-program info
))
392 (uncompress-args (jka-compr-info-uncompress-args info
))
393 (base-name (file-name-nondirectory filename
))
396 (jka-compr-run-real-handler 'file-local-copy
(list filename
)))
400 (setq local-file
(or local-copy filename
))
404 (setq buffer-file-name filename
))
406 (unwind-protect ; to make sure local-copy gets deleted
412 (message "%s %s..." uncompress-message base-name
))
414 (condition-case error-code
416 (let ((coding-system-for-read 'no-conversion
))
418 (goto-char (point-min)))
421 (jka-compr-partial-uncompress uncompress-program
422 (concat uncompress-message
430 ;; If visiting, bind off buffer-file-name so that
431 ;; file-locking will not ask whether we should
432 ;; really edit the buffer.
433 (let ((buffer-file-name
434 (if visit nil buffer-file-name
)))
435 (jka-compr-call-process uncompress-program
436 (concat uncompress-message
442 (setq size
(- (point) start
))
444 (delete-region (point) (point-max)))
447 ;; If the file we wanted to uncompress does not exist,
448 ;; handle that according to VISIT as `insert-file-contents'
449 ;; would, maybe signaling the same error it normally would.
450 (if (and (eq (car error-code
) 'file-error
)
451 (eq (nth 3 error-code
) local-file
))
453 (setq notfound error-code
)
455 (cons "Opening input file"
456 (nthcdr 2 error-code
))))
457 ;; If the uncompression program can't be found,
458 ;; signal that as a non-file error
459 ;; so that find-file-noselect-1 won't handle it.
460 (if (and (eq (car error-code
) 'file-error
)
461 (equal (cadr error-code
) "Searching for program"))
462 (error "Uncompression program `%s' not found"
464 (signal (car error-code
) (cdr error-code
))))))
468 (file-exists-p local-copy
)
469 (delete-file local-copy
)))
472 (decode-coding-inserted-region
473 (point) (+ (point) size
)
474 (jka-compr-byte-compiler-base-file-name file
)
475 visit beg end replace
))
481 (setq buffer-file-name filename
)
482 (setq jka-compr-really-do-compress t
)
483 (set-visited-file-modtime)))
487 (message "%s %s...done" uncompress-message base-name
))
493 (cons "Opening input file" (nth 2 notfound
))))
495 ;; This is done in insert-file-contents after we return.
496 ;; That is a little weird, but better to go along with it now
497 ;; than to change it now.
499 ;; ;; Run the functions that insert-file-contents would.
500 ;; (let ((p after-insert-file-functions)
503 ;; (setq insval (funcall (car p) size))
506 ;; (or (integerp insval)
507 ;; (signal 'wrong-type-argument
508 ;; (list 'integerp insval)))
509 ;; (setq size insval)))
510 ;; (setq p (cdr p))))
512 (or (jka-compr-info-compress-program info
)
513 (message "You can't save this buffer because compression program is not defined"))
515 (list filename size
)))))
518 (defun jka-compr-file-local-copy (file)
519 (let* ((filename (expand-file-name file
))
520 (info (jka-compr-get-compression-info filename
)))
524 (let ((uncompress-message (jka-compr-info-uncompress-message info
))
525 (uncompress-program (jka-compr-info-uncompress-program info
))
526 (uncompress-args (jka-compr-info-uncompress-args info
))
527 (base-name (file-name-nondirectory filename
))
529 (jka-compr-run-real-handler 'file-local-copy
(list filename
)))
530 (temp-file (jka-compr-make-temp-name t
))
531 (temp-buffer (get-buffer-create " *jka-compr-flc-temp*"))
534 (setq local-file
(or local-copy filename
))
538 (with-current-buffer temp-buffer
542 (message "%s %s..." uncompress-message base-name
))
544 ;; Here we must read the output of uncompress program
545 ;; and write it to TEMP-FILE without any code
546 ;; conversion. An appropriate code conversion (if
547 ;; necessary) is done by the later I/O operation
549 (let ((coding-system-for-read 'no-conversion
)
550 (coding-system-for-write 'no-conversion
))
552 (jka-compr-call-process uncompress-program
553 (concat uncompress-message
562 (message "%s %s...done" uncompress-message base-name
))
565 (point-min) (point-max) temp-file nil
'dont
)))
569 (file-exists-p local-copy
)
570 (delete-file local-copy
))
572 (kill-buffer temp-buffer
))
576 (jka-compr-run-real-handler 'file-local-copy
(list filename
)))))
579 ;; Support for loading compressed files.
580 (defun jka-compr-load (file &optional noerror nomessage nosuffix
)
581 "Documented as original."
583 (let* ((local-copy (jka-compr-file-local-copy file
))
584 (load-file (or local-copy file
)))
588 (let (inhibit-file-name-operation
589 inhibit-file-name-handlers
)
591 (message "Loading %s..." file
))
593 (let ((load-force-doc-strings t
))
594 (load load-file noerror t t
))
596 (message "Loading %s...done." file
))
597 ;; Fix up the load history to point at the right library.
598 (let ((l (assoc load-file load-history
)))
599 ;; Remove .gz and .elc?.
600 (while (file-name-extension file
)
601 (setq file
(file-name-sans-extension file
)))
604 (jka-compr-delete-temp-file local-copy
))
608 (defun jka-compr-byte-compiler-base-file-name (file)
609 (let ((info (jka-compr-get-compression-info file
)))
610 (if (and info
(jka-compr-info-strip-extension info
))
612 (substring file
0 (string-match (jka-compr-info-regexp info
) file
)))
615 (put 'write-region
'jka-compr
'jka-compr-write-region
)
616 (put 'insert-file-contents
'jka-compr
'jka-compr-insert-file-contents
)
617 (put 'file-local-copy
'jka-compr
'jka-compr-file-local-copy
)
618 (put 'load
'jka-compr
'jka-compr-load
)
619 (put 'byte-compiler-base-file-name
'jka-compr
620 'jka-compr-byte-compiler-base-file-name
)
623 (defvar jka-compr-inhibit nil
624 "Non-nil means inhibit automatic uncompression temporarily.
625 Lisp programs can bind this to t to do that.
626 It is not recommended to set this variable permanently to anything but nil.")
629 (defun jka-compr-handler (operation &rest args
)
631 (let ((jka-op (get operation
'jka-compr
)))
632 (if (and jka-op
(not jka-compr-inhibit
))
634 (jka-compr-run-real-handler operation args
)))))
636 ;; If we are given an operation that we don't handle,
637 ;; call the Emacs primitive for that operation,
638 ;; and manipulate the inhibit variables
639 ;; to prevent the primitive from calling our handler again.
640 (defun jka-compr-run-real-handler (operation args
)
641 (let ((inhibit-file-name-handlers
642 (cons 'jka-compr-handler
643 (and (eq inhibit-file-name-operation operation
)
644 inhibit-file-name-handlers
)))
645 (inhibit-file-name-operation operation
))
646 (apply operation args
)))
649 (defun jka-compr-uninstall ()
650 "Uninstall jka-compr.
651 This removes the entries in `file-name-handler-alist' and `auto-mode-alist'
652 and `inhibit-first-line-modes-suffixes' that were added
653 by `jka-compr-installed'."
654 ;; Delete from inhibit-first-line-modes-suffixes
655 ;; what jka-compr-install added.
657 (function (lambda (x)
658 (and (jka-compr-info-strip-extension x
)
659 (setq inhibit-first-line-modes-suffixes
660 (delete (jka-compr-info-regexp x
)
661 inhibit-first-line-modes-suffixes
)))))
662 jka-compr-compression-info-list--internal
)
664 (let* ((fnha (cons nil file-name-handler-alist
))
668 (if (eq (cdr (car (cdr last
))) 'jka-compr-handler
)
669 (setcdr last
(cdr (cdr last
)))
670 (setq last
(cdr last
))))
672 (setq file-name-handler-alist
(cdr fnha
)))
674 (let* ((ama (cons nil auto-mode-alist
))
679 (setq entry
(car (cdr last
)))
680 (if (or (member entry jka-compr-mode-alist-additions--internal
)
681 (and (consp (cdr entry
))
682 (eq (nth 2 entry
) 'jka-compr
)))
683 (setcdr last
(cdr (cdr last
)))
684 (setq last
(cdr last
))))
686 (setq auto-mode-alist
(cdr ama
)))
688 (while jka-compr-added-to-file-coding-system-alist
689 (setq file-coding-system-alist
690 (delq (car (member (pop jka-compr-added-to-file-coding-system-alist
)
691 file-coding-system-alist
))
692 file-coding-system-alist
)))
694 ;; Remove the suffixes that were added by jka-compr.
695 (dolist (suff jka-compr-load-suffixes--internal
)
696 (setq load-file-rep-suffixes
(delete suff load-file-rep-suffixes
)))
698 (setq jka-compr-compression-info-list--internal nil
699 jka-compr-mode-alist-additions--internal nil
700 jka-compr-load-suffixes--internal nil
))
704 ;; arch-tag: 3f15b630-e9a7-46c4-a22a-94afdde86ebc
705 ;;; jka-compr.el ends here