Document fit-frame-to-buffer
[emacs.git] / lisp / jka-compr.el
blob7e50ae57b19151ed8131e4bd90d16d0edc6259a2
1 ;;; jka-compr.el --- reading/writing/loading compressed files
3 ;; Copyright (C) 1993-1995, 1997, 1999-2012 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 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/>.
24 ;;; Commentary:
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.
35 ;; INSTRUCTIONS:
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
50 ;; nil.
53 ;; APPLICATION NOTES:
55 ;; crypt++
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
64 ;; file.
68 ;; ACKNOWLEDGMENTS
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.
74 ;; Jean-loup Gailly
75 ;; David Hughes
76 ;; Richard Pieri
77 ;; Daniel Quinlan
78 ;; Chris P. Ross
79 ;; Rick Sladkey
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.
90 ;;; Code:
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."
97 :type 'string
98 :group 'jka-compr)
100 (defvar jka-compr-use-shell
101 (not (memq system-type '(ms-dos windows-nt))))
103 (defvar jka-compr-really-do-compress nil
104 "Non-nil in a buffer whose visited file was uncompressed on visiting it.
105 This means compress the data on writing the file, even if the
106 data appears to be compressed already.")
107 (make-variable-buffer-local 'jka-compr-really-do-compress)
108 (put 'jka-compr-really-do-compress 'permanent-local t)
111 (put 'compression-error 'error-conditions '(compression-error file-error error))
114 (defvar jka-compr-acceptable-retval-list '(0 2 141))
117 (defun jka-compr-error (prog args infile message &optional errfile)
119 (let ((errbuf (get-buffer-create " *jka-compr-error*")))
120 (with-current-buffer errbuf
121 (widen) (erase-buffer)
122 (insert (format "Error while executing \"%s %s < %s\"\n\n"
123 prog
124 (mapconcat 'identity args " ")
125 infile))
127 (and errfile
128 (insert-file-contents errfile)))
129 (display-buffer errbuf))
131 (signal 'compression-error
132 (list "Opening input file" (format "error %s" message) infile)))
135 (defcustom jka-compr-dd-program "/bin/dd"
136 "How to invoke `dd'."
137 :type 'string
138 :group 'jka-compr)
141 (defvar jka-compr-dd-blocksize 256)
144 (defun jka-compr-partial-uncompress (prog message args infile beg len)
145 "Call program PROG with ARGS args taking input from INFILE.
146 Fourth and fifth args, BEG and LEN, specify which part of the output
147 to keep: LEN chars starting BEG chars from the beginning."
148 (let ((start (point))
149 (prefix beg))
150 (if (and jka-compr-use-shell jka-compr-dd-program)
151 ;; Put the uncompression output through dd
152 ;; to discard the part we don't want.
153 (let ((skip (/ beg jka-compr-dd-blocksize))
154 (err-file (jka-compr-make-temp-name))
155 ;; call-process barfs if default-directory is inaccessible.
156 (default-directory
157 (if (and default-directory
158 (file-accessible-directory-p default-directory))
159 default-directory
160 (file-name-directory infile)))
161 count)
162 ;; Update PREFIX based on the text that we won't read in.
163 (setq prefix (- beg (* skip jka-compr-dd-blocksize))
164 count (and len (1+ (/ (+ len prefix) jka-compr-dd-blocksize))))
165 (unwind-protect
166 (or (memq (call-process
167 jka-compr-shell infile t nil "-c"
168 ;; Windows shells need the program file name
169 ;; after the pipe symbol be quoted if they use
170 ;; forward slashes as directory separators.
171 (format
172 "%s %s 2> %s | \"%s\" bs=%d skip=%d %s 2> %s"
173 prog
174 (mapconcat 'identity args " ")
175 err-file
176 jka-compr-dd-program
177 jka-compr-dd-blocksize
178 skip
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)) "")
183 null-device))
184 jka-compr-acceptable-retval-list)
185 (jka-compr-error prog args infile message err-file))
186 (delete-file err-file)))
188 ;; Run the uncompression program directly.
189 ;; We get the whole file and must delete what we don't want.
190 (jka-compr-call-process prog message infile t nil args))
192 ;; Delete the stuff after what we want, if there is any.
193 (and
195 (< (+ start prefix len) (point))
196 (delete-region (+ start prefix len) (point)))
198 ;; Delete the stuff before what we want.
199 (delete-region start (+ start prefix))))
202 (defun jka-compr-call-process (prog message infile output temp args)
203 ;; call-process barfs if default-directory is inaccessible.
204 (let ((default-directory
205 (if (and default-directory
206 (not (file-remote-p default-directory))
207 (file-accessible-directory-p default-directory))
208 default-directory
209 (file-name-directory infile))))
210 (if jka-compr-use-shell
211 (let ((err-file (jka-compr-make-temp-name))
212 (coding-system-for-read (or coding-system-for-read 'undecided))
213 (coding-system-for-write 'no-conversion))
214 (unwind-protect
215 (or (memq
216 (call-process jka-compr-shell infile
217 (if (stringp output) nil output)
219 "-c"
220 (format "%s %s 2> %s %s"
221 prog
222 (mapconcat 'identity args " ")
223 err-file
224 (if (stringp output)
225 (concat "> " output)
226 "")))
227 jka-compr-acceptable-retval-list)
228 (jka-compr-error prog args infile message err-file))
229 (delete-file err-file)))
230 (or (eq 0
231 (apply 'call-process
232 prog infile (if (stringp output) temp output)
233 nil args))
234 (jka-compr-error prog args infile message))
235 (and (stringp output)
236 (with-current-buffer temp
237 (write-region (point-min) (point-max) output)
238 (erase-buffer))))))
241 ;; Support for temp files. Much of this was inspired if not lifted
242 ;; from ange-ftp.
244 (defcustom jka-compr-temp-name-template
245 (expand-file-name "jka-com" temporary-file-directory)
246 "Prefix added to all temp files created by jka-compr.
247 There should be no more than seven characters after the final `/'."
248 :type 'string
249 :group 'jka-compr)
251 (defun jka-compr-make-temp-name (&optional _local-copy)
252 "This routine will return the name of a new file."
253 (make-temp-file jka-compr-temp-name-template))
255 (defun jka-compr-write-region (start end file &optional append visit)
256 (let* ((filename (expand-file-name file))
257 (visit-file (if (stringp visit) (expand-file-name visit) filename))
258 (info (jka-compr-get-compression-info visit-file))
259 (magic (and info (jka-compr-info-file-magic-bytes info))))
261 ;; If we uncompressed this file when visiting it,
262 ;; then recompress it when writing it
263 ;; even if the contents look compressed already.
264 (if (and jka-compr-really-do-compress
265 (or (null start)
266 (= (- end start) (buffer-size))))
267 (setq magic nil))
269 (if (and info
270 ;; If the contents to be written out
271 ;; are properly compressed already,
272 ;; don't try to compress them over again.
273 (not (and magic
274 (equal (if (stringp start)
275 (substring start 0 (min (length start)
276 (length magic)))
277 (let* ((from (or start (point-min)))
278 (to (min (or end (point-max))
279 (+ from (length magic)))))
280 (buffer-substring from to)))
281 magic))))
282 (let ((can-append (jka-compr-info-can-append info))
283 (compress-program (jka-compr-info-compress-program info))
284 (compress-message (jka-compr-info-compress-message info))
285 (compress-args (jka-compr-info-compress-args info))
286 (base-name (file-name-nondirectory visit-file))
287 temp-file temp-buffer
288 ;; we need to leave `last-coding-system-used' set to its
289 ;; value after calling write-region the first time, so
290 ;; that `basic-save-buffer' sees the right value.
291 (coding-system-used last-coding-system-used))
293 (or compress-program
294 (error "No compression program defined"))
296 (setq temp-buffer (get-buffer-create " *jka-compr-wr-temp*"))
297 (with-current-buffer temp-buffer
298 (widen) (erase-buffer))
300 (if (and append
301 (not can-append)
302 (file-exists-p filename))
304 (let* ((local-copy (file-local-copy filename))
305 (local-file (or local-copy filename)))
307 (setq temp-file local-file))
309 (setq temp-file (jka-compr-make-temp-name)))
311 (and
312 compress-message
313 jka-compr-verbose
314 (message "%s %s..." compress-message base-name))
316 (jka-compr-run-real-handler 'write-region
317 (list start end temp-file t 'dont))
318 ;; save value used by the real write-region
319 (setq coding-system-used last-coding-system-used)
321 ;; Here we must read the output of compress program as is
322 ;; without any code conversion.
323 (let ((coding-system-for-read 'no-conversion))
324 (jka-compr-call-process compress-program
325 (concat compress-message
326 " " base-name)
327 temp-file
328 temp-buffer
330 compress-args))
332 (with-current-buffer temp-buffer
333 (let ((coding-system-for-write 'no-conversion))
334 (if (memq system-type '(ms-dos windows-nt))
335 (setq buffer-file-type t) )
336 (jka-compr-run-real-handler 'write-region
337 (list (point-min) (point-max)
338 filename
339 (and append can-append) 'dont))
340 (erase-buffer)) )
342 (delete-file temp-file)
344 (and
345 compress-message
346 jka-compr-verbose
347 (message "%s %s...done" compress-message base-name))
349 (cond
350 ((eq visit t)
351 (setq buffer-file-name filename)
352 (setq jka-compr-really-do-compress t)
353 (set-visited-file-modtime))
354 ((stringp visit)
355 (setq buffer-file-name visit)
356 (let ((buffer-file-name filename))
357 (set-visited-file-modtime))))
359 (and (or (eq visit t)
360 (eq visit nil)
361 (stringp visit))
362 (message "Wrote %s" visit-file))
364 ;; ensure `last-coding-system-used' has an appropriate value
365 (setq last-coding-system-used coding-system-used)
367 nil)
369 (jka-compr-run-real-handler 'write-region
370 (list start end filename append visit)))))
373 (defun jka-compr-insert-file-contents (file &optional visit beg end replace)
374 (barf-if-buffer-read-only)
376 (and (or beg end)
377 visit
378 (error "Attempt to visit less than an entire file"))
380 (let* ((filename (expand-file-name file))
381 (info (jka-compr-get-compression-info filename)))
383 (if (not info)
385 (jka-compr-run-real-handler 'insert-file-contents
386 (list file visit beg end replace))
388 (let ((uncompress-message (jka-compr-info-uncompress-message info))
389 (uncompress-program (jka-compr-info-uncompress-program info))
390 (uncompress-args (jka-compr-info-uncompress-args info))
391 (base-name (file-name-nondirectory filename))
392 (notfound nil)
393 (local-copy
394 (jka-compr-run-real-handler 'file-local-copy (list filename)))
395 local-file
396 size start)
398 (setq local-file (or local-copy filename))
400 (and
401 visit
402 (setq buffer-file-name filename))
404 (unwind-protect ; to make sure local-copy gets deleted
406 (progn
408 (and
409 uncompress-message
410 jka-compr-verbose
411 (message "%s %s..." uncompress-message base-name))
413 (condition-case error-code
415 (let ((coding-system-for-read 'no-conversion))
416 (if replace
417 (goto-char (point-min)))
418 (setq start (point))
419 (if (or beg end)
420 (jka-compr-partial-uncompress uncompress-program
421 (concat uncompress-message
422 " " base-name)
423 uncompress-args
424 local-file
425 (or beg 0)
426 (if (and beg end)
427 (- end beg)
428 end))
429 ;; If visiting, bind off buffer-file-name so that
430 ;; file-locking will not ask whether we should
431 ;; really edit the buffer.
432 (let ((buffer-file-name
433 (if visit nil buffer-file-name)))
434 (jka-compr-call-process uncompress-program
435 (concat uncompress-message
436 " " base-name)
437 local-file
440 uncompress-args)))
441 (setq size (- (point) start))
442 (if replace
443 (delete-region (point) (point-max)))
444 (goto-char start))
445 (error
446 ;; If the file we wanted to uncompress does not exist,
447 ;; handle that according to VISIT as `insert-file-contents'
448 ;; would, maybe signaling the same error it normally would.
449 (if (and (eq (car error-code) 'file-error)
450 (eq (nth 3 error-code) local-file))
451 (if visit
452 (setq notfound error-code)
453 (signal 'file-error
454 (cons "Opening input file"
455 (nthcdr 2 error-code))))
456 ;; If the uncompression program can't be found,
457 ;; signal that as a non-file error
458 ;; so that find-file-noselect-1 won't handle it.
459 (if (and (eq (car error-code) 'file-error)
460 (equal (cadr error-code) "Searching for program"))
461 (error "Uncompression program `%s' not found"
462 (nth 3 error-code)))
463 (signal (car error-code) (cdr error-code))))))
465 (and
466 local-copy
467 (file-exists-p local-copy)
468 (delete-file local-copy)))
470 (unless notfound
471 (decode-coding-inserted-region
472 (point) (+ (point) size)
473 (jka-compr-byte-compiler-base-file-name file)
474 visit beg end replace))
476 (and
477 visit
478 (progn
479 (unlock-buffer)
480 (setq buffer-file-name filename)
481 (setq jka-compr-really-do-compress t)
482 (set-visited-file-modtime)))
484 (and
485 uncompress-message
486 jka-compr-verbose
487 (message "%s %s...done" uncompress-message base-name))
489 (and
490 visit
491 notfound
492 (signal 'file-error
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)
501 ;; (insval size))
502 ;; (while p
503 ;; (setq insval (funcall (car p) size))
504 ;; (if insval
505 ;; (progn
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)))
522 (if info
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))
528 (local-copy
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*"))
532 local-file)
534 (setq local-file (or local-copy filename))
536 (unwind-protect
538 (with-current-buffer temp-buffer
540 (and
541 uncompress-message
542 jka-compr-verbose
543 (message "%s %s..." uncompress-message base-name))
545 ;; Here we must read the output of uncompress program
546 ;; and write it to TEMP-FILE without any code
547 ;; conversion. An appropriate code conversion (if
548 ;; necessary) is done by the later I/O operation
549 ;; (e.g. load).
550 (let ((coding-system-for-read 'no-conversion)
551 (coding-system-for-write 'no-conversion))
553 (jka-compr-call-process uncompress-program
554 (concat uncompress-message
555 " " base-name)
556 local-file
559 uncompress-args)
561 (and
562 uncompress-message
563 jka-compr-verbose
564 (message "%s %s...done" uncompress-message base-name))
566 (write-region
567 (point-min) (point-max) temp-file nil 'dont)))
569 (and
570 local-copy
571 (file-exists-p local-copy)
572 (delete-file local-copy))
574 (kill-buffer temp-buffer))
576 temp-file)
578 (jka-compr-run-real-handler 'file-local-copy (list filename)))))
581 ;; Support for loading compressed files.
582 (defun jka-compr-load (file &optional noerror nomessage _nosuffix)
583 "Documented as original."
585 (let* ((local-copy (jka-compr-file-local-copy file))
586 (load-file (or local-copy file)))
588 (unwind-protect
590 (let (inhibit-file-name-operation
591 inhibit-file-name-handlers)
592 (or nomessage
593 (message "Loading %s..." file))
595 (let ((load-force-doc-strings t))
596 (load load-file noerror t t))
597 (or nomessage
598 (message "Loading %s...done." file))
599 ;; Fix up the load history to point at the right library.
600 (let ((l (or (assoc load-file load-history)
601 ;; On MS-Windows, if load-file is in
602 ;; temporary-file-directory, it will look like
603 ;; "c:/DOCUME~1/USER/LOCALS~1/foo", whereas
604 ;; readevalloop will record its truename in
605 ;; load-history. Therefore try truename if the
606 ;; original name is not in load-history.
607 (assoc (file-truename load-file) load-history))))
608 ;; Remove .gz and .elc?.
609 (while (file-name-extension file)
610 (setq file (file-name-sans-extension file)))
611 (setcar l file)))
613 (delete-file local-copy))
617 (defun jka-compr-byte-compiler-base-file-name (file)
618 (let ((info (jka-compr-get-compression-info file)))
619 (if (and info (jka-compr-info-strip-extension info))
620 (save-match-data
621 (substring file 0 (string-match (jka-compr-info-regexp info) file)))
622 file)))
624 (put 'write-region 'jka-compr 'jka-compr-write-region)
625 (put 'insert-file-contents 'jka-compr 'jka-compr-insert-file-contents)
626 (put 'file-local-copy 'jka-compr 'jka-compr-file-local-copy)
627 (put 'load 'jka-compr 'jka-compr-load)
628 (put 'byte-compiler-base-file-name 'jka-compr
629 'jka-compr-byte-compiler-base-file-name)
631 ;;;###autoload
632 (defvar jka-compr-inhibit nil
633 "Non-nil means inhibit automatic uncompression temporarily.
634 Lisp programs can bind this to t to do that.
635 It is not recommended to set this variable permanently to anything but nil.")
637 ;;;###autoload
638 (defun jka-compr-handler (operation &rest args)
639 (save-match-data
640 (let ((jka-op (get operation 'jka-compr)))
641 (if (and jka-op (not jka-compr-inhibit))
642 (apply jka-op args)
643 (jka-compr-run-real-handler operation args)))))
645 ;; If we are given an operation that we don't handle,
646 ;; call the Emacs primitive for that operation,
647 ;; and manipulate the inhibit variables
648 ;; to prevent the primitive from calling our handler again.
649 (defun jka-compr-run-real-handler (operation args)
650 (let ((inhibit-file-name-handlers
651 (cons 'jka-compr-handler
652 (and (eq inhibit-file-name-operation operation)
653 inhibit-file-name-handlers)))
654 (inhibit-file-name-operation operation))
655 (apply operation args)))
657 ;;;###autoload
658 (defun jka-compr-uninstall ()
659 "Uninstall jka-compr.
660 This removes the entries in `file-name-handler-alist' and `auto-mode-alist'
661 and `inhibit-local-variables-suffixes' that were added
662 by `jka-compr-installed'."
663 ;; Delete from inhibit-local-variables-suffixes what jka-compr-install added.
664 (mapc
665 (function (lambda (x)
666 (and (jka-compr-info-strip-extension x)
667 (setq inhibit-local-variables-suffixes
668 (delete (jka-compr-info-regexp x)
669 inhibit-local-variables-suffixes)))))
670 jka-compr-compression-info-list--internal)
672 (let* ((fnha (cons nil file-name-handler-alist))
673 (last fnha))
675 (while (cdr last)
676 (if (eq (cdr (car (cdr last))) 'jka-compr-handler)
677 (setcdr last (cdr (cdr last)))
678 (setq last (cdr last))))
680 (setq file-name-handler-alist (cdr fnha)))
682 (let* ((ama (cons nil auto-mode-alist))
683 (last ama)
684 entry)
686 (while (cdr last)
687 (setq entry (car (cdr last)))
688 (if (or (member entry jka-compr-mode-alist-additions--internal)
689 (and (consp (cdr entry))
690 (eq (nth 2 entry) 'jka-compr)))
691 (setcdr last (cdr (cdr last)))
692 (setq last (cdr last))))
694 (setq auto-mode-alist (cdr ama)))
696 (while jka-compr-added-to-file-coding-system-alist
697 (setq file-coding-system-alist
698 (delq (car (member (pop jka-compr-added-to-file-coding-system-alist)
699 file-coding-system-alist))
700 file-coding-system-alist)))
702 ;; Remove the suffixes that were added by jka-compr.
703 (dolist (suff jka-compr-load-suffixes--internal)
704 (setq load-file-rep-suffixes (delete suff load-file-rep-suffixes)))
706 (setq jka-compr-compression-info-list--internal nil
707 jka-compr-mode-alist-additions--internal nil
708 jka-compr-load-suffixes--internal nil))
710 (provide 'jka-compr)
712 ;;; jka-compr.el ends here