Add arch tagline
[emacs.git] / lisp / jka-compr.el
blob33d3fe379d8cf975752e27f617cfcce33cf1395f
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 Free Software Foundation, Inc.
6 ;; Author: jka@ece.cmu.edu (Jay K. Adams)
7 ;; Maintainer: FSF
8 ;; Keywords: data
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)
15 ;; any later version.
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.
27 ;;; Commentary:
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.
38 ;; INSTRUCTIONS:
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
53 ;; nil.
56 ;; APPLICATION NOTES:
58 ;; crypt++
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
67 ;; file.
71 ;; ACKNOWLEDGMENTS
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.
77 ;; Jean-loup Gailly
78 ;; David Hughes
79 ;; Richard Pieri
80 ;; Daniel Quinlan
81 ;; Chris P. Ross
82 ;; Rick Sladkey
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.
93 ;;; Code:
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."
100 :type 'string
101 :group 'jka-compr)
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"
126 prog
127 (mapconcat 'identity args " ")
128 infile))
130 (and errfile
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'."
140 :type 'string
141 :group 'jka-compr)
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))
152 (prefix beg))
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.
159 (default-directory
160 (if (and default-directory
161 (file-accessible-directory-p default-directory))
162 default-directory
163 (file-name-directory infile)))
164 count)
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))))
168 (unwind-protect
169 (or (memq (call-process
170 jka-compr-shell infile t nil "-c"
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 (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.
192 (and
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))
206 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))
212 (unwind-protect
213 (or (memq
214 (call-process jka-compr-shell infile
215 (if (stringp output) nil output)
217 "-c"
218 (format "%s %s 2> %s %s"
219 prog
220 (mapconcat 'identity args " ")
221 err-file
222 (if (stringp output)
223 (concat "> " output)
224 "")))
225 jka-compr-acceptable-retval-list)
226 (jka-compr-error prog args infile message err-file))
227 (jka-compr-delete-temp-file err-file)))
228 (or (eq 0
229 (apply 'call-process
230 prog infile (if (stringp output) temp output)
231 nil args))
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)
236 (erase-buffer))))))
239 ;; Support for temp files. Much of this was inspired if not lifted
240 ;; from ange-ftp.
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 `/'."
246 :type 'string
247 :group 'jka-compr)
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.
263 (if (null start)
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
270 (eq start 1)
271 (eq end (1+ (buffer-size))))
272 (setq magic nil))
274 (if (and info
275 ;; If the contents to be written out
276 ;; are properly compressed already,
277 ;; don't try to compress them over again.
278 (not (and magic
279 (equal (if (stringp start)
280 (substring start 0 (min (length start)
281 (length magic)))
282 (buffer-substring start
283 (min end
284 (+ start (length magic)))))
285 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))
297 (or compress-program
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))
304 (if (and append
305 (not can-append)
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)))
315 (and
316 compress-message
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
329 " " base-name)
330 temp-file
331 temp-buffer
333 compress-args))
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)
341 filename
342 (and append can-append) 'dont))
343 (erase-buffer)) )
345 (jka-compr-delete-temp-file temp-file)
347 (and
348 compress-message
349 (message "%s %s...done" compress-message base-name))
351 (cond
352 ((eq visit t)
353 (setq buffer-file-name filename)
354 (setq jka-compr-really-do-compress t)
355 (set-visited-file-modtime))
356 ((stringp visit)
357 (setq buffer-file-name visit)
358 (let ((buffer-file-name filename))
359 (set-visited-file-modtime))))
361 (and (or (eq visit t)
362 (eq visit nil)
363 (stringp visit))
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)
369 nil)
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)
378 (and (or beg end)
379 visit
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)))
385 (if info
387 (let ((uncompress-message (jka-compr-info-uncompress-message info))
388 (uncompress-program (jka-compr-info-uncompress-program info))
389 (uncompress-args (jka-compr-info-uncompress-args info))
390 (base-name (file-name-nondirectory filename))
391 (notfound nil)
392 (local-copy
393 (jka-compr-run-real-handler 'file-local-copy (list filename)))
394 local-file
395 size start)
397 (setq local-file (or local-copy filename))
399 (and
400 visit
401 (setq buffer-file-name filename))
403 (unwind-protect ; to make sure local-copy gets deleted
405 (progn
407 (and
408 uncompress-message
409 (message "%s %s..." uncompress-message base-name))
411 (condition-case error-code
413 (let ((coding-system-for-read 'no-conversion))
414 (if replace
415 (goto-char (point-min)))
416 (setq start (point))
417 (if (or beg end)
418 (jka-compr-partial-uncompress uncompress-program
419 (concat uncompress-message
420 " " base-name)
421 uncompress-args
422 local-file
423 (or beg 0)
424 (if (and beg end)
425 (- end beg)
426 end))
427 ;; If visiting, bind off buffer-file-name so that
428 ;; file-locking will not ask whether we should
429 ;; really edit the buffer.
430 (let ((buffer-file-name
431 (if visit nil buffer-file-name)))
432 (jka-compr-call-process uncompress-program
433 (concat uncompress-message
434 " " base-name)
435 local-file
438 uncompress-args)))
439 (setq size (- (point) start))
440 (if replace
441 (delete-region (point) (point-max)))
442 (goto-char start))
443 (error
444 ;; If the file we wanted to uncompress does not exist,
445 ;; handle that according to VISIT as `insert-file-contents'
446 ;; would, maybe signaling the same error it normally would.
447 (if (and (eq (car error-code) 'file-error)
448 (eq (nth 3 error-code) local-file))
449 (if visit
450 (setq notfound error-code)
451 (signal 'file-error
452 (cons "Opening input file"
453 (nthcdr 2 error-code))))
454 ;; If the uncompression program can't be found,
455 ;; signal that as a non-file error
456 ;; so that find-file-noselect-1 won't handle it.
457 (if (and (eq (car error-code) 'file-error)
458 (equal (cadr error-code) "Searching for program"))
459 (error "Uncompression program `%s' not found"
460 (nth 3 error-code)))
461 (signal (car error-code) (cdr error-code))))))
463 (and
464 local-copy
465 (file-exists-p local-copy)
466 (delete-file local-copy)))
468 (unless notfound
469 (decode-coding-inserted-region
470 (point) (+ (point) size)
471 (jka-compr-byte-compiler-base-file-name file)
472 visit beg end replace))
474 (and
475 visit
476 (progn
477 (unlock-buffer)
478 (setq buffer-file-name filename)
479 (setq jka-compr-really-do-compress t)
480 (set-visited-file-modtime)))
482 (and
483 uncompress-message
484 (message "%s %s...done" uncompress-message base-name))
486 (and
487 visit
488 notfound
489 (signal 'file-error
490 (cons "Opening input file" (nth 2 notfound))))
492 ;; This is done in insert-file-contents after we return.
493 ;; That is a little weird, but better to go along with it now
494 ;; than to change it now.
496 ;;; ;; Run the functions that insert-file-contents would.
497 ;;; (let ((p after-insert-file-functions)
498 ;;; (insval size))
499 ;;; (while p
500 ;;; (setq insval (funcall (car p) size))
501 ;;; (if insval
502 ;;; (progn
503 ;;; (or (integerp insval)
504 ;;; (signal 'wrong-type-argument
505 ;;; (list 'integerp insval)))
506 ;;; (setq size insval)))
507 ;;; (setq p (cdr p))))
509 (or (jka-compr-info-compress-program info)
510 (message "You can't save this buffer because compression program is not defined"))
512 (list filename size))
514 (jka-compr-run-real-handler 'insert-file-contents
515 (list file visit beg end replace)))))
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 (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
548 ;; (e.g. load).
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
554 " " base-name)
555 local-file
558 uncompress-args)
560 (and
561 uncompress-message
562 (message "%s %s...done" uncompress-message base-name))
564 (write-region
565 (point-min) (point-max) temp-file nil 'dont)))
567 (and
568 local-copy
569 (file-exists-p local-copy)
570 (delete-file local-copy))
572 (kill-buffer temp-buffer))
574 temp-file)
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)))
586 (unwind-protect
588 (let (inhibit-file-name-operation
589 inhibit-file-name-handlers)
590 (or nomessage
591 (message "Loading %s..." file))
593 (let ((load-force-doc-strings t))
594 (load load-file noerror t t))
595 (or nomessage
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)))
602 (setcar l 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))
611 (save-match-data
612 (substring file 0 (string-match (jka-compr-info-regexp info) file)))
613 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)
622 ;;;###autoload
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.")
628 ;;;###autoload
629 (defun jka-compr-handler (operation &rest args)
630 (save-match-data
631 (let ((jka-op (get operation 'jka-compr)))
632 (if (and jka-op (not jka-compr-inhibit))
633 (apply jka-op args)
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)))
648 ;;;###autoload
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.
656 (mapc
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))
665 (last fnha))
667 (while (cdr last)
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))
675 (last ama)
676 entry)
678 (while (cdr last)
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))
702 (provide 'jka-compr)
704 ;; arch-tag: 3f15b630-e9a7-46c4-a22a-94afdde86ebc
705 ;;; jka-compr.el ends here