X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/30c78e11b9303762c991b2c9dfc575887e735c0a..380874900ca183ec2fdce91949d841328852d7a8:/lisp/jka-compr.el diff --git a/lisp/jka-compr.el b/lisp/jka-compr.el index b25e527c9a..389944fa3e 100644 --- a/lisp/jka-compr.el +++ b/lisp/jka-compr.el @@ -1,182 +1,126 @@ -;;; jka-compr.el - reading/writing/loading compressed files. -;;; Copyright (C) 1993, 1994 Free Software Foundation, Inc. +;;; jka-compr.el --- reading/writing/loading compressed files + +;; Copyright (C) 1993, 1994, 1995, 1997, 1999, 2000, 2002, 2003, +;; 2004, 2005, 2006 Free Software Foundation, Inc. ;; Author: jka@ece.cmu.edu (Jay K. Adams) +;; Maintainer: FSF ;; Keywords: data -;;; 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, simply load this package, and edit as usual. -;;; 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 crpyt++ 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. -;;; +;; 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., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, 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: -(defvar jka-compr-shell "sh" +(require 'jka-cmpr-hook) + +(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').") - - -(defvar jka-compr-use-shell t) - - -;;; I have this defined so that .Z files are assumed to be in unix -;;; compress format; and .gz files, in gzip format. -(defvar jka-compr-compression-info-list - ;;[regexp - ;; compr-message compr-prog compr-args - ;; uncomp-message uncomp-prog uncomp-args - ;; can-append auto-mode-flag] - '(["\\.Z\\(~\\|\\.~[0-9]+~\\)?\\'" - "compressing" "compress" ("-c") - "uncompressing" "uncompress" ("-c") - nil t] - ["\\.tgz\\'" - "zipping" "gzip" ("-c" "-q") - "unzipping" "gzip" ("-c" "-q" "-d") - t nil] - ["\\.gz\\(~\\|\\.~[0-9]+~\\)?\\'" - "zipping" "gzip" ("-c" "-q") - "unzipping" "gzip" ("-c" "-q" "-d") - t t]) - - "List of vectors that describe available compression techniques. -Each element, which describes a compression technique, is a vector of -the form [REGEXP COMPRESS-MSG COMPRESS-PROGRAM COMPRESS-ARGS -UNCOMPRESS-MSG UNCOMPRESS-PROGRAM UNCOMPRESS-ARGS -APPEND-FLAG EXTENSION], where: - - regexp is a regexp that matches filenames that are - compressed with this format - - compress-msg is the message to issue to the user when doing this - type of compression (nil means no message) - - compress-program is a program that performs this compression - - compress-args is a list of args to pass to the compress program - - uncompress-msg is the message to issue to the user when doing this - type of uncompression (nil means no message) - - uncompress-program is a program that performs this compression - - uncompress-args is a list of args to pass to the uncompress program - - append-flag is non-nil if this compression technique can be - appended - - auto-mode flag non-nil means strip the regexp from file names - before attempting to set the mode. - -Because of the way `call-process' is defined, discarding the stderr output of -a program adds the overhead of starting a shell each time the program is -invoked.") - -(defvar jka-compr-mode-alist-additions - (list (cons "\\.tgz\\'" 'tar-mode)) - "A list of pairs to add to auto-mode-alist when jka-compr is installed.") - -(defvar jka-compr-file-name-handler-entry - nil - "The entry in `file-name-handler-alist' used by the jka-compr I/O functions.") +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-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-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)) @@ -186,26 +130,26 @@ based on the filename itself and `jka-compr-compression-info-list'." (defun jka-compr-error (prog args infile message &optional errfile) - (let ((errbuf (get-buffer-create " *jka-compr-error*")) - (curbuf (current-buffer))) - (set-buffer errbuf) - (widen) (erase-buffer) - (insert (format "Error while executing \"%s %s < %s\"\n\n" - prog - (mapconcat 'identity args " ") - infile)) + (let ((errbuf (get-buffer-create " *jka-compr-error*"))) + (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)) - - (set-buffer curbuf) + (and errfile + (insert-file-contents errfile))) (display-buffer errbuf)) - (signal 'compression-error (list "Opening input file" (format "error %s" message) infile))) - - -(defvar jka-compr-dd-program - "/bin/dd") + (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) @@ -215,32 +159,39 @@ based on the filename itself and `jka-compr-compression-info-list'." "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* ((skip (/ beg jka-compr-dd-blocksize)) - (prefix (- beg (* skip jka-compr-dd-blocksize))) - (count (and len (1+ (/ (+ len prefix) jka-compr-dd-blocksize)))) - (start (point)) - (err-file (jka-compr-make-temp-name)) - (run-string (format "%s %s 2> %s | %s bs=%d skip=%d %s 2> /dev/null" - 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 (concat "count=" (1+ count)) "")))) - - (unwind-protect - (or (memq (call-process jka-compr-shell - infile t nil "-c" - run-string) - jka-compr-acceptable-retval-list) - - (jka-compr-error prog args infile message err-file)) - - (jka-compr-delete-temp-file err-file)) + (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 @@ -255,8 +206,10 @@ to keep: LEN chars starting BEG chars from the beginning." (defun jka-compr-call-process (prog message infile output temp args) (if jka-compr-use-shell - (let ((err-file (jka-compr-make-temp-name))) - + (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 @@ -277,7 +230,7 @@ to keep: LEN chars starting BEG chars from the beginning." (jka-compr-delete-temp-file err-file))) - (or (zerop + (or (eq 0 (apply 'call-process prog infile @@ -287,147 +240,145 @@ to keep: LEN chars starting BEG chars from the beginning." (jka-compr-error prog args infile message)) (and (stringp output) - (let ((cbuf (current-buffer))) - (set-buffer temp) + (with-current-buffer temp (write-region (point-min) (point-max) output) - (erase-buffer) - (set-buffer cbuf))))) + (erase-buffer))))) -;;; Support for temp files. Much of this was inspired if not lifted -;;; from ange-ftp. +;; Support for temp files. Much of this was inspired if not lifted +;; from ange-ftp. -(defvar jka-compr-temp-name-template - "/tmp/jka-com" +(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 `/'") - -(defvar jka-compr-temp-name-table (make-vector 31 nil)) +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." - (let* ((lastchar ?a) - (prevchar ?a) - (template (concat jka-compr-temp-name-template "aa")) - (lastpos (1- (length template))) - (not-done t) - file - entry) + (make-temp-file jka-compr-temp-name-template)) - (while not-done - (aset template lastpos lastchar) - (setq file (concat (make-temp-name template) "#")) - (setq entry (intern file jka-compr-temp-name-table)) - (if (or (get entry 'active) - (file-exists-p file)) - - (progn - (setq lastchar (1+ lastchar)) - (if (> lastchar ?z) - (progn - (setq prevchar (1+ prevchar)) - (setq lastchar ?a) - (if (> prevchar ?z) - (error "Can't allocate temp file.") - (aset template (1- lastpos) prevchar))))) - - (put entry 'active (not local-copy)) - (setq not-done nil))) - - file)) - - -(defun jka-compr-delete-temp-file (temp) - - (put (intern temp jka-compr-temp-name-table) - 'active nil) - - (condition-case () - (delete-file temp) - (error nil))) +(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))) - - (if info - - (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)) - (uncompress-program (jka-compr-info-uncompress-program info)) - (uncompress-message (jka-compr-info-uncompress-message info)) - (compress-args (jka-compr-info-compress-args info)) - (uncompress-args (jka-compr-info-uncompress-args info)) - (base-name (file-name-nondirectory visit-file)) - temp-file cbuf temp-buffer) - - (setq cbuf (current-buffer) - temp-buffer (get-buffer-create " *jka-compr-wr-temp*")) - (set-buffer temp-buffer) - (widen) (erase-buffer) - (set-buffer cbuf) - - (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)) + (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) + compress-args)) - (set-buffer temp-buffer) - (jka-compr-run-real-handler 'write-region - (list (point-min) (point-max) - filename - (and append can-append) 'dont)) - (erase-buffer) - (set-buffer cbuf) + (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) + (jka-compr-delete-temp-file temp-file) - (and - compress-message - (message "%s %s...done" compress-message base-name)) + (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)))) - (cond - ((eq visit t) - (setq buffer-file-name filename) - (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)) - (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))))) + 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) @@ -461,14 +412,14 @@ There should be no more than seven characters after the final `/'") (unwind-protect ; to make sure local-copy gets deleted (progn - + (and uncompress-message (message "%s %s..." uncompress-message base-name)) (condition-case error-code - (progn + (let ((coding-system-for-read 'no-conversion)) (if replace (goto-char (point-min))) (setq start (point)) @@ -496,19 +447,26 @@ There should be no more than seven characters after the final `/'") uncompress-args))) (setq size (- (point) start)) (if replace - (let* ((del-beg (point)) - (del-end (+ del-beg size))) - (delete-region del-beg - (min del-end (point-max))))) + (delete-region (point) (point-max))) (goto-char start)) (error + ;; If the file we wanted to uncompress does not exist, + ;; handle that according to VISIT as `insert-file-contents' + ;; would, maybe signaling the same error it normally would. (if (and (eq (car error-code) 'file-error) (eq (nth 3 error-code) local-file)) (if visit (setq notfound error-code) - (signal 'file-error + (signal 'file-error (cons "Opening input file" (nthcdr 2 error-code)))) + ;; If the uncompression program can't be found, + ;; signal that as a non-file error + ;; so that find-file-noselect-1 won't handle it. + (if (and (eq (car error-code) 'file-error) + (equal (cadr error-code) "Searching for program")) + (error "Uncompression program `%s' not found" + (nth 3 error-code))) (signal (car error-code) (cdr error-code)))))) (and @@ -516,13 +474,20 @@ There should be no more than seven characters after the final `/'") (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)) @@ -533,18 +498,25 @@ There should be no more than seven characters after the final `/'") (signal 'file-error (cons "Opening input file" (nth 2 notfound)))) - ;; 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)))) + ;; 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)) @@ -566,51 +538,54 @@ There should be no more than seven characters after the final `/'") (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) - (cbuf (current-buffer)) local-file) (setq local-file (or local-copy filename)) (unwind-protect - (progn - - (and - uncompress-message - (message "%s %s..." uncompress-message base-name)) - - (set-buffer temp-buffer) - - (jka-compr-call-process uncompress-program - (concat uncompress-message - " " base-name) - local-file - t - nil - uncompress-args) + (with-current-buffer temp-buffer (and uncompress-message - (message "%s %s...done" uncompress-message base-name)) + (message "%s %s..." uncompress-message base-name)) - (write-region - (point-min) (point-max) temp-file nil 'dont)) + ;; 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)) - (set-buffer cbuf) (kill-buffer temp-buffer)) temp-file) - + (jka-compr-run-real-handler 'file-local-copy (list filename))))) -;;; Support for loading compressed files. +;; Support for loading compressed files. (defun jka-compr-load (file &optional noerror nomessage nosuffix) "Documented as original." @@ -624,24 +599,46 @@ There should be no more than seven characters after the final `/'") (or nomessage (message "Loading %s..." file)) - (load load-file noerror t t) - + (let ((load-force-doc-strings t)) + (load load-file noerror t t)) (or nomessage - (message "Loading %s...done." file))) + (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 jka-op + (if (and jka-op (not jka-compr-inhibit)) (apply jka-op args) (jka-compr-run-real-handler operation args))))) @@ -657,79 +654,7 @@ There should be no more than seven characters after the final `/'") (inhibit-file-name-operation operation)) (apply operation args))) -(defun toggle-auto-compression (arg) - "Toggle automatic file compression and decompression. -With prefix argument ARG, turn auto compression on if positive, else off. -Returns the new status of auto compression (non-nil means on)." - (interactive "P") - (let* ((installed (jka-compr-installed-p)) - (flag (if (null arg) - (not installed) - (or (eq arg t) (listp arg) (and (integerp arg) (> arg 0)))))) - - (cond - ((and flag installed) t) ; already installed - - ((and (not flag) (not installed)) nil) ; already not installed - - (flag - (jka-compr-install)) - - (t - (jka-compr-uninstall))) - - - (and (interactive-p) - (if flag - (message "Automatic file (de)compression is now ON.") - (message "Automatic file (de)compression is now OFF."))) - - flag)) - - -(defun jka-compr-build-file-regexp () - (concat - "\\(" - (mapconcat - 'jka-compr-info-regexp - jka-compr-compression-info-list - "\\)\\|\\(") - "\\)")) - - -(defun jka-compr-install () - "Install jka-compr. -This adds entries to `file-name-handler-alist' and `auto-mode-alist' -and `inhibit-first-line-modes-suffixes'." - - (setq jka-compr-file-name-handler-entry - (cons (jka-compr-build-file-regexp) 'jka-compr-handler)) - - (setq file-name-handler-alist (cons jka-compr-file-name-handler-entry - file-name-handler-alist)) - - (mapcar - (function (lambda (x) - (and (jka-compr-info-strip-extension x) - ;; Make entries in auto-mode-alist so that modes - ;; are chosen right according to the file names - ;; sans `.gz'. - (setq auto-mode-alist - (cons (list (jka-compr-info-regexp x) - nil 'jka-compr) - auto-mode-alist)) - ;; Also add these regexps to - ;; inhibit-first-line-modes-suffixes, so that a - ;; -*- line in the first file of a compressed tar - ;; file doesn't override tar-mode. - (setq inhibit-first-line-modes-suffixes - (cons (jka-compr-info-regexp x) - inhibit-first-line-modes-suffixes))))) - jka-compr-compression-info-list) - (setq auto-mode-alist - (append auto-mode-alist jka-compr-mode-alist-additions))) - - +;;;###autoload (defun jka-compr-uninstall () "Uninstall jka-compr. This removes the entries in `file-name-handler-alist' and `auto-mode-alist' @@ -766,34 +691,24 @@ by `jka-compr-installed'." (eq (nth 2 entry) 'jka-compr))) (setcdr last (cdr (cdr last))) (setq last (cdr last)))) - - (setq auto-mode-alist (cdr ama)))) - - -(defun jka-compr-installed-p () - "Return non-nil if jka-compr is installed. -The return value is the entry in `file-name-handler-alist' for jka-compr." - - (let ((fnha file-name-handler-alist) - (installed nil)) - - (while (and fnha (not installed)) - (and (eq (cdr (car fnha)) 'jka-compr-handler) - (setq installed (car fnha))) - (setq fnha (cdr fnha))) - - installed)) - -;;; Add the file I/O hook if it does not already exist. -;;; Make sure that jka-compr-file-name-handler-entry is eq to the -;;; entry for jka-compr in file-name-handler-alist. -(and (jka-compr-installed-p) - (jka-compr-uninstall)) + (setq auto-mode-alist (cdr ama))) -(jka-compr-install) + (while jka-compr-added-to-file-coding-system-alist + (setq file-coding-system-alist + (delq (car (member (pop jka-compr-added-to-file-coding-system-alist) + file-coding-system-alist)) + file-coding-system-alist))) + ;; 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) -;; jka-compr.el ends here. +;; arch-tag: 3f15b630-e9a7-46c4-a22a-94afdde86ebc +;;; jka-compr.el ends here