Mercurial > emacs
view lisp/jka-compr.el @ 83310:e58cb448e07c
Merged from miles@gnu.org--gnu-2005 (patch 80-82, 350-422)
Patches applied:
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-350
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-351
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-352
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-353
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-354
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-355
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-356
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-357
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-358
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-359
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-360
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-361
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-362
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-363
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-364
Remove "-face" suffix from widget faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-365
Remove "-face" suffix from custom faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-366
Remove "-face" suffix from change-log faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-367
Remove "-face" suffix from compilation faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-368
Remove "-face" suffix from diff-mode faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-369
lisp/longlines.el (longlines-visible-face): Face removed
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-370
Remove "-face" suffix from woman faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-371
Remove "-face" suffix from whitespace-highlight face
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-372
Remove "-face" suffix from ruler-mode faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-373
Remove "-face" suffix from show-paren faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-374
Remove "-face" suffix from log-view faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-375
Remove "-face" suffix from smerge faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-376
Remove "-face" suffix from show-tabs faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-377
Remove "-face" suffix from highlight-changes faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-378
Remove "-face" suffix from and downcase info faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-379
Remove "-face" suffix from pcvs faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-380
Update uses of renamed pcvs faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-381
Tweak ChangeLog
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-382
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-383
Remove "-face" suffix from strokes-char face
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-384
Remove "-face" suffix from compare-windows face
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-385
Remove "-face" suffix from calendar faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-386
Remove "-face" suffix from diary-button face
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-387
Remove "-face" suffix from testcover faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-388
Remove "-face" suffix from viper faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-389
Remove "-face" suffix from org faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-390
Remove "-face" suffix from sgml-namespace face
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-391
Remove "-face" suffix from table-cell face
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-392
Remove "-face" suffix from tex-mode faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-393
Remove "-face" suffix from texinfo-heading face
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-394
Remove "-face" suffix from flyspell faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-395
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-396
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-397
Remove "-face" suffix from gomoku faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-398
Remove "-face" suffix from mpuz faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-399
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-400
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-401
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-402
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-403
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-404
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-405
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-406
Merge from gnus--rel--5.10
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-407
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-408
Remove "-face" suffix from Buffer-menu-buffer face
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-409
Remove "-face" suffix from antlr-mode faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-410
Remove "-face" suffix from ebrowse faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-411
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-412
Remove "-face" suffix from flymake faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-413
Remove "-face" suffix from idlwave faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-414
Remove "-face" suffix from sh-script faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-415
Remove "-face" suffix from vhdl-mode faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-416
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-417
Remove "-face" suffix from which-func face
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-418
Remove "-face" suffix from cperl-mode faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-419
Remove "-face" suffix from ld-script faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-420
Fix cperl-mode font-lock problem
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-421
Tweak which-func face
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-422
Update from CVS
* miles@gnu.org--gnu-2005/gnus--rel--5.10--patch-80
Merge from emacs--cvs-trunk--0
* miles@gnu.org--gnu-2005/gnus--rel--5.10--patch-81
Update from CVS
* miles@gnu.org--gnu-2005/gnus--rel--5.10--patch-82
Update from CVS
git-archimport-id: lorentey@elte.hu--2004/emacs--multi-tty--0--patch-350
author | Karoly Lorentey <lorentey@elte.hu> |
---|---|
date | Wed, 15 Jun 2005 12:57:51 +0000 |
parents | 5b31557e355c |
children | e6ea4d9f64f3 62afea0771d8 |
line wrap: on
line source
;;; jka-compr.el --- reading/writing/loading compressed files ;; Copyright (C) 1993, 1994, 1995, 1997, 1999, 2000, 2003, 2004 Free Software Foundation, Inc. ;; Author: jka@ece.cmu.edu (Jay K. Adams) ;; Maintainer: FSF ;; Keywords: data ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. ;;; Commentary: ;; This package implements low-level support for reading, writing, ;; and loading compressed files. It hooks into the low-level file ;; I/O functions (including write-region and insert-file-contents) so ;; that they automatically compress or uncompress a file if the file ;; appears to need it (based on the extension of the file name). ;; Packages like Rmail, VM, GNUS, and Info should be able to work ;; with compressed files without modification. ;; INSTRUCTIONS: ;; ;; To use jka-compr, invoke the command `auto-compression-mode' (which ;; see), or customize the variable of the same name. Its operation ;; should be transparent to the user (except for messages appearing when ;; a file is being compressed or uncompressed). ;; ;; The variable, jka-compr-compression-info-list can be used to ;; customize jka-compr to work with other compression programs. ;; The default value of this variable allows jka-compr to work with ;; Unix compress and gzip. ;; ;; If you are concerned about the stderr output of gzip and other ;; compression/decompression programs showing up in your buffers, you ;; should set the discard-error flag in the compression-info-list. ;; This will cause the stderr of all programs to be discarded. ;; However, it also causes emacs to call compression/uncompression ;; programs through a shell (which is specified by jka-compr-shell). ;; This may be a drag if, on your system, starting up a shell is ;; slow. ;; ;; If you don't want messages about compressing and decompressing ;; to show up in the echo area, you can set the compress-name and ;; decompress-name fields of the jka-compr-compression-info-list to ;; nil. ;; APPLICATION NOTES: ;; ;; crypt++ ;; jka-compr can coexist with crypt++ if you take all the decompression ;; entries out of the crypt-encoding-list. Clearly problems will arise if ;; you have two programs trying to compress/decompress files. jka-compr ;; will not "work with" crypt++ in the following sense: you won't be able to ;; decode encrypted compressed files--that is, files that have been ;; compressed then encrypted (in that order). Theoretically, crypt++ and ;; jka-compr could properly handle a file that has been encrypted then ;; compressed, but there is little point in trying to compress an encrypted ;; file. ;; ;; ACKNOWLEDGMENTS ;; ;; jka-compr is a V19 adaptation of jka-compr for V18 of Emacs. Many people ;; have made helpful suggestions, reported bugs, and even fixed bugs in ;; jka-compr. I recall the following people as being particularly helpful. ;; ;; Jean-loup Gailly ;; David Hughes ;; Richard Pieri ;; Daniel Quinlan ;; Chris P. Ross ;; Rick Sladkey ;; ;; Andy Norman's ange-ftp was the inspiration for the original jka-compr for ;; Version 18 of Emacs. ;; ;; After I had made progress on the original jka-compr for V18, I learned of a ;; package written by Kazushi Jam Marukawa, called jam-zcat, that did exactly ;; what I was trying to do. I looked over the jam-zcat source code and ;; probably got some ideas from it. ;; ;;; Code: (defcustom jka-compr-shell "sh" "*Shell to be used for calling compression programs. The value of this variable only matters if you want to discard the stderr of a compression/decompression program (see the documentation for `jka-compr-compression-info-list')." :type 'string :group 'jka-compr) (defvar jka-compr-use-shell (not (memq system-type '(ms-dos windows-nt)))) (defvar jka-compr-really-do-compress nil "Non-nil in a buffer whose visited file was uncompressed on visiting it. This means compress the data on writing the file, even if the data appears to be compressed already.") (make-variable-buffer-local 'jka-compr-really-do-compress) (put 'jka-compr-really-do-compress 'permanent-local t) ;;; Functions for accessing the return value of jka-compr-get-compression-info (defun jka-compr-info-regexp (info) (aref info 0)) (defun jka-compr-info-compress-message (info) (aref info 1)) (defun jka-compr-info-compress-program (info) (aref info 2)) (defun jka-compr-info-compress-args (info) (aref info 3)) (defun jka-compr-info-uncompress-message (info) (aref info 4)) (defun jka-compr-info-uncompress-program (info) (aref info 5)) (defun jka-compr-info-uncompress-args (info) (aref info 6)) (defun jka-compr-info-can-append (info) (aref info 7)) (defun jka-compr-info-strip-extension (info) (aref info 8)) (defun jka-compr-info-file-magic-bytes (info) (aref info 9)) (defun jka-compr-get-compression-info (filename) "Return information about the compression scheme of FILENAME. The determination as to which compression scheme, if any, to use is based on the filename itself and `jka-compr-compression-info-list'." (catch 'compression-info (let ((case-fold-search nil)) (mapcar (function (lambda (x) (and (string-match (jka-compr-info-regexp x) filename) (throw 'compression-info x)))) jka-compr-compression-info-list) nil))) (put 'compression-error 'error-conditions '(compression-error file-error error)) (defvar jka-compr-acceptable-retval-list '(0 2 141)) (defun jka-compr-error (prog args infile message &optional errfile) (let ((errbuf (get-buffer-create " *jka-compr-error*")) (curbuf (current-buffer))) (with-current-buffer errbuf (widen) (erase-buffer) (insert (format "Error while executing \"%s %s < %s\"\n\n" prog (mapconcat 'identity args " ") infile)) (and errfile (insert-file-contents errfile))) (display-buffer errbuf)) (signal 'compression-error (list "Opening input file" (format "error %s" message) infile))) (defcustom jka-compr-dd-program "/bin/dd" "How to invoke `dd'." :type 'string :group 'jka-compr) (defvar jka-compr-dd-blocksize 256) (defun jka-compr-partial-uncompress (prog message args infile beg len) "Call program PROG with ARGS args taking input from INFILE. Fourth and fifth args, BEG and LEN, specify which part of the output to keep: LEN chars starting BEG chars from the beginning." (let ((start (point)) (prefix beg)) (if (and jka-compr-use-shell jka-compr-dd-program) ;; Put the uncompression output through dd ;; to discard the part we don't want. (let ((skip (/ beg jka-compr-dd-blocksize)) (err-file (jka-compr-make-temp-name)) count) ;; Update PREFIX based on the text that we won't read in. (setq prefix (- beg (* skip jka-compr-dd-blocksize)) count (and len (1+ (/ (+ len prefix) jka-compr-dd-blocksize)))) (unwind-protect (or (memq (call-process jka-compr-shell infile t nil "-c" (format "%s %s 2> %s | %s bs=%d skip=%d %s 2> %s" prog (mapconcat 'identity args " ") err-file jka-compr-dd-program jka-compr-dd-blocksize skip ;; dd seems to be unreliable about ;; providing the last block. So, always ;; read one more than you think you need. (if count (format "count=%d" (1+ count)) "") null-device)) jka-compr-acceptable-retval-list) (jka-compr-error prog args infile message err-file)) (jka-compr-delete-temp-file err-file))) ;; Run the uncompression program directly. ;; We get the whole file and must delete what we don't want. (jka-compr-call-process prog message infile t nil args)) ;; Delete the stuff after what we want, if there is any. (and len (< (+ start prefix len) (point)) (delete-region (+ start prefix len) (point))) ;; Delete the stuff before what we want. (delete-region start (+ start prefix)))) (defun jka-compr-call-process (prog message infile output temp args) (if jka-compr-use-shell (let ((err-file (jka-compr-make-temp-name)) (coding-system-for-read (or coding-system-for-read 'undecided)) (coding-system-for-write 'no-conversion)) (unwind-protect (or (memq (call-process jka-compr-shell infile (if (stringp output) nil output) nil "-c" (format "%s %s 2> %s %s" prog (mapconcat 'identity args " ") err-file (if (stringp output) (concat "> " output) ""))) jka-compr-acceptable-retval-list) (jka-compr-error prog args infile message err-file)) (jka-compr-delete-temp-file err-file))) (or (eq 0 (apply 'call-process prog infile (if (stringp output) temp output) nil args)) (jka-compr-error prog args infile message)) (and (stringp output) (with-current-buffer temp (write-region (point-min) (point-max) output) (erase-buffer))))) ;;; Support for temp files. Much of this was inspired if not lifted ;;; from ange-ftp. (defcustom jka-compr-temp-name-template (expand-file-name "jka-com" temporary-file-directory) "Prefix added to all temp files created by jka-compr. There should be no more than seven characters after the final `/'." :type 'string :group 'jka-compr) (defun jka-compr-make-temp-name (&optional local-copy) "This routine will return the name of a new file." (make-temp-file jka-compr-temp-name-template)) (defalias 'jka-compr-delete-temp-file 'delete-file) (defun jka-compr-write-region (start end file &optional append visit) (let* ((filename (expand-file-name file)) (visit-file (if (stringp visit) (expand-file-name visit) filename)) (info (jka-compr-get-compression-info visit-file)) (magic (and info (jka-compr-info-file-magic-bytes info)))) ;; If START is nil, use the whole buffer. (if (null start) (setq start 1 end (1+ (buffer-size)))) ;; If we uncompressed this file when visiting it, ;; then recompress it when writing it ;; even if the contents look compressed already. (if (and jka-compr-really-do-compress (eq start 1) (eq end (1+ (buffer-size)))) (setq magic nil)) (if (and info ;; If the contents to be written out ;; are properly compressed already, ;; don't try to compress them over again. (not (and magic (equal (if (stringp start) (substring start 0 (min (length start) (length magic))) (buffer-substring start (min end (+ start (length magic))))) magic)))) (let ((can-append (jka-compr-info-can-append info)) (compress-program (jka-compr-info-compress-program info)) (compress-message (jka-compr-info-compress-message info)) (compress-args (jka-compr-info-compress-args info)) (base-name (file-name-nondirectory visit-file)) temp-file temp-buffer ;; we need to leave `last-coding-system-used' set to its ;; value after calling write-region the first time, so ;; that `basic-save-buffer' sees the right value. (coding-system-used last-coding-system-used)) (or compress-program (error "No compression program defined")) (setq temp-buffer (get-buffer-create " *jka-compr-wr-temp*")) (with-current-buffer temp-buffer (widen) (erase-buffer)) (if (and append (not can-append) (file-exists-p filename)) (let* ((local-copy (file-local-copy filename)) (local-file (or local-copy filename))) (setq temp-file local-file)) (setq temp-file (jka-compr-make-temp-name))) (and compress-message (message "%s %s..." compress-message base-name)) (jka-compr-run-real-handler 'write-region (list start end temp-file t 'dont)) ;; save value used by the real write-region (setq coding-system-used last-coding-system-used) ;; Here we must read the output of compress program as is ;; without any code conversion. (let ((coding-system-for-read 'no-conversion)) (jka-compr-call-process compress-program (concat compress-message " " base-name) temp-file temp-buffer nil compress-args)) (with-current-buffer temp-buffer (let ((coding-system-for-write 'no-conversion)) (if (memq system-type '(ms-dos windows-nt)) (setq buffer-file-type t) ) (jka-compr-run-real-handler 'write-region (list (point-min) (point-max) filename (and append can-append) 'dont)) (erase-buffer)) ) (jka-compr-delete-temp-file temp-file) (and compress-message (message "%s %s...done" compress-message base-name)) (cond ((eq visit t) (setq buffer-file-name filename) (setq jka-compr-really-do-compress t) (set-visited-file-modtime)) ((stringp visit) (setq buffer-file-name visit) (let ((buffer-file-name filename)) (set-visited-file-modtime)))) (and (or (eq visit t) (eq visit nil) (stringp visit)) (message "Wrote %s" visit-file)) ;; ensure `last-coding-system-used' has an appropriate value (setq last-coding-system-used coding-system-used) nil) (jka-compr-run-real-handler 'write-region (list start end filename append visit))))) (defun jka-compr-insert-file-contents (file &optional visit beg end replace) (barf-if-buffer-read-only) (and (or beg end) visit (error "Attempt to visit less than an entire file")) (let* ((filename (expand-file-name file)) (info (jka-compr-get-compression-info filename))) (if info (let ((uncompress-message (jka-compr-info-uncompress-message info)) (uncompress-program (jka-compr-info-uncompress-program info)) (uncompress-args (jka-compr-info-uncompress-args info)) (base-name (file-name-nondirectory filename)) (notfound nil) (local-copy (jka-compr-run-real-handler 'file-local-copy (list filename))) local-file size start) (setq local-file (or local-copy filename)) (and visit (setq buffer-file-name filename)) (unwind-protect ; to make sure local-copy gets deleted (progn (and uncompress-message (message "%s %s..." uncompress-message base-name)) (condition-case error-code (let ((coding-system-for-read 'no-conversion)) (if replace (goto-char (point-min))) (setq start (point)) (if (or beg end) (jka-compr-partial-uncompress uncompress-program (concat uncompress-message " " base-name) uncompress-args local-file (or beg 0) (if (and beg end) (- end beg) end)) ;; If visiting, bind off buffer-file-name so that ;; file-locking will not ask whether we should ;; really edit the buffer. (let ((buffer-file-name (if visit nil buffer-file-name))) (jka-compr-call-process uncompress-program (concat uncompress-message " " base-name) local-file t nil uncompress-args))) (setq size (- (point) start)) (if replace (delete-region (point) (point-max))) (goto-char start)) (error (if (and (eq (car error-code) 'file-error) (eq (nth 3 error-code) local-file)) (if visit (setq notfound error-code) (signal 'file-error (cons "Opening input file" (nthcdr 2 error-code)))) (signal (car error-code) (cdr error-code)))))) (and local-copy (file-exists-p local-copy) (delete-file local-copy))) (unless notfound (decode-coding-inserted-region (point) (+ (point) size) (jka-compr-byte-compiler-base-file-name file) visit beg end replace)) (and visit (progn (unlock-buffer) (setq buffer-file-name filename) (setq jka-compr-really-do-compress t) (set-visited-file-modtime))) (and uncompress-message (message "%s %s...done" uncompress-message base-name)) (and visit notfound (signal 'file-error (cons "Opening input file" (nth 2 notfound)))) ;; This is done in insert-file-contents after we return. ;; That is a little weird, but better to go along with it now ;; than to change it now. ;;; ;; Run the functions that insert-file-contents would. ;;; (let ((p after-insert-file-functions) ;;; (insval size)) ;;; (while p ;;; (setq insval (funcall (car p) size)) ;;; (if insval ;;; (progn ;;; (or (integerp insval) ;;; (signal 'wrong-type-argument ;;; (list 'integerp insval))) ;;; (setq size insval))) ;;; (setq p (cdr p)))) (or (jka-compr-info-compress-program info) (message "You can't save this buffer because compression program is not defined")) (list filename size)) (jka-compr-run-real-handler 'insert-file-contents (list file visit beg end replace))))) (defun jka-compr-file-local-copy (file) (let* ((filename (expand-file-name file)) (info (jka-compr-get-compression-info filename))) (if info (let ((uncompress-message (jka-compr-info-uncompress-message info)) (uncompress-program (jka-compr-info-uncompress-program info)) (uncompress-args (jka-compr-info-uncompress-args info)) (base-name (file-name-nondirectory filename)) (local-copy (jka-compr-run-real-handler 'file-local-copy (list filename))) (temp-file (jka-compr-make-temp-name t)) (temp-buffer (get-buffer-create " *jka-compr-flc-temp*")) (notfound nil) local-file) (setq local-file (or local-copy filename)) (unwind-protect (with-current-buffer temp-buffer (and uncompress-message (message "%s %s..." uncompress-message base-name)) ;; Here we must read the output of uncompress program ;; and write it to TEMP-FILE without any code ;; conversion. An appropriate code conversion (if ;; necessary) is done by the later I/O operation ;; (e.g. load). (let ((coding-system-for-read 'no-conversion) (coding-system-for-write 'no-conversion)) (jka-compr-call-process uncompress-program (concat uncompress-message " " base-name) local-file t nil uncompress-args) (and uncompress-message (message "%s %s...done" uncompress-message base-name)) (write-region (point-min) (point-max) temp-file nil 'dont))) (and local-copy (file-exists-p local-copy) (delete-file local-copy)) (kill-buffer temp-buffer)) temp-file) (jka-compr-run-real-handler 'file-local-copy (list filename))))) ;;; Support for loading compressed files. (defun jka-compr-load (file &optional noerror nomessage nosuffix) "Documented as original." (let* ((local-copy (jka-compr-file-local-copy file)) (load-file (or local-copy file))) (unwind-protect (let (inhibit-file-name-operation inhibit-file-name-handlers) (or nomessage (message "Loading %s..." file)) (let ((load-force-doc-strings t)) (load load-file noerror t t)) (or nomessage (message "Loading %s...done." file)) ;; Fix up the load history to point at the right library. (let ((l (assoc load-file load-history))) ;; Remove .gz and .elc?. (while (file-name-extension file) (setq file (file-name-sans-extension file))) (setcar l file))) (jka-compr-delete-temp-file local-copy)) t)) (defun jka-compr-byte-compiler-base-file-name (file) (let ((info (jka-compr-get-compression-info file))) (if (and info (jka-compr-info-strip-extension info)) (save-match-data (substring file 0 (string-match (jka-compr-info-regexp info) file))) file))) (put 'write-region 'jka-compr 'jka-compr-write-region) (put 'insert-file-contents 'jka-compr 'jka-compr-insert-file-contents) (put 'file-local-copy 'jka-compr 'jka-compr-file-local-copy) (put 'load 'jka-compr 'jka-compr-load) (put 'byte-compiler-base-file-name 'jka-compr 'jka-compr-byte-compiler-base-file-name) ;;;###autoload (defvar jka-compr-inhibit nil "Non-nil means inhibit automatic uncompression temporarily. Lisp programs can bind this to t to do that. It is not recommended to set this variable permanently to anything but nil.") ;;;###autoload (defun jka-compr-handler (operation &rest args) (save-match-data (let ((jka-op (get operation 'jka-compr))) (if (and jka-op (not jka-compr-inhibit)) (apply jka-op args) (jka-compr-run-real-handler operation args))))) ;; If we are given an operation that we don't handle, ;; call the Emacs primitive for that operation, ;; and manipulate the inhibit variables ;; to prevent the primitive from calling our handler again. (defun jka-compr-run-real-handler (operation args) (let ((inhibit-file-name-handlers (cons 'jka-compr-handler (and (eq inhibit-file-name-operation operation) inhibit-file-name-handlers))) (inhibit-file-name-operation operation)) (apply operation args))) ;;;###autoload (defun jka-compr-uninstall () "Uninstall jka-compr. This removes the entries in `file-name-handler-alist' and `auto-mode-alist' and `inhibit-first-line-modes-suffixes' that were added by `jka-compr-installed'." ;; Delete from inhibit-first-line-modes-suffixes ;; what jka-compr-install added. (mapcar (function (lambda (x) (and (jka-compr-info-strip-extension x) (setq inhibit-first-line-modes-suffixes (delete (jka-compr-info-regexp x) inhibit-first-line-modes-suffixes))))) jka-compr-compression-info-list) (let* ((fnha (cons nil file-name-handler-alist)) (last fnha)) (while (cdr last) (if (eq (cdr (car (cdr last))) 'jka-compr-handler) (setcdr last (cdr (cdr last))) (setq last (cdr last)))) (setq file-name-handler-alist (cdr fnha))) (let* ((ama (cons nil auto-mode-alist)) (last ama) entry) (while (cdr last) (setq entry (car (cdr last))) (if (or (member entry jka-compr-mode-alist-additions) (and (consp (cdr entry)) (eq (nth 2 entry) 'jka-compr))) (setcdr last (cdr (cdr last))) (setq last (cdr last)))) (setq auto-mode-alist (cdr ama))) (let* ((ama (cons nil file-coding-system-alist)) (last ama) entry) (while (cdr last) (setq entry (car (cdr last))) (if (member entry jka-compr-added-to-file-coding-system-alist) (setcdr last (cdr (cdr last))) (setq last (cdr last)))) (setq file-coding-system-alist (cdr ama))) ;; Remove the suffixes that were added by jka-compr. (let ((suffixes nil) (re (jka-compr-build-file-regexp))) (dolist (suffix load-suffixes) (unless (string-match re suffix) (push suffix suffixes))) (setq load-suffixes (nreverse suffixes)))) (provide 'jka-compr) ;;; arch-tag: 3f15b630-e9a7-46c4-a22a-94afdde86ebc ;;; jka-compr.el ends here