(Fmap_charset_chars): Fix docstring.
[bpt/emacs.git] / lisp / jka-compr.el
1 ;;; jka-compr.el --- reading/writing/loading compressed files
2
3 ;; Copyright (C) 1993, 1994, 1995, 1997, 1999, 2000 Free Software Foundation, Inc.
4
5 ;; Author: jka@ece.cmu.edu (Jay K. Adams)
6 ;; Maintainer: FSF
7 ;; Keywords: data
8
9 ;; This file is part of GNU Emacs.
10
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.
15
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.
20
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.
25
26 ;;; Commentary:
27
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.
35
36
37 ;; INSTRUCTIONS:
38 ;;
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).
43 ;;
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.
48 ;;
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.
57 ;;
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.
62
63
64 ;; APPLICATION NOTES:
65 ;;
66 ;; crypt++
67 ;; jka-compr can coexist with crpyt++ 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.
76 ;;
77
78
79 ;; ACKNOWLEDGMENTS
80 ;;
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.
84 ;;
85 ;; Jean-loup Gailly
86 ;; David Hughes
87 ;; Richard Pieri
88 ;; Daniel Quinlan
89 ;; Chris P. Ross
90 ;; Rick Sladkey
91 ;;
92 ;; Andy Norman's ange-ftp was the inspiration for the original jka-compr for
93 ;; Version 18 of Emacs.
94 ;;
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.
99 ;;
100
101 ;;; Code:
102
103 (defgroup compression nil
104 "Data compression utilities"
105 :group 'data)
106
107 (defgroup jka-compr nil
108 "jka-compr customization"
109 :group 'compression)
110
111
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)
119
120 (defvar jka-compr-use-shell
121 (not (memq system-type '(ms-dos windows-nt))))
122
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"])
149
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:
155
156 regexp is a regexp that matches filenames that are
157 compressed with this format
158
159 compress-msg is the message to issue to the user when doing this
160 type of compression (nil means no message)
161
162 compress-program is a program that performs this compression
163
164 compress-args is a list of args to pass to the compress program
165
166 uncompress-msg is the message to issue to the user when doing this
167 type of uncompression (nil means no message)
168
169 uncompress-program is a program that performs this compression
170
171 uncompress-args is a list of args to pass to the uncompress program
172
173 append-flag is non-nil if this compression technique can be
174 appended
175
176 strip-extension-flag non-nil means strip the regexp from file names
177 before attempting to set the mode.
178
179 file-magic-chars is a string of characters that you would find
180 at the beginning of a file compressed in this way.
181
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)
200
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)
206
207 (defcustom jka-compr-load-suffixes '(".gz")
208 "List of suffixes to try when loading files."
209 :type '(repeat string)
210 :group 'jka-compr)
211
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)
214
215 (defvar jka-compr-file-name-handler-entry
216 nil
217 "The entry in `file-name-handler-alist' used by the jka-compr I/O functions.")
218
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)
222 \f
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))
234
235
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)))
248
249
250 (put 'compression-error 'error-conditions '(compression-error file-error error))
251
252
253 (defvar jka-compr-acceptable-retval-list '(0 2 141))
254
255
256 (defun jka-compr-error (prog args infile message &optional errfile)
257
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))
266
267 (and errfile
268 (insert-file-contents errfile)))
269 (display-buffer errbuf))
270
271 (signal 'compression-error
272 (list "Opening input file" (format "error %s" message) infile)))
273
274
275 (defcustom jka-compr-dd-program "/bin/dd"
276 "How to invoke `dd'."
277 :type 'string
278 :group 'jka-compr)
279
280
281 (defvar jka-compr-dd-blocksize 256)
282
283
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))
321
322 ;; Delete the stuff after what we want, if there is any.
323 (and
324 len
325 (< (+ start prefix len) (point))
326 (delete-region (+ start prefix len) (point)))
327
328 ;; Delete the stuff before what we want.
329 (delete-region start (+ start prefix))))
330
331
332 (defun jka-compr-call-process (prog message infile output temp args)
333 (if jka-compr-use-shell
334
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))
338
339 (unwind-protect
340
341 (or (memq
342 (call-process jka-compr-shell infile
343 (if (stringp output) nil output)
344 nil
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)
354
355 (jka-compr-error prog args infile message err-file))
356
357 (jka-compr-delete-temp-file err-file)))
358
359 (or (zerop
360 (apply 'call-process
361 prog
362 infile
363 (if (stringp output) temp output)
364 nil
365 args))
366 (jka-compr-error prog args infile message))
367
368 (and (stringp output)
369 (with-current-buffer temp
370 (write-region (point-min) (point-max) output)
371 (erase-buffer)))))
372
373
374 ;;; Support for temp files. Much of this was inspired if not lifted
375 ;;; from ange-ftp.
376
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)
383
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))
387
388 (defalias 'jka-compr-delete-temp-file 'delete-file)
389
390
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))))
396
397 ;; If START is nil, use the whole buffer.
398 (if (null start)
399 (setq start 1 end (1+ (buffer-size))))
400
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))
408
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))
434
435 (setq temp-buffer (get-buffer-create " *jka-compr-wr-temp*"))
436 (with-current-buffer temp-buffer
437 (widen) (erase-buffer))
438
439 (if (and append
440 (not can-append)
441 (file-exists-p filename))
442
443 (let* ((local-copy (file-local-copy filename))
444 (local-file (or local-copy filename)))
445
446 (setq temp-file local-file))
447
448 (setq temp-file (jka-compr-make-temp-name)))
449
450 (and
451 compress-message
452 (message "%s %s..." compress-message base-name))
453
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)
458
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
467 nil
468 compress-args))
469
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)) )
479
480 (jka-compr-delete-temp-file temp-file)
481
482 (and
483 compress-message
484 (message "%s %s...done" compress-message base-name))
485
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))))
495
496 (and (or (eq visit t)
497 (eq visit nil)
498 (stringp visit))
499 (message "Wrote %s" visit-file))
500
501 ;; ensure `last-coding-system-used' has an appropriate value
502 (setq last-coding-system-used coding-system-used)
503
504 nil)
505
506 (jka-compr-run-real-handler 'write-region
507 (list start end filename append visit)))))
508
509
510 (defun jka-compr-insert-file-contents (file &optional visit beg end replace)
511 (barf-if-buffer-read-only)
512
513 (and (or beg end)
514 visit
515 (error "Attempt to visit less than an entire file"))
516
517 (let* ((filename (expand-file-name file))
518 (info (jka-compr-get-compression-info filename)))
519
520 (if info
521
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
531 (coding-system-for-read
532 (or coding-system-for-read
533 ;; If multibyte characters are disabled,
534 ;; don't do that conversion.
535 (and (null enable-multibyte-characters)
536 (or (auto-coding-alist-lookup
537 (jka-compr-byte-compiler-base-file-name file))
538 'raw-text))
539 (let ((coding (find-operation-coding-system
540 'insert-file-contents
541 (jka-compr-byte-compiler-base-file-name file))))
542 (and (consp coding) (car coding)))
543 'undecided)) )
544
545 (setq local-file (or local-copy filename))
546
547 (and
548 visit
549 (setq buffer-file-name filename))
550
551 (unwind-protect ; to make sure local-copy gets deleted
552
553 (progn
554
555 (and
556 uncompress-message
557 (message "%s %s..." uncompress-message base-name))
558
559 (condition-case error-code
560
561 (progn
562 (if replace
563 (goto-char (point-min)))
564 (setq start (point))
565 (if (or beg end)
566 (jka-compr-partial-uncompress uncompress-program
567 (concat uncompress-message
568 " " base-name)
569 uncompress-args
570 local-file
571 (or beg 0)
572 (if (and beg end)
573 (- end beg)
574 end))
575 ;; If visiting, bind off buffer-file-name so that
576 ;; file-locking will not ask whether we should
577 ;; really edit the buffer.
578 (let ((buffer-file-name
579 (if visit nil buffer-file-name)))
580 (jka-compr-call-process uncompress-program
581 (concat uncompress-message
582 " " base-name)
583 local-file
584 t
585 nil
586 uncompress-args)))
587 (setq size (- (point) start))
588 (if replace
589 (let* ((del-beg (point))
590 (del-end (+ del-beg size)))
591 (delete-region del-beg
592 (min del-end (point-max)))))
593 (goto-char start))
594 (error
595 (if (and (eq (car error-code) 'file-error)
596 (eq (nth 3 error-code) local-file))
597 (if visit
598 (setq notfound error-code)
599 (signal 'file-error
600 (cons "Opening input file"
601 (nthcdr 2 error-code))))
602 (signal (car error-code) (cdr error-code))))))
603
604 (and
605 local-copy
606 (file-exists-p local-copy)
607 (delete-file local-copy)))
608
609 (and
610 visit
611 (progn
612 (unlock-buffer)
613 (setq buffer-file-name filename)
614 (setq jka-compr-really-do-compress t)
615 (set-visited-file-modtime)))
616
617 (and
618 uncompress-message
619 (message "%s %s...done" uncompress-message base-name))
620
621 (and
622 visit
623 notfound
624 (signal 'file-error
625 (cons "Opening input file" (nth 2 notfound))))
626
627 ;; This is done in insert-file-contents after we return.
628 ;; That is a little weird, but better to go along with it now
629 ;; than to change it now.
630
631 ;;; ;; Run the functions that insert-file-contents would.
632 ;;; (let ((p after-insert-file-functions)
633 ;;; (insval size))
634 ;;; (while p
635 ;;; (setq insval (funcall (car p) size))
636 ;;; (if insval
637 ;;; (progn
638 ;;; (or (integerp insval)
639 ;;; (signal 'wrong-type-argument
640 ;;; (list 'integerp insval)))
641 ;;; (setq size insval)))
642 ;;; (setq p (cdr p))))
643
644 (list filename size))
645
646 (jka-compr-run-real-handler 'insert-file-contents
647 (list file visit beg end replace)))))
648
649
650 (defun jka-compr-file-local-copy (file)
651 (let* ((filename (expand-file-name file))
652 (info (jka-compr-get-compression-info filename)))
653
654 (if info
655
656 (let ((uncompress-message (jka-compr-info-uncompress-message info))
657 (uncompress-program (jka-compr-info-uncompress-program info))
658 (uncompress-args (jka-compr-info-uncompress-args info))
659 (base-name (file-name-nondirectory filename))
660 (local-copy
661 (jka-compr-run-real-handler 'file-local-copy (list filename)))
662 (temp-file (jka-compr-make-temp-name t))
663 (temp-buffer (get-buffer-create " *jka-compr-flc-temp*"))
664 (notfound nil)
665 local-file)
666
667 (setq local-file (or local-copy filename))
668
669 (unwind-protect
670
671 (with-current-buffer temp-buffer
672
673 (and
674 uncompress-message
675 (message "%s %s..." uncompress-message base-name))
676
677 ;; Here we must read the output of uncompress program
678 ;; and write it to TEMP-FILE without any code
679 ;; conversion. An appropriate code conversion (if
680 ;; necessary) is done by the later I/O operation
681 ;; (e.g. load).
682 (let ((coding-system-for-read 'no-conversion)
683 (coding-system-for-write 'no-conversion))
684
685 (jka-compr-call-process uncompress-program
686 (concat uncompress-message
687 " " base-name)
688 local-file
689 t
690 nil
691 uncompress-args)
692
693 (and
694 uncompress-message
695 (message "%s %s...done" uncompress-message base-name))
696
697 (write-region
698 (point-min) (point-max) temp-file nil 'dont)))
699
700 (and
701 local-copy
702 (file-exists-p local-copy)
703 (delete-file local-copy))
704
705 (kill-buffer temp-buffer))
706
707 temp-file)
708
709 (jka-compr-run-real-handler 'file-local-copy (list filename)))))
710
711
712 ;;; Support for loading compressed files.
713 (defun jka-compr-load (file &optional noerror nomessage nosuffix)
714 "Documented as original."
715
716 (let* ((local-copy (jka-compr-file-local-copy file))
717 (load-file (or local-copy file)))
718
719 (unwind-protect
720
721 (let (inhibit-file-name-operation
722 inhibit-file-name-handlers)
723 (or nomessage
724 (message "Loading %s..." file))
725
726 (let ((load-force-doc-strings t))
727 (load load-file noerror t t))
728 (or nomessage
729 (message "Loading %s...done." file))
730 ;; Fix up the load history to point at the right library.
731 (let ((l (assoc load-file load-history)))
732 ;; Remove .gz and .elc?.
733 (while (file-name-extension file)
734 (setq file (file-name-sans-extension file)))
735 (setcar l file)))
736
737 (jka-compr-delete-temp-file local-copy))
738
739 t))
740
741 (defun jka-compr-byte-compiler-base-file-name (file)
742 (let ((info (jka-compr-get-compression-info file)))
743 (if (and info (jka-compr-info-strip-extension info))
744 (save-match-data
745 (substring file 0 (string-match (jka-compr-info-regexp info) file)))
746 file)))
747 \f
748 (put 'write-region 'jka-compr 'jka-compr-write-region)
749 (put 'insert-file-contents 'jka-compr 'jka-compr-insert-file-contents)
750 (put 'file-local-copy 'jka-compr 'jka-compr-file-local-copy)
751 (put 'load 'jka-compr 'jka-compr-load)
752 (put 'byte-compiler-base-file-name 'jka-compr
753 'jka-compr-byte-compiler-base-file-name)
754
755 (defvar jka-compr-inhibit nil
756 "Non-nil means inhibit automatic uncompression temporarily.
757 Lisp programs can bind this to t to do that.
758 It is not recommended to set this variable permanently to anything but nil.")
759
760 (defun jka-compr-handler (operation &rest args)
761 (save-match-data
762 (let ((jka-op (get operation 'jka-compr)))
763 (if (and jka-op (not jka-compr-inhibit))
764 (apply jka-op args)
765 (jka-compr-run-real-handler operation args)))))
766
767 ;; If we are given an operation that we don't handle,
768 ;; call the Emacs primitive for that operation,
769 ;; and manipulate the inhibit variables
770 ;; to prevent the primitive from calling our handler again.
771 (defun jka-compr-run-real-handler (operation args)
772 (let ((inhibit-file-name-handlers
773 (cons 'jka-compr-handler
774 (and (eq inhibit-file-name-operation operation)
775 inhibit-file-name-handlers)))
776 (inhibit-file-name-operation operation))
777 (apply operation args)))
778
779
780 (defun jka-compr-build-file-regexp ()
781 (mapconcat
782 'jka-compr-info-regexp
783 jka-compr-compression-info-list
784 "\\|"))
785
786
787 (defun jka-compr-install ()
788 "Install jka-compr.
789 This adds entries to `file-name-handler-alist' and `auto-mode-alist'
790 and `inhibit-first-line-modes-suffixes'."
791
792 (setq jka-compr-file-name-handler-entry
793 (cons (jka-compr-build-file-regexp) 'jka-compr-handler))
794
795 (setq file-name-handler-alist (cons jka-compr-file-name-handler-entry
796 file-name-handler-alist))
797
798 (setq jka-compr-added-to-file-coding-system-alist nil)
799
800 (mapcar
801 (function (lambda (x)
802 ;; Don't do multibyte encoding on the compressed files.
803 (let ((elt (cons (jka-compr-info-regexp x)
804 '(no-conversion . no-conversion))))
805 (setq file-coding-system-alist
806 (cons elt file-coding-system-alist))
807 (setq jka-compr-added-to-file-coding-system-alist
808 (cons elt jka-compr-added-to-file-coding-system-alist)))
809
810 (and (jka-compr-info-strip-extension x)
811 ;; Make entries in auto-mode-alist so that modes
812 ;; are chosen right according to the file names
813 ;; sans `.gz'.
814 (setq auto-mode-alist
815 (cons (list (jka-compr-info-regexp x)
816 nil 'jka-compr)
817 auto-mode-alist))
818 ;; Also add these regexps to
819 ;; inhibit-first-line-modes-suffixes, so that a
820 ;; -*- line in the first file of a compressed tar
821 ;; file doesn't override tar-mode.
822 (setq inhibit-first-line-modes-suffixes
823 (cons (jka-compr-info-regexp x)
824 inhibit-first-line-modes-suffixes)))))
825 jka-compr-compression-info-list)
826 (setq auto-mode-alist
827 (append auto-mode-alist jka-compr-mode-alist-additions))
828
829 ;; Make sure that (load "foo") will find /bla/foo.el.gz.
830 (setq load-suffixes
831 (apply 'append
832 (mapcar (lambda (suffix)
833 (cons suffix
834 (mapcar (lambda (ext) (concat suffix ext))
835 jka-compr-load-suffixes)))
836 load-suffixes))))
837
838
839 (defun jka-compr-uninstall ()
840 "Uninstall jka-compr.
841 This removes the entries in `file-name-handler-alist' and `auto-mode-alist'
842 and `inhibit-first-line-modes-suffixes' that were added
843 by `jka-compr-installed'."
844 ;; Delete from inhibit-first-line-modes-suffixes
845 ;; what jka-compr-install added.
846 (mapcar
847 (function (lambda (x)
848 (and (jka-compr-info-strip-extension x)
849 (setq inhibit-first-line-modes-suffixes
850 (delete (jka-compr-info-regexp x)
851 inhibit-first-line-modes-suffixes)))))
852 jka-compr-compression-info-list)
853
854 (let* ((fnha (cons nil file-name-handler-alist))
855 (last fnha))
856
857 (while (cdr last)
858 (if (eq (cdr (car (cdr last))) 'jka-compr-handler)
859 (setcdr last (cdr (cdr last)))
860 (setq last (cdr last))))
861
862 (setq file-name-handler-alist (cdr fnha)))
863
864 (let* ((ama (cons nil auto-mode-alist))
865 (last ama)
866 entry)
867
868 (while (cdr last)
869 (setq entry (car (cdr last)))
870 (if (or (member entry jka-compr-mode-alist-additions)
871 (and (consp (cdr entry))
872 (eq (nth 2 entry) 'jka-compr)))
873 (setcdr last (cdr (cdr last)))
874 (setq last (cdr last))))
875
876 (setq auto-mode-alist (cdr ama)))
877
878 (let* ((ama (cons nil file-coding-system-alist))
879 (last ama)
880 entry)
881
882 (while (cdr last)
883 (setq entry (car (cdr last)))
884 (if (member entry jka-compr-added-to-file-coding-system-alist)
885 (setcdr last (cdr (cdr last)))
886 (setq last (cdr last))))
887
888 (setq file-coding-system-alist (cdr ama)))
889
890 ;; Remove the suffixes that were added by jka-compr.
891 (let ((suffixes nil)
892 (re (jka-compr-build-file-regexp)))
893 (dolist (suffix load-suffixes)
894 (unless (string-match re suffix)
895 (push suffix suffixes)))
896 (setq load-suffixes (nreverse suffixes))))
897
898
899 (defun jka-compr-installed-p ()
900 "Return non-nil if jka-compr is installed.
901 The return value is the entry in `file-name-handler-alist' for jka-compr."
902
903 (let ((fnha file-name-handler-alist)
904 (installed nil))
905
906 (while (and fnha (not installed))
907 (and (eq (cdr (car fnha)) 'jka-compr-handler)
908 (setq installed (car fnha)))
909 (setq fnha (cdr fnha)))
910
911 installed))
912
913
914 ;;; Add the file I/O hook if it does not already exist.
915 ;;; Make sure that jka-compr-file-name-handler-entry is eq to the
916 ;;; entry for jka-compr in file-name-handler-alist.
917 (and (jka-compr-installed-p)
918 (jka-compr-uninstall))
919
920
921 ;;;###autoload
922 (define-minor-mode auto-compression-mode
923 "Toggle automatic file compression and uncompression.
924 With prefix argument ARG, turn auto compression on if positive, else off.
925 Returns the new status of auto compression (non-nil means on)."
926 :global t :group 'jka-compr
927 (let* ((installed (jka-compr-installed-p))
928 (flag auto-compression-mode))
929 (cond
930 ((and flag installed) t) ; already installed
931 ((and (not flag) (not installed)) nil) ; already not installed
932 (flag (jka-compr-install))
933 (t (jka-compr-uninstall)))))
934
935
936 ;;;###autoload
937 (defmacro with-auto-compression-mode (&rest body)
938 "Evalute BODY with automatic file compression and uncompression enabled."
939 (let ((already-installed (make-symbol "already-installed")))
940 `(let ((,already-installed (jka-compr-installed-p)))
941 (unwind-protect
942 (progn
943 (unless ,already-installed
944 (jka-compr-install))
945 ,@body)
946 (unless ,already-installed
947 (jka-compr-uninstall))))))
948 (put 'with-auto-compression-mode 'lisp-indent-function 0)
949
950
951 (provide 'jka-compr)
952
953 ;;; jka-compr.el ends here