*** empty log message ***
[emacs.git] / lisp / jka-compr.el
blob3d14089349fc0a77943870ce82992ff5e314f0a8
1 ;;; jka-compr.el --- reading/writing/loading compressed files
3 ;; Copyright (C) 1993, 1994, 1995, 1997, 1999, 2000, 2003 Free Software Foundation, Inc.
5 ;; Author: jka@ece.cmu.edu (Jay K. Adams)
6 ;; Maintainer: FSF
7 ;; Keywords: data
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 2, or (at your option)
14 ;; 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; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
26 ;;; Commentary:
28 ;; This package implements low-level support for reading, writing,
29 ;; and loading compressed files. It hooks into the low-level file
30 ;; I/O functions (including write-region and insert-file-contents) so
31 ;; that they automatically compress or uncompress a file if the file
32 ;; appears to need it (based on the extension of the file name).
33 ;; Packages like Rmail, VM, GNUS, and Info should be able to work
34 ;; with compressed files without modification.
37 ;; INSTRUCTIONS:
39 ;; To use jka-compr, invoke the command `auto-compression-mode' (which
40 ;; see), or customize the variable of the same name. Its operation
41 ;; should be transparent to the user (except for messages appearing when
42 ;; a file is being compressed or uncompressed).
44 ;; The variable, jka-compr-compression-info-list can be used to
45 ;; customize jka-compr to work with other compression programs.
46 ;; The default value of this variable allows jka-compr to work with
47 ;; Unix compress and gzip.
49 ;; If you are concerned about the stderr output of gzip and other
50 ;; compression/decompression programs showing up in your buffers, you
51 ;; should set the discard-error flag in the compression-info-list.
52 ;; This will cause the stderr of all programs to be discarded.
53 ;; However, it also causes emacs to call compression/uncompression
54 ;; programs through a shell (which is specified by jka-compr-shell).
55 ;; This may be a drag if, on your system, starting up a shell is
56 ;; slow.
58 ;; If you don't want messages about compressing and decompressing
59 ;; to show up in the echo area, you can set the compress-name and
60 ;; decompress-name fields of the jka-compr-compression-info-list to
61 ;; nil.
64 ;; APPLICATION NOTES:
66 ;; crypt++
67 ;; jka-compr can coexist with crypt++ if you take all the decompression
68 ;; entries out of the crypt-encoding-list. Clearly problems will arise if
69 ;; you have two programs trying to compress/decompress files. jka-compr
70 ;; will not "work with" crypt++ in the following sense: you won't be able to
71 ;; decode encrypted compressed files--that is, files that have been
72 ;; compressed then encrypted (in that order). Theoretically, crypt++ and
73 ;; jka-compr could properly handle a file that has been encrypted then
74 ;; compressed, but there is little point in trying to compress an encrypted
75 ;; file.
79 ;; ACKNOWLEDGMENTS
81 ;; jka-compr is a V19 adaptation of jka-compr for V18 of Emacs. Many people
82 ;; have made helpful suggestions, reported bugs, and even fixed bugs in
83 ;; jka-compr. I recall the following people as being particularly helpful.
85 ;; Jean-loup Gailly
86 ;; David Hughes
87 ;; Richard Pieri
88 ;; Daniel Quinlan
89 ;; Chris P. Ross
90 ;; Rick Sladkey
92 ;; Andy Norman's ange-ftp was the inspiration for the original jka-compr for
93 ;; Version 18 of Emacs.
95 ;; After I had made progress on the original jka-compr for V18, I learned of a
96 ;; package written by Kazushi Jam Marukawa, called jam-zcat, that did exactly
97 ;; what I was trying to do. I looked over the jam-zcat source code and
98 ;; probably got some ideas from it.
101 ;;; Code:
103 (defgroup compression nil
104 "Data compression utilities"
105 :group 'data)
107 (defgroup jka-compr nil
108 "jka-compr customization"
109 :group 'compression)
112 (defcustom jka-compr-shell "sh"
113 "*Shell to be used for calling compression programs.
114 The value of this variable only matters if you want to discard the
115 stderr of a compression/decompression program (see the documentation
116 for `jka-compr-compression-info-list')."
117 :type 'string
118 :group 'jka-compr)
120 (defvar jka-compr-use-shell
121 (not (memq system-type '(ms-dos windows-nt))))
123 ;;; I have this defined so that .Z files are assumed to be in unix
124 ;;; compress format; and .gz files, in gzip format, and .bz2 files in bzip fmt.
125 (defcustom jka-compr-compression-info-list
126 ;;[regexp
127 ;; compr-message compr-prog compr-args
128 ;; uncomp-message uncomp-prog uncomp-args
129 ;; can-append auto-mode-flag strip-extension-flag file-magic-bytes]
130 '(["\\.Z\\(~\\|\\.~[0-9]+~\\)?\\'"
131 "compressing" "compress" ("-c")
132 "uncompressing" "uncompress" ("-c")
133 nil t "\037\235"]
134 ;; Formerly, these had an additional arg "-c", but that fails with
135 ;; "Version 0.1pl2, 29-Aug-97." (RedHat 5.1 GNU/Linux) and
136 ;; "Version 0.9.0b, 9-Sept-98".
137 ["\\.bz2\\'"
138 "bzip2ing" "bzip2" nil
139 "bunzip2ing" "bzip2" ("-d")
140 nil t "BZh"]
141 ["\\.tgz\\'"
142 "zipping" "gzip" ("-c" "-q")
143 "unzipping" "gzip" ("-c" "-q" "-d")
144 t nil "\037\213"]
145 ["\\.g?z\\(~\\|\\.~[0-9]+~\\)?\\'"
146 "zipping" "gzip" ("-c" "-q")
147 "unzipping" "gzip" ("-c" "-q" "-d")
148 t t "\037\213"])
150 "List of vectors that describe available compression techniques.
151 Each element, which describes a compression technique, is a vector of
152 the form [REGEXP COMPRESS-MSG COMPRESS-PROGRAM COMPRESS-ARGS
153 UNCOMPRESS-MSG UNCOMPRESS-PROGRAM UNCOMPRESS-ARGS
154 APPEND-FLAG STRIP-EXTENSION-FLAG FILE-MAGIC-CHARS], where:
156 regexp is a regexp that matches filenames that are
157 compressed with this format
159 compress-msg is the message to issue to the user when doing this
160 type of compression (nil means no message)
162 compress-program is a program that performs this compression
164 compress-args is a list of args to pass to the compress program
166 uncompress-msg is the message to issue to the user when doing this
167 type of uncompression (nil means no message)
169 uncompress-program is a program that performs this compression
171 uncompress-args is a list of args to pass to the uncompress program
173 append-flag is non-nil if this compression technique can be
174 appended
176 strip-extension-flag non-nil means strip the regexp from file names
177 before attempting to set the mode.
179 file-magic-chars is a string of characters that you would find
180 at the beginning of a file compressed in this way.
182 Because of the way `call-process' is defined, discarding the stderr output of
183 a program adds the overhead of starting a shell each time the program is
184 invoked."
185 :type '(repeat (vector regexp
186 (choice :tag "Compress Message"
187 (string :format "%v")
188 (const :tag "No Message" nil))
189 (string :tag "Compress Program")
190 (repeat :tag "Compress Arguments" string)
191 (choice :tag "Uncompress Message"
192 (string :format "%v")
193 (const :tag "No Message" nil))
194 (string :tag "Uncompress Program")
195 (repeat :tag "Uncompress Arguments" string)
196 (boolean :tag "Append")
197 (boolean :tag "Strip Extension")
198 (string :tag "Magic Bytes")))
199 :group 'jka-compr)
201 (defcustom jka-compr-mode-alist-additions
202 (list (cons "\\.tgz\\'" 'tar-mode))
203 "A list of pairs to add to `auto-mode-alist' when jka-compr is installed."
204 :type '(repeat (cons string symbol))
205 :group 'jka-compr)
207 (defcustom jka-compr-load-suffixes '(".gz")
208 "List of suffixes to try when loading files."
209 :type '(repeat string)
210 :group 'jka-compr)
212 ;; List of all the elements we actually added to file-coding-system-alist.
213 (defvar jka-compr-added-to-file-coding-system-alist nil)
215 (defvar jka-compr-file-name-handler-entry
217 "The entry in `file-name-handler-alist' used by the jka-compr I/O functions.")
219 (defvar jka-compr-really-do-compress nil
220 "Non-nil in a buffer whose visited file was uncompressed on visiting it.")
221 (put 'jka-compr-really-do-compress 'permanent-local t)
223 ;;; Functions for accessing the return value of jka-compr-get-compression-info
224 (defun jka-compr-info-regexp (info) (aref info 0))
225 (defun jka-compr-info-compress-message (info) (aref info 1))
226 (defun jka-compr-info-compress-program (info) (aref info 2))
227 (defun jka-compr-info-compress-args (info) (aref info 3))
228 (defun jka-compr-info-uncompress-message (info) (aref info 4))
229 (defun jka-compr-info-uncompress-program (info) (aref info 5))
230 (defun jka-compr-info-uncompress-args (info) (aref info 6))
231 (defun jka-compr-info-can-append (info) (aref info 7))
232 (defun jka-compr-info-strip-extension (info) (aref info 8))
233 (defun jka-compr-info-file-magic-bytes (info) (aref info 9))
236 (defun jka-compr-get-compression-info (filename)
237 "Return information about the compression scheme of FILENAME.
238 The determination as to which compression scheme, if any, to use is
239 based on the filename itself and `jka-compr-compression-info-list'."
240 (catch 'compression-info
241 (let ((case-fold-search nil))
242 (mapcar
243 (function (lambda (x)
244 (and (string-match (jka-compr-info-regexp x) filename)
245 (throw 'compression-info x))))
246 jka-compr-compression-info-list)
247 nil)))
250 (put 'compression-error 'error-conditions '(compression-error file-error error))
253 (defvar jka-compr-acceptable-retval-list '(0 2 141))
256 (defun jka-compr-error (prog args infile message &optional errfile)
258 (let ((errbuf (get-buffer-create " *jka-compr-error*"))
259 (curbuf (current-buffer)))
260 (with-current-buffer errbuf
261 (widen) (erase-buffer)
262 (insert (format "Error while executing \"%s %s < %s\"\n\n"
263 prog
264 (mapconcat 'identity args " ")
265 infile))
267 (and errfile
268 (insert-file-contents errfile)))
269 (display-buffer errbuf))
271 (signal 'compression-error
272 (list "Opening input file" (format "error %s" message) infile)))
275 (defcustom jka-compr-dd-program "/bin/dd"
276 "How to invoke `dd'."
277 :type 'string
278 :group 'jka-compr)
281 (defvar jka-compr-dd-blocksize 256)
284 (defun jka-compr-partial-uncompress (prog message args infile beg len)
285 "Call program PROG with ARGS args taking input from INFILE.
286 Fourth and fifth args, BEG and LEN, specify which part of the output
287 to keep: LEN chars starting BEG chars from the beginning."
288 (let ((start (point))
289 (prefix beg))
290 (if (and jka-compr-use-shell jka-compr-dd-program)
291 ;; Put the uncompression output through dd
292 ;; to discard the part we don't want.
293 (let ((skip (/ beg jka-compr-dd-blocksize))
294 (err-file (jka-compr-make-temp-name))
295 count)
296 ;; Update PREFIX based on the text that we won't read in.
297 (setq prefix (- beg (* skip jka-compr-dd-blocksize))
298 count (and len (1+ (/ (+ len prefix) jka-compr-dd-blocksize))))
299 (unwind-protect
300 (or (memq (call-process
301 jka-compr-shell infile t nil "-c"
302 (format
303 "%s %s 2> %s | %s bs=%d skip=%d %s 2> %s"
304 prog
305 (mapconcat 'identity args " ")
306 err-file
307 jka-compr-dd-program
308 jka-compr-dd-blocksize
309 skip
310 ;; dd seems to be unreliable about
311 ;; providing the last block. So, always
312 ;; read one more than you think you need.
313 (if count (format "count=%d" (1+ count)) "")
314 null-device))
315 jka-compr-acceptable-retval-list)
316 (jka-compr-error prog args infile message err-file))
317 (jka-compr-delete-temp-file err-file)))
318 ;; Run the uncompression program directly.
319 ;; We get the whole file and must delete what we don't want.
320 (jka-compr-call-process prog message infile t nil args))
322 ;; Delete the stuff after what we want, if there is any.
323 (and
325 (< (+ start prefix len) (point))
326 (delete-region (+ start prefix len) (point)))
328 ;; Delete the stuff before what we want.
329 (delete-region start (+ start prefix))))
332 (defun jka-compr-call-process (prog message infile output temp args)
333 (if jka-compr-use-shell
335 (let ((err-file (jka-compr-make-temp-name))
336 (coding-system-for-read (or coding-system-for-read 'undecided))
337 (coding-system-for-write 'no-conversion))
339 (unwind-protect
341 (or (memq
342 (call-process jka-compr-shell infile
343 (if (stringp output) nil output)
345 "-c"
346 (format "%s %s 2> %s %s"
347 prog
348 (mapconcat 'identity args " ")
349 err-file
350 (if (stringp output)
351 (concat "> " output)
352 "")))
353 jka-compr-acceptable-retval-list)
355 (jka-compr-error prog args infile message err-file))
357 (jka-compr-delete-temp-file err-file)))
359 (or (zerop
360 (apply 'call-process
361 prog
362 infile
363 (if (stringp output) temp output)
365 args))
366 (jka-compr-error prog args infile message))
368 (and (stringp output)
369 (with-current-buffer temp
370 (write-region (point-min) (point-max) output)
371 (erase-buffer)))))
374 ;;; Support for temp files. Much of this was inspired if not lifted
375 ;;; from ange-ftp.
377 (defcustom jka-compr-temp-name-template
378 (expand-file-name "jka-com" temporary-file-directory)
379 "Prefix added to all temp files created by jka-compr.
380 There should be no more than seven characters after the final `/'."
381 :type 'string
382 :group 'jka-compr)
384 (defun jka-compr-make-temp-name (&optional local-copy)
385 "This routine will return the name of a new file."
386 (make-temp-file jka-compr-temp-name-template))
388 (defalias 'jka-compr-delete-temp-file 'delete-file)
391 (defun jka-compr-write-region (start end file &optional append visit)
392 (let* ((filename (expand-file-name file))
393 (visit-file (if (stringp visit) (expand-file-name visit) filename))
394 (info (jka-compr-get-compression-info visit-file))
395 (magic (and info (jka-compr-info-file-magic-bytes info))))
397 ;; If START is nil, use the whole buffer.
398 (if (null start)
399 (setq start 1 end (1+ (buffer-size))))
401 ;; If we uncompressed this file when visiting it,
402 ;; then recompress it when writing it
403 ;; even if the contents look compressed already.
404 (if (and jka-compr-really-do-compress
405 (eq start 1)
406 (eq end (1+ (buffer-size))))
407 (setq magic nil))
409 (if (and info
410 ;; If the contents to be written out
411 ;; are properly compressed already,
412 ;; don't try to compress them over again.
413 (not (and magic
414 (equal (if (stringp start)
415 (substring start 0 (min (length start)
416 (length magic)))
417 (buffer-substring start
418 (min end
419 (+ start (length magic)))))
420 magic))))
421 (let ((can-append (jka-compr-info-can-append info))
422 (compress-program (jka-compr-info-compress-program info))
423 (compress-message (jka-compr-info-compress-message info))
424 (uncompress-program (jka-compr-info-uncompress-program info))
425 (uncompress-message (jka-compr-info-uncompress-message info))
426 (compress-args (jka-compr-info-compress-args info))
427 (uncompress-args (jka-compr-info-uncompress-args info))
428 (base-name (file-name-nondirectory visit-file))
429 temp-file temp-buffer
430 ;; we need to leave `last-coding-system-used' set to its
431 ;; value after calling write-region the first time, so
432 ;; that `basic-save-buffer' sees the right value.
433 (coding-system-used last-coding-system-used))
435 (setq temp-buffer (get-buffer-create " *jka-compr-wr-temp*"))
436 (with-current-buffer temp-buffer
437 (widen) (erase-buffer))
439 (if (and append
440 (not can-append)
441 (file-exists-p filename))
443 (let* ((local-copy (file-local-copy filename))
444 (local-file (or local-copy filename)))
446 (setq temp-file local-file))
448 (setq temp-file (jka-compr-make-temp-name)))
450 (and
451 compress-message
452 (message "%s %s..." compress-message base-name))
454 (jka-compr-run-real-handler 'write-region
455 (list start end temp-file t 'dont))
456 ;; save value used by the real write-region
457 (setq coding-system-used last-coding-system-used)
459 ;; Here we must read the output of compress program as is
460 ;; without any code conversion.
461 (let ((coding-system-for-read 'no-conversion))
462 (jka-compr-call-process compress-program
463 (concat compress-message
464 " " base-name)
465 temp-file
466 temp-buffer
468 compress-args))
470 (with-current-buffer temp-buffer
471 (let ((coding-system-for-write 'no-conversion))
472 (if (memq system-type '(ms-dos windows-nt))
473 (setq buffer-file-type t) )
474 (jka-compr-run-real-handler 'write-region
475 (list (point-min) (point-max)
476 filename
477 (and append can-append) 'dont))
478 (erase-buffer)) )
480 (jka-compr-delete-temp-file temp-file)
482 (and
483 compress-message
484 (message "%s %s...done" compress-message base-name))
486 (cond
487 ((eq visit t)
488 (setq buffer-file-name filename)
489 (setq jka-compr-really-do-compress t)
490 (set-visited-file-modtime))
491 ((stringp visit)
492 (setq buffer-file-name visit)
493 (let ((buffer-file-name filename))
494 (set-visited-file-modtime))))
496 (and (or (eq visit t)
497 (eq visit nil)
498 (stringp visit))
499 (message "Wrote %s" visit-file))
501 ;; ensure `last-coding-system-used' has an appropriate value
502 (setq last-coding-system-used coding-system-used)
504 nil)
506 (jka-compr-run-real-handler 'write-region
507 (list start end filename append visit)))))
510 (defun jka-compr-insert-file-contents (file &optional visit beg end replace)
511 (barf-if-buffer-read-only)
513 (and (or beg end)
514 visit
515 (error "Attempt to visit less than an entire file"))
517 (let* ((filename (expand-file-name file))
518 (info (jka-compr-get-compression-info filename)))
520 (if info
522 (let ((uncompress-message (jka-compr-info-uncompress-message info))
523 (uncompress-program (jka-compr-info-uncompress-program info))
524 (uncompress-args (jka-compr-info-uncompress-args info))
525 (base-name (file-name-nondirectory filename))
526 (notfound nil)
527 (local-copy
528 (jka-compr-run-real-handler 'file-local-copy (list filename)))
529 local-file
530 size start)
532 (setq local-file (or local-copy filename))
534 (and
535 visit
536 (setq buffer-file-name filename))
538 (unwind-protect ; to make sure local-copy gets deleted
540 (progn
542 (and
543 uncompress-message
544 (message "%s %s..." uncompress-message base-name))
546 (condition-case error-code
548 (let ((coding-system-for-read 'no-conversion))
549 (if replace
550 (goto-char (point-min)))
551 (setq start (point))
552 (if (or beg end)
553 (jka-compr-partial-uncompress uncompress-program
554 (concat uncompress-message
555 " " base-name)
556 uncompress-args
557 local-file
558 (or beg 0)
559 (if (and beg end)
560 (- end beg)
561 end))
562 ;; If visiting, bind off buffer-file-name so that
563 ;; file-locking will not ask whether we should
564 ;; really edit the buffer.
565 (let ((buffer-file-name
566 (if visit nil buffer-file-name)))
567 (jka-compr-call-process uncompress-program
568 (concat uncompress-message
569 " " base-name)
570 local-file
573 uncompress-args)))
574 (setq size (- (point) start))
575 (if replace
576 (delete-region (point) (point-max)))
577 (goto-char start))
578 (error
579 (if (and (eq (car error-code) 'file-error)
580 (eq (nth 3 error-code) local-file))
581 (if visit
582 (setq notfound error-code)
583 (signal 'file-error
584 (cons "Opening input file"
585 (nthcdr 2 error-code))))
586 (signal (car error-code) (cdr error-code))))))
588 (and
589 local-copy
590 (file-exists-p local-copy)
591 (delete-file local-copy)))
593 (decode-coding-inserted-region
594 (point) (+ (point) size)
595 (jka-compr-byte-compiler-base-file-name file)
596 visit beg end replace)
598 (and
599 visit
600 (progn
601 (unlock-buffer)
602 (setq buffer-file-name filename)
603 (setq jka-compr-really-do-compress t)
604 (set-visited-file-modtime)))
606 (and
607 uncompress-message
608 (message "%s %s...done" uncompress-message base-name))
610 (and
611 visit
612 notfound
613 (signal 'file-error
614 (cons "Opening input file" (nth 2 notfound))))
616 ;; This is done in insert-file-contents after we return.
617 ;; That is a little weird, but better to go along with it now
618 ;; than to change it now.
620 ;;; ;; Run the functions that insert-file-contents would.
621 ;;; (let ((p after-insert-file-functions)
622 ;;; (insval size))
623 ;;; (while p
624 ;;; (setq insval (funcall (car p) size))
625 ;;; (if insval
626 ;;; (progn
627 ;;; (or (integerp insval)
628 ;;; (signal 'wrong-type-argument
629 ;;; (list 'integerp insval)))
630 ;;; (setq size insval)))
631 ;;; (setq p (cdr p))))
633 (list filename size))
635 (jka-compr-run-real-handler 'insert-file-contents
636 (list file visit beg end replace)))))
639 (defun jka-compr-file-local-copy (file)
640 (let* ((filename (expand-file-name file))
641 (info (jka-compr-get-compression-info filename)))
643 (if info
645 (let ((uncompress-message (jka-compr-info-uncompress-message info))
646 (uncompress-program (jka-compr-info-uncompress-program info))
647 (uncompress-args (jka-compr-info-uncompress-args info))
648 (base-name (file-name-nondirectory filename))
649 (local-copy
650 (jka-compr-run-real-handler 'file-local-copy (list filename)))
651 (temp-file (jka-compr-make-temp-name t))
652 (temp-buffer (get-buffer-create " *jka-compr-flc-temp*"))
653 (notfound nil)
654 local-file)
656 (setq local-file (or local-copy filename))
658 (unwind-protect
660 (with-current-buffer temp-buffer
662 (and
663 uncompress-message
664 (message "%s %s..." uncompress-message base-name))
666 ;; Here we must read the output of uncompress program
667 ;; and write it to TEMP-FILE without any code
668 ;; conversion. An appropriate code conversion (if
669 ;; necessary) is done by the later I/O operation
670 ;; (e.g. load).
671 (let ((coding-system-for-read 'no-conversion)
672 (coding-system-for-write 'no-conversion))
674 (jka-compr-call-process uncompress-program
675 (concat uncompress-message
676 " " base-name)
677 local-file
680 uncompress-args)
682 (and
683 uncompress-message
684 (message "%s %s...done" uncompress-message base-name))
686 (write-region
687 (point-min) (point-max) temp-file nil 'dont)))
689 (and
690 local-copy
691 (file-exists-p local-copy)
692 (delete-file local-copy))
694 (kill-buffer temp-buffer))
696 temp-file)
698 (jka-compr-run-real-handler 'file-local-copy (list filename)))))
701 ;;; Support for loading compressed files.
702 (defun jka-compr-load (file &optional noerror nomessage nosuffix)
703 "Documented as original."
705 (let* ((local-copy (jka-compr-file-local-copy file))
706 (load-file (or local-copy file)))
708 (unwind-protect
710 (let (inhibit-file-name-operation
711 inhibit-file-name-handlers)
712 (or nomessage
713 (message "Loading %s..." file))
715 (let ((load-force-doc-strings t))
716 (load load-file noerror t t))
717 (or nomessage
718 (message "Loading %s...done." file))
719 ;; Fix up the load history to point at the right library.
720 (let ((l (assoc load-file load-history)))
721 ;; Remove .gz and .elc?.
722 (while (file-name-extension file)
723 (setq file (file-name-sans-extension file)))
724 (setcar l file)))
726 (jka-compr-delete-temp-file local-copy))
730 (defun jka-compr-byte-compiler-base-file-name (file)
731 (let ((info (jka-compr-get-compression-info file)))
732 (if (and info (jka-compr-info-strip-extension info))
733 (save-match-data
734 (substring file 0 (string-match (jka-compr-info-regexp info) file)))
735 file)))
737 (put 'write-region 'jka-compr 'jka-compr-write-region)
738 (put 'insert-file-contents 'jka-compr 'jka-compr-insert-file-contents)
739 (put 'file-local-copy 'jka-compr 'jka-compr-file-local-copy)
740 (put 'load 'jka-compr 'jka-compr-load)
741 (put 'byte-compiler-base-file-name 'jka-compr
742 'jka-compr-byte-compiler-base-file-name)
744 (defvar jka-compr-inhibit nil
745 "Non-nil means inhibit automatic uncompression temporarily.
746 Lisp programs can bind this to t to do that.
747 It is not recommended to set this variable permanently to anything but nil.")
749 (put 'jka-compr-handler 'safe-magic t)
750 (defun jka-compr-handler (operation &rest args)
751 (save-match-data
752 (let ((jka-op (get operation 'jka-compr)))
753 (if (and jka-op (not jka-compr-inhibit))
754 (apply jka-op args)
755 (jka-compr-run-real-handler operation args)))))
757 ;; If we are given an operation that we don't handle,
758 ;; call the Emacs primitive for that operation,
759 ;; and manipulate the inhibit variables
760 ;; to prevent the primitive from calling our handler again.
761 (defun jka-compr-run-real-handler (operation args)
762 (let ((inhibit-file-name-handlers
763 (cons 'jka-compr-handler
764 (and (eq inhibit-file-name-operation operation)
765 inhibit-file-name-handlers)))
766 (inhibit-file-name-operation operation))
767 (apply operation args)))
770 (defun jka-compr-build-file-regexp ()
771 (mapconcat
772 'jka-compr-info-regexp
773 jka-compr-compression-info-list
774 "\\|"))
777 (defun jka-compr-install ()
778 "Install jka-compr.
779 This adds entries to `file-name-handler-alist' and `auto-mode-alist'
780 and `inhibit-first-line-modes-suffixes'."
782 (setq jka-compr-file-name-handler-entry
783 (cons (jka-compr-build-file-regexp) 'jka-compr-handler))
785 (setq file-name-handler-alist (cons jka-compr-file-name-handler-entry
786 file-name-handler-alist))
788 (setq jka-compr-added-to-file-coding-system-alist nil)
790 (mapcar
791 (function (lambda (x)
792 ;; Don't do multibyte encoding on the compressed files.
793 (let ((elt (cons (jka-compr-info-regexp x)
794 '(no-conversion . no-conversion))))
795 (setq file-coding-system-alist
796 (cons elt file-coding-system-alist))
797 (setq jka-compr-added-to-file-coding-system-alist
798 (cons elt jka-compr-added-to-file-coding-system-alist)))
800 (and (jka-compr-info-strip-extension x)
801 ;; Make entries in auto-mode-alist so that modes
802 ;; are chosen right according to the file names
803 ;; sans `.gz'.
804 (setq auto-mode-alist
805 (cons (list (jka-compr-info-regexp x)
806 nil 'jka-compr)
807 auto-mode-alist))
808 ;; Also add these regexps to
809 ;; inhibit-first-line-modes-suffixes, so that a
810 ;; -*- line in the first file of a compressed tar
811 ;; file doesn't override tar-mode.
812 (setq inhibit-first-line-modes-suffixes
813 (cons (jka-compr-info-regexp x)
814 inhibit-first-line-modes-suffixes)))))
815 jka-compr-compression-info-list)
816 (setq auto-mode-alist
817 (append auto-mode-alist jka-compr-mode-alist-additions))
819 ;; Make sure that (load "foo") will find /bla/foo.el.gz.
820 (setq load-suffixes
821 (apply 'append
822 (mapcar (lambda (suffix)
823 (cons suffix
824 (mapcar (lambda (ext) (concat suffix ext))
825 jka-compr-load-suffixes)))
826 load-suffixes))))
829 (defun jka-compr-uninstall ()
830 "Uninstall jka-compr.
831 This removes the entries in `file-name-handler-alist' and `auto-mode-alist'
832 and `inhibit-first-line-modes-suffixes' that were added
833 by `jka-compr-installed'."
834 ;; Delete from inhibit-first-line-modes-suffixes
835 ;; what jka-compr-install added.
836 (mapcar
837 (function (lambda (x)
838 (and (jka-compr-info-strip-extension x)
839 (setq inhibit-first-line-modes-suffixes
840 (delete (jka-compr-info-regexp x)
841 inhibit-first-line-modes-suffixes)))))
842 jka-compr-compression-info-list)
844 (let* ((fnha (cons nil file-name-handler-alist))
845 (last fnha))
847 (while (cdr last)
848 (if (eq (cdr (car (cdr last))) 'jka-compr-handler)
849 (setcdr last (cdr (cdr last)))
850 (setq last (cdr last))))
852 (setq file-name-handler-alist (cdr fnha)))
854 (let* ((ama (cons nil auto-mode-alist))
855 (last ama)
856 entry)
858 (while (cdr last)
859 (setq entry (car (cdr last)))
860 (if (or (member entry jka-compr-mode-alist-additions)
861 (and (consp (cdr entry))
862 (eq (nth 2 entry) 'jka-compr)))
863 (setcdr last (cdr (cdr last)))
864 (setq last (cdr last))))
866 (setq auto-mode-alist (cdr ama)))
868 (let* ((ama (cons nil file-coding-system-alist))
869 (last ama)
870 entry)
872 (while (cdr last)
873 (setq entry (car (cdr last)))
874 (if (member entry jka-compr-added-to-file-coding-system-alist)
875 (setcdr last (cdr (cdr last)))
876 (setq last (cdr last))))
878 (setq file-coding-system-alist (cdr ama)))
880 ;; Remove the suffixes that were added by jka-compr.
881 (let ((suffixes nil)
882 (re (jka-compr-build-file-regexp)))
883 (dolist (suffix load-suffixes)
884 (unless (string-match re suffix)
885 (push suffix suffixes)))
886 (setq load-suffixes (nreverse suffixes))))
889 (defun jka-compr-installed-p ()
890 "Return non-nil if jka-compr is installed.
891 The return value is the entry in `file-name-handler-alist' for jka-compr."
893 (let ((fnha file-name-handler-alist)
894 (installed nil))
896 (while (and fnha (not installed))
897 (and (eq (cdr (car fnha)) 'jka-compr-handler)
898 (setq installed (car fnha)))
899 (setq fnha (cdr fnha)))
901 installed))
904 ;;; Add the file I/O hook if it does not already exist.
905 ;;; Make sure that jka-compr-file-name-handler-entry is eq to the
906 ;;; entry for jka-compr in file-name-handler-alist.
907 (and (jka-compr-installed-p)
908 (jka-compr-uninstall))
911 ;;;###autoload
912 (define-minor-mode auto-compression-mode
913 "Toggle automatic file compression and uncompression.
914 With prefix argument ARG, turn auto compression on if positive, else off.
915 Returns the new status of auto compression (non-nil means on)."
916 :global t :group 'jka-compr
917 (let* ((installed (jka-compr-installed-p))
918 (flag auto-compression-mode))
919 (cond
920 ((and flag installed) t) ; already installed
921 ((and (not flag) (not installed)) nil) ; already not installed
922 (flag (jka-compr-install))
923 (t (jka-compr-uninstall)))))
926 ;;;###autoload
927 (defmacro with-auto-compression-mode (&rest body)
928 "Evalute BODY with automatic file compression and uncompression enabled."
929 (let ((already-installed (make-symbol "already-installed")))
930 `(let ((,already-installed (jka-compr-installed-p)))
931 (unwind-protect
932 (progn
933 (unless ,already-installed
934 (jka-compr-install))
935 ,@body)
936 (unless ,already-installed
937 (jka-compr-uninstall))))))
938 (put 'with-auto-compression-mode 'lisp-indent-function 0)
941 (provide 'jka-compr)
943 ;;; jka-compr.el ends here