changeset 6002:7507f44b1e5e

Initial revision

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/jka-compr.el	Fri Feb 18 22:50:05 1994 +0000
@@ -0,0 +1,822 @@
+;;; jka-compr.el - reading/writing/loading compressed files.
+;;; Copyright (C) 1993, 1994  Free Software Foundation, Inc.
+
+;; Author: [e-mail] (Jay K. Adams)
+;; Version: 0.10
+;; 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:
+;;; 
+;;; rmail, vm, gnus, etc.
+;;;   To use compressed mail folders, .newsrc files, etc., you need
+;;;   only compress the file.  Since jka-compr searches for .gz
+;;;   versions of the files it's finding, you need not change
+;;;   variables within rmail, gnus, etc.  
+;;;
+;;;
+;;; 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.
+;;;
+;;;
+;;; tar-mode
+;;;   Some people like to use extensions like .trz for compressed tar files.
+;;;   To handle these sorts of files, you have to add an entry to
+;;;   jka-compr-compression-info-list that looks something like this: 
+;;;
+;;;      ["\\.trz\\'" "\037\213"
+;;;       "zip"   "gzip"  nil  ("-q")
+;;;       "unzip" "gzip"  nil  ("-q" "-d")
+;;;       t
+;;;       nil]
+;;;
+;;;   The last nil in the vector (the "extension" field) prevents jka-compr
+;;;   from attempting to add .trz to an ordinary file name when it is looking
+;;;   for a compressed version of that file (i.e. don't look for things like
+;;;   foobar.c.trz).
+;;;
+;;;   Finally, to make tar-mode start up automatically, you have to add an
+;;;   entry to auto-mode-alist that looks like this
+;;;
+;;;       ("\\.trz\\'" . tar-mode)
+;;;
+
+
+;;; 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"
+  "*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-discard  compr-args
+  ;; uncomp-message uncomp-prog uncomp-discard uncomp-args
+  ;; can-append auto-mode-flag]
+  '(["\\.Z~?\\'"
+     "compressing"    "compress"     ("-c")
+     "uncompressing"  "uncompress"   ("-c")
+     nil t]
+    ["\\.gz~?\\'"
+     "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 magic compress-name compress-program compress-discard-err
+compress-args uncompress-name uncompress-program uncompress-discard-err
+uncompress-args append-flag extension] where:
+
+   regexp                is a regexp that matches filenames that are
+                         compressed with this format
+
+   compress-program      is a program that performs this compression
+
+   compress-args         is a list of args to pass to the compress program
+
+   uncompress-message    is the message to issue to the user when this
+                         type of uncompression is taking place (nil
+                         means don't issue any 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.")
+
+
+;;; 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))
+
+
+(defvar jka-compr-acceptable-retval-list '(0 141))
+
+
+(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))
+
+     (and errfile
+	  (insert-file-contents errfile))
+
+     (set-buffer curbuf)
+     (display-buffer errbuf))
+
+  (signal 'compression-error (list "Opening input file" (format "error %s" message) infile)))
+			
+   
+(defvar jka-compr-dd-program
+  "/bin/dd")
+
+
+(defvar jka-compr-dd-blocksize 512)
+
+
+(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 discard.  All output is discarded unless it comes within LEN chars after
+the BEGth char."
+
+  (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))
+	 (end (and count (+ start (* count jka-compr-dd-blocksize))))
+	 (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
+			     (if count (concat "count=" 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))
+
+    (and
+     end
+     (delete-region (+ start prefix len) end))
+
+    (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)))
+	    
+	(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 (zerop
+	 (apply 'call-process
+		prog
+		infile
+		(if (stringp output) temp output)
+		nil
+		args))
+	(jka-compr-error prog args infile message))
+
+    (and (stringp output)
+	 (let ((cbuf (current-buffer)))
+	   (set-buffer temp)
+	   (write-region (point-min) (point-max) output)
+	   (erase-buffer)
+	   (set-buffer cbuf)))))
+
+
+;;; Support for temp files.  Much of this was inspired if not lifted
+;;; from ange-ftp.
+
+(defvar jka-compr-temp-name-template
+  "/tmp/jka-com"
+  "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))
+
+(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)
+
+    (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)))
+
+
+(defun jka-compr-write-region (start end file &optional append visit)
+  "Documented as original."
+  (interactive "r\nFWrite region to file: ")
+
+  (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))
+		(temp-file (jka-compr-make-temp-name))
+		(base-name (file-name-nondirectory visit-file))
+		cbuf temp-buffer)
+
+	    (setq cbuf (current-buffer)
+		  temp-buffer (get-buffer-create " *jka-compr-temp*"))
+	    (set-buffer temp-buffer)
+	    (widen) (erase-buffer)
+	    (set-buffer cbuf)
+
+	    (and append
+		 (not can-append)
+		 (file-exists-p filename)
+		 (let* ((local-copy (file-local-copy filename))
+			(local-file (or local-copy filename)))
+
+		   (unwind-protect
+
+		       (progn
+		      
+			 (and
+			  uncompress-message
+			  (message "%s %s..." uncompress-message base-name))
+
+			 (jka-compr-call-process uncompress-program
+						 (concat uncompress-message
+							 " " base-name)
+						 local-file
+						 temp-file
+						 temp-buffer
+						 uncompress-args)
+			 (and
+			  uncompress-message
+			  (message "%s %s...done" uncompress-message base-name)))
+		     
+		     (and
+		      local-copy
+		      (file-exists-p local-copy)
+		      (delete-file local-copy)))))
+
+	    (and 
+	     compress-message
+	     (message "%s %s..." compress-message base-name))
+
+	    (write-region start end temp-file t 'dont)
+
+	    (jka-compr-call-process compress-program
+				    (concat compress-message
+					    " " base-name)
+				    temp-file
+				    temp-buffer
+				    nil
+				    compress-args)
+
+	    (set-buffer temp-buffer)
+	    (write-region (point-min) (point-max)
+			  filename (and append can-append) 'dont)
+	    (erase-buffer)
+	    (set-buffer cbuf)
+
+	    (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)
+	      (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))
+
+	    nil)
+	      
+	(write-region start end filename append visit))))
+
+
+(defun jka-compr-insert-file-contents (file &optional visit beg end)
+  "Documented as original."
+
+  (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 (file-local-copy 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
+
+		    (progn
+		      (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))
+			(jka-compr-call-process uncompress-program
+						(concat uncompress-message
+							" " base-name)
+						local-file
+						t
+						nil
+						uncompress-args))
+		      (setq size (- (point) start))
+		      (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)))
+
+	  (and
+	   visit
+	   (progn
+	     (setq buffer-file-name filename)
+	     (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))))
+
+	  (list filename size))
+
+      (insert-file-contents file visit beg end))))
+
+
+(defun jka-compr-file-local-copy (file)
+  "Documented as original."
+
+  (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 (file-local-copy filename))
+	      (temp-file (jka-compr-make-temp-name t))
+	      (temp-buffer (get-buffer-create " *jka-compr-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)
+
+		(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)
+	    
+      (file-local-copy 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
+
+	(progn
+
+	  (setq file-name-handler-alist
+		(cons jka-compr-file-name-handler-entry
+		      file-name-handler-alist))
+
+	  (or nomessage
+	      (message "Loading %s..." file))
+
+	  (load load-file noerror t t)
+
+	  (or nomessage
+	      (message "Loading %s...done." file)))
+
+      (setq file-name-handler-alist
+	    (delq jka-compr-file-name-handler-entry
+		  file-name-handler-alist))
+
+      (jka-compr-delete-temp-file local-copy))
+
+    t))
+
+
+(defvar jka-compr-file-name-handler-entry
+  nil
+  "The entry in file-name-handler-alist used by the jka-compr I/O functions.")
+
+
+(defun jka-compr-handler (operation &rest args)
+
+  (let ((jka-op (intern-soft (symbol-name operation) jka-compr-op-table)))
+
+    (unwind-protect
+	(progn
+	  (setq file-name-handler-alist
+		(delq jka-compr-file-name-handler-entry
+		      file-name-handler-alist))
+	  (if jka-op
+	      (apply jka-op args)
+	    (apply operation args)))
+
+      (setq file-name-handler-alist
+	    (cons jka-compr-file-name-handler-entry
+		  file-name-handler-alist)))))
+
+  
+(defvar jka-compr-op-table
+  (make-vector 127 0)
+  "Hash table of operations supported by jka-compr")
+
+
+(defun jka-compr-intern-operation (op)
+  (let ((opsym (intern (symbol-name op) jka-compr-op-table))
+	(jka-fn (intern (concat "jka-compr-" (symbol-name op)))))
+    (fset opsym jka-fn)))
+
+
+(defvar jka-compr-operation-list
+  '(
+    write-region
+    insert-file-contents
+    file-local-copy
+    load
+    )
+  "List of file operations implemented by jka-compr.")
+
+
+(mapcar
+ (function
+  (lambda (fn)
+    (jka-compr-intern-operation fn)))
+ jka-compr-operation-list)
+
+
+(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.
+Appropriate entries are added to file-name-handler-alist and auto-mode-alist."
+
+  (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)
+		(setq auto-mode-alist (cons (list (jka-compr-info-regexp x)
+						  nil 'jka-compr)
+					    auto-mode-alist)))))
+
+   jka-compr-compression-info-list))
+
+
+(defun jka-compr-uninstall ()
+  "Uninstall jka-compr.
+Entries in file-name-handler-alist and auto-mode-alist that were created by
+jka-compr-installed are removed."
+
+  (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 (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))))
+
+      
+(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))
+
+(jka-compr-install)
+
+
+(provide 'jka-compr)
+
+;; jka-compr.el ends here.