code.delx.au - gnu-emacs/blob - lisp/jka-compr.el

   1 ;;; jka-compr.el --- reading/writing/loading compressed files
   2
   3 ;; Copyright (C) 1993-1995, 1997, 1999-2013 Free Software Foundation,
   4 ;; Inc.
   5
   6 ;; Author: jka@ece.cmu.edu (Jay K. Adams)
   7 ;; Maintainer: FSF
   8 ;; Keywords: data
   9
  10 ;; This file is part of GNU Emacs.
  11
  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 of the License, or
  15 ;; (at your option) any later version.
  16
  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.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26
  27 ;; This package implements low-level support for reading, writing,
  28 ;; and loading compressed files.  It hooks into the low-level file
  29 ;; I/O functions (including write-region and insert-file-contents) so
  30 ;; that they automatically compress or uncompress a file if the file
  31 ;; appears to need it (based on the extension of the file name).
  32 ;; Packages like Rmail, VM, GNUS, and Info should be able to work
  33 ;; with compressed files without modification.
  34
  35
  36 ;; INSTRUCTIONS:
  37 ;;
  38 ;; To use jka-compr, invoke the command `auto-compression-mode' (which
  39 ;; see), or customize the variable of the same name.  Its operation
  40 ;; should be transparent to the user (except for messages appearing when
  41 ;; a file is being compressed or uncompressed).
  42 ;;
  43 ;; The variable, jka-compr-compression-info-list can be used to
  44 ;; customize jka-compr to work with other compression programs.
  45 ;; The default value of this variable allows jka-compr to work with
  46 ;; Unix compress and gzip.
  47 ;;
  48 ;; If you don't want messages about compressing and decompressing
  49 ;; to show up in the echo area, you can set the compress-msg and
  50 ;; decompress-msg fields of the jka-compr-compression-info-list to
  51 ;; nil.
  52
  53
  54 ;; APPLICATION NOTES:
  55 ;;
  56 ;; crypt++
  57 ;;   jka-compr can coexist with crypt++ if you take all the decompression
  58 ;;   entries out of the crypt-encoding-list.  Clearly problems will arise if
  59 ;;   you have two programs trying to compress/decompress files.  jka-compr
  60 ;;   will not "work with" crypt++ in the following sense: you won't be able to
  61 ;;   decode encrypted compressed files--that is, files that have been
  62 ;;   compressed then encrypted (in that order).  Theoretically, crypt++ and
  63 ;;   jka-compr could properly handle a file that has been encrypted then
  64 ;;   compressed, but there is little point in trying to compress an encrypted
  65 ;;   file.
  66 ;;
  67
  68
  69 ;; ACKNOWLEDGMENTS
  70 ;;
  71 ;; jka-compr is a V19 adaptation of jka-compr for V18 of Emacs.  Many people
  72 ;; have made helpful suggestions, reported bugs, and even fixed bugs in
  73 ;; jka-compr.  I recall the following people as being particularly helpful.
  74 ;;
  75 ;;   Jean-loup Gailly
  76 ;;   David Hughes
  77 ;;   Richard Pieri
  78 ;;   Daniel Quinlan
  79 ;;   Chris P. Ross
  80 ;;   Rick Sladkey
  81 ;;
  82 ;; Andy Norman's ange-ftp was the inspiration for the original jka-compr for
  83 ;; Version 18 of Emacs.
  84 ;;
  85 ;; After I had made progress on the original jka-compr for V18, I learned of a
  86 ;; package written by Kazushi Jam Marukawa, called jam-zcat, that did exactly
  87 ;; what I was trying to do.  I looked over the jam-zcat source code and
  88 ;; probably got some ideas from it.
  89 ;;
  90
  91 ;;; Code:
  92
  93 (require 'jka-cmpr-hook)
  94
  95 (defcustom jka-compr-shell "sh"
  96   "Shell to be used for calling compression programs.
  97 NOTE: Not used in MS-DOS and Windows systems."
  98   :type 'string
  99   :group 'jka-compr)
 100
 101 (defvar jka-compr-use-shell
 102   (not (memq system-type '(ms-dos windows-nt))))
 103
 104 (defvar jka-compr-really-do-compress nil
 105   "Non-nil in a buffer whose visited file was uncompressed on visiting it.
 106 This means compress the data on writing the file, even if the
 107 data appears to be compressed already.")
 108 (make-variable-buffer-local 'jka-compr-really-do-compress)
 109 (put 'jka-compr-really-do-compress 'permanent-local t)
 110 \f
 111
 112 (put 'compression-error 'error-conditions '(compression-error file-error error))
 113
 114
 115 (defvar jka-compr-acceptable-retval-list '(0 2 141))
 116
 117
 118 (defun jka-compr-error (prog args infile message &optional errfile)
 119
 120   (let ((errbuf (get-buffer-create " *jka-compr-error*")))
 121     (with-current-buffer errbuf
 122       (widen) (erase-buffer)
 123       (insert (format "Error while executing \"%s %s < %s\"\n\n"
 124                       prog
 125                       (mapconcat 'identity args " ")
 126                       infile))
 127
 128       (and errfile
 129            (insert-file-contents errfile)))
 130      (display-buffer errbuf))
 131
 132   (signal 'compression-error
 133           (list "Opening input file" (format "error %s" message) infile)))
 134
 135
 136 (defcustom jka-compr-dd-program "/bin/dd"
 137   "How to invoke `dd'."
 138   :type 'string
 139   :group 'jka-compr)
 140
 141
 142 (defvar jka-compr-dd-blocksize 256)
 143
 144
 145 (defun jka-compr-partial-uncompress (prog message args infile beg len)
 146   "Call program PROG with ARGS args taking input from INFILE.
 147 Fourth and fifth args, BEG and LEN, specify which part of the output
 148 to keep: LEN chars starting BEG chars from the beginning."
 149   (let ((start (point))
 150         (prefix beg))
 151     (if (and jka-compr-use-shell jka-compr-dd-program)
 152         ;; Put the uncompression output through dd
 153         ;; to discard the part we don't want.
 154         (let ((skip (/ beg jka-compr-dd-blocksize))
 155               (err-file (jka-compr-make-temp-name))
 156               ;; call-process barfs if default-directory is inaccessible.
 157               (default-directory
 158                 (if (and default-directory
 159                          (file-accessible-directory-p default-directory))
 160                     default-directory
 161                   (file-name-directory infile)))
 162               count)
 163           ;; Update PREFIX based on the text that we won't read in.
 164           (setq prefix (- beg (* skip jka-compr-dd-blocksize))
 165                 count (and len (1+ (/ (+ len prefix) jka-compr-dd-blocksize))))
 166           (unwind-protect
 167               (or (memq (call-process
 168                          jka-compr-shell infile t nil "-c"
 169                          ;; Windows shells need the program file name
 170                          ;; after the pipe symbol be quoted if they use
 171                          ;; forward slashes as directory separators.
 172                          (format
 173                           "%s %s 2> %s | \"%s\" bs=%d skip=%d %s 2> %s"
 174                           prog
 175                           (mapconcat 'identity args " ")
 176                           err-file
 177                           jka-compr-dd-program
 178                           jka-compr-dd-blocksize
 179                           skip
 180                           ;; dd seems to be unreliable about
 181                           ;; providing the last block.  So, always
 182                           ;; read one more than you think you need.
 183                           (if count (format "count=%d" (1+ count)) "")
 184                           null-device))
 185                         jka-compr-acceptable-retval-list)
 186                   (jka-compr-error prog args infile message err-file))
 187             (delete-file err-file)))
 188
 189       ;; Run the uncompression program directly.
 190       ;; We get the whole file and must delete what we don't want.
 191       (jka-compr-call-process prog message infile t nil args))
 192
 193     ;; Delete the stuff after what we want, if there is any.
 194     (and
 195      len
 196      (< (+ start prefix len) (point))
 197      (delete-region (+ start prefix len) (point)))
 198
 199     ;; Delete the stuff before what we want.
 200     (delete-region start (+ start prefix))))
 201
 202
 203 (defun jka-compr-call-process (prog message infile output temp args)
 204   ;; call-process barfs if default-directory is inaccessible.
 205   (let ((default-directory
 206           (if (and default-directory
 207                    (not (file-remote-p default-directory))
 208                    (file-accessible-directory-p default-directory))
 209               default-directory
 210             (file-name-directory infile))))
 211     (if jka-compr-use-shell
 212         (let ((err-file (jka-compr-make-temp-name))
 213               (coding-system-for-read (or coding-system-for-read 'undecided))
 214               (coding-system-for-write 'no-conversion))
 215           (unwind-protect
 216               (or (memq
 217                    (call-process jka-compr-shell infile
 218                                  (if (stringp output) nil output)
 219                                  nil
 220                                  "-c"
 221                                  (format "%s %s 2> %s %s"
 222                                          prog
 223                                          (mapconcat 'identity args " ")
 224                                          err-file
 225                                          (if (stringp output)
 226                                              (concat "> " output)
 227                                            "")))
 228                    jka-compr-acceptable-retval-list)
 229                   (jka-compr-error prog args infile message err-file))
 230             (delete-file err-file)))
 231       (or (eq 0
 232               (apply 'call-process
 233                      prog infile (if (stringp output) temp output)
 234                      nil args))
 235           (jka-compr-error prog args infile message))
 236       (and (stringp output)
 237            (with-current-buffer temp
 238              (write-region (point-min) (point-max) output)
 239              (erase-buffer))))))
 240
 241
 242 ;; Support for temp files.  Much of this was inspired if not lifted
 243 ;; from ange-ftp.
 244
 245 (defcustom jka-compr-temp-name-template
 246   (expand-file-name "jka-com" temporary-file-directory)
 247   "Prefix added to all temp files created by jka-compr.
 248 There should be no more than seven characters after the final `/'."
 249   :type 'string
 250   :group 'jka-compr)
 251
 252 (defun jka-compr-make-temp-name (&optional _local-copy)
 253   "This routine will return the name of a new file."
 254   (make-temp-file jka-compr-temp-name-template))
 255
 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))))
 261
 262     ;; If we uncompressed this file when visiting it,
 263     ;; then recompress it when writing it
 264     ;; even if the contents look compressed already.
 265     (if (and jka-compr-really-do-compress
 266              (or (null start)
 267                  (= (- end start) (buffer-size))))
 268         (setq magic nil))
 269
 270     (if (and info
 271              ;; If the contents to be written out
 272              ;; are properly compressed already,
 273              ;; don't try to compress them over again.
 274              (not (and magic
 275                        (equal (if (stringp start)
 276                                   (substring start 0 (min (length start)
 277                                                           (length magic)))
 278                                 (let* ((from (or start (point-min)))
 279                                        (to (min (or end (point-max))
 280                                                 (+ from (length magic)))))
 281                                   (buffer-substring from to)))
 282                               magic))))
 283         (let ((can-append (jka-compr-info-can-append info))
 284               (compress-program (jka-compr-info-compress-program info))
 285               (compress-message (jka-compr-info-compress-message info))
 286               (compress-args (jka-compr-info-compress-args info))
 287               (base-name (file-name-nondirectory visit-file))
 288               temp-file temp-buffer
 289               ;; we need to leave `last-coding-system-used' set to its
 290               ;; value after calling write-region the first time, so
 291               ;; that `basic-save-buffer' sees the right value.
 292               (coding-system-used last-coding-system-used))
 293
 294           (or compress-program
 295               (error "No compression program defined"))
 296
 297           (setq temp-buffer (get-buffer-create " *jka-compr-wr-temp*"))
 298           (with-current-buffer temp-buffer
 299             (widen) (erase-buffer))
 300
 301           (if (and append
 302                    (not can-append)
 303                    (file-exists-p filename))
 304
 305               (let* ((local-copy (file-local-copy filename))
 306                      (local-file (or local-copy filename)))
 307
 308                 (setq temp-file local-file))
 309
 310             (setq temp-file (jka-compr-make-temp-name)))
 311
 312           (and
 313            compress-message
 314            jka-compr-verbose
 315            (message "%s %s..." compress-message base-name))
 316
 317           (jka-compr-run-real-handler 'write-region
 318                                       (list start end temp-file t 'dont))
 319           ;; save value used by the real write-region
 320           (setq coding-system-used last-coding-system-used)
 321
 322           ;; Here we must read the output of compress program as is
 323           ;; without any code conversion.
 324           (let ((coding-system-for-read 'no-conversion))
 325             (jka-compr-call-process compress-program
 326                                     (concat compress-message
 327                                             " " base-name)
 328                                     temp-file
 329                                     temp-buffer
 330                                     nil
 331                                     compress-args))
 332
 333           (with-current-buffer temp-buffer
 334             (let ((coding-system-for-write 'no-conversion))
 335               (if (memq system-type '(ms-dos windows-nt))
 336                   (setq buffer-file-type t) )
 337               (jka-compr-run-real-handler 'write-region
 338                                           (list (point-min) (point-max)
 339                                                 filename
 340                                                 (and append can-append) 'dont))
 341               (erase-buffer)) )
 342
 343           (delete-file temp-file)
 344
 345           (and
 346            compress-message
 347            jka-compr-verbose
 348            (message "%s %s...done" compress-message base-name))
 349
 350           (cond
 351            ((eq visit t)
 352             (setq buffer-file-name filename)
 353             (setq jka-compr-really-do-compress t)
 354             (set-visited-file-modtime))
 355            ((stringp visit)
 356             (setq buffer-file-name visit)
 357             (let ((buffer-file-name filename))
 358               (set-visited-file-modtime))))
 359
 360           (and (or (eq visit t)
 361                    (eq visit nil)
 362                    (stringp visit))
 363                (message "Wrote %s" visit-file))
 364
 365           ;; ensure `last-coding-system-used' has an appropriate value
 366           (setq last-coding-system-used coding-system-used)
 367
 368           nil)
 369
 370       (jka-compr-run-real-handler 'write-region
 371                                   (list start end filename append visit)))))
 372
 373
 374 (defun jka-compr-insert-file-contents (file &optional visit beg end replace)
 375   (barf-if-buffer-read-only)
 376
 377   (and (or beg end)
 378        visit
 379        (error "Attempt to visit less than an entire file"))
 380
 381   (let* ((filename (expand-file-name file))
 382          (info (jka-compr-get-compression-info filename)))
 383
 384     (if (not info)
 385
 386         (jka-compr-run-real-handler 'insert-file-contents
 387                                     (list file visit beg end replace))
 388
 389       (let ((uncompress-message (jka-compr-info-uncompress-message info))
 390             (uncompress-program (jka-compr-info-uncompress-program info))
 391             (uncompress-args (jka-compr-info-uncompress-args info))
 392             (base-name (file-name-nondirectory filename))
 393             (notfound nil)
 394             (local-copy
 395              (jka-compr-run-real-handler 'file-local-copy (list filename)))
 396             local-file
 397             size start)
 398
 399         (setq local-file (or local-copy filename))
 400
 401         (and
 402          visit
 403          (setq buffer-file-name filename))
 404
 405         (unwind-protect               ; to make sure local-copy gets deleted
 406
 407             (progn
 408
 409               (and
 410                uncompress-message
 411                jka-compr-verbose
 412                (message "%s %s..." uncompress-message base-name))
 413
 414               (condition-case error-code
 415
 416                   (let ((coding-system-for-read 'no-conversion))
 417                     (if replace
 418                         (goto-char (point-min)))
 419                     (setq start (point))
 420                     (if (or beg end)
 421                         (jka-compr-partial-uncompress uncompress-program
 422                                                       (concat uncompress-message
 423                                                               " " base-name)
 424                                                       uncompress-args
 425                                                       local-file
 426                                                       (or beg 0)
 427                                                       (if (and beg end)
 428                                                           (- end beg)
 429                                                         end))
 430                       ;; If visiting, bind off buffer-file-name so that
 431                       ;; file-locking will not ask whether we should
 432                       ;; really edit the buffer.
 433                       (let ((buffer-file-name
 434                              (if visit nil buffer-file-name)))
 435                         (jka-compr-call-process uncompress-program
 436                                                 (concat uncompress-message
 437                                                         " " base-name)
 438                                                 local-file
 439                                                 t
 440                                                 nil
 441                                                 uncompress-args)))
 442                     (setq size (- (point) start))
 443                     (if replace
 444                         (delete-region (point) (point-max)))
 445                     (goto-char start))
 446                 (error
 447                  ;; If the file we wanted to uncompress does not exist,
 448                  ;; handle that according to VISIT as `insert-file-contents'
 449                  ;; would, maybe signaling the same error it normally would.
 450                  (if (and (eq (car error-code) 'file-error)
 451                           (eq (nth 3 error-code) local-file))
 452                      (if visit
 453                          (setq notfound error-code)
 454                        (signal 'file-error
 455                                (cons "Opening input file"
 456                                      (nthcdr 2 error-code))))
 457                    ;; If the uncompression program can't be found,
 458                    ;; signal that as a non-file error
 459                    ;; so that find-file-noselect-1 won't handle it.
 460                    (if (and (eq (car error-code) 'file-error)
 461                             (equal (cadr error-code) "Searching for program"))
 462                        (error "Uncompression program `%s' not found"
 463                               (nth 3 error-code)))
 464                    (signal (car error-code) (cdr error-code))))))
 465
 466           (and
 467            local-copy
 468            (file-exists-p local-copy)
 469            (delete-file local-copy)))
 470
 471         (unless notfound
 472           (decode-coding-inserted-region
 473            (point) (+ (point) size)
 474            (jka-compr-byte-compiler-base-file-name file)
 475            visit beg end replace))
 476
 477         (and
 478          visit
 479          (progn
 480            (unlock-buffer)
 481            (setq buffer-file-name filename)
 482            (setq jka-compr-really-do-compress t)
 483            (set-visited-file-modtime)))
 484
 485         (and
 486          uncompress-message
 487          jka-compr-verbose
 488          (message "%s %s...done" uncompress-message base-name))
 489
 490         (and
 491          visit
 492          notfound
 493          (signal 'file-error
 494                  (cons "Opening input file" (nth 2 notfound))))
 495
 496         ;; This is done in insert-file-contents after we return.
 497         ;; That is a little weird, but better to go along with it now
 498         ;; than to change it now.
 499
 500         ;; ;; Run the functions that insert-file-contents would.
 501         ;; (let ((p after-insert-file-functions)
 502         ;;       (insval size))
 503         ;;   (while p
 504         ;;     (setq insval (funcall (car p) size))
 505         ;;     (if insval
 506         ;;         (progn
 507         ;;           (or (integerp insval)
 508         ;;              (signal 'wrong-type-argument
 509         ;;                      (list 'integerp insval)))
 510         ;;           (setq size insval)))
 511         ;;     (setq p (cdr p))))
 512
 513         (or (jka-compr-info-compress-program info)
 514             (message "You can't save this buffer because compression program is not defined"))
 515
 516         (list filename size)))))
 517
 518
 519 (defun jka-compr-file-local-copy (file)
 520   (let* ((filename (expand-file-name file))
 521          (info (jka-compr-get-compression-info filename)))
 522
 523     (if info
 524
 525         (let ((uncompress-message (jka-compr-info-uncompress-message info))
 526               (uncompress-program (jka-compr-info-uncompress-program info))
 527               (uncompress-args (jka-compr-info-uncompress-args info))
 528               (base-name (file-name-nondirectory filename))
 529               (local-copy
 530                (jka-compr-run-real-handler 'file-local-copy (list filename)))
 531               (temp-file (jka-compr-make-temp-name t))
 532               (temp-buffer (get-buffer-create " *jka-compr-flc-temp*"))
 533               local-file)
 534
 535           (setq local-file (or local-copy filename))
 536
 537           (unwind-protect
 538
 539               (with-current-buffer temp-buffer
 540
 541                 (and
 542                  uncompress-message
 543                  jka-compr-verbose
 544                  (message "%s %s..." uncompress-message base-name))
 545
 546                 ;; Here we must read the output of uncompress program
 547                 ;; and write it to TEMP-FILE without any code
 548                 ;; conversion.  An appropriate code conversion (if
 549                 ;; necessary) is done by the later I/O operation
 550                 ;; (e.g. load).
 551                 (let ((coding-system-for-read 'no-conversion)
 552                       (coding-system-for-write 'no-conversion))
 553
 554                   (jka-compr-call-process uncompress-program
 555                                           (concat uncompress-message
 556                                                   " " base-name)
 557                                           local-file
 558                                           t
 559                                           nil
 560                                           uncompress-args)
 561
 562                   (and
 563                    uncompress-message
 564                    jka-compr-verbose
 565                    (message "%s %s...done" uncompress-message base-name))
 566
 567                   (write-region
 568                    (point-min) (point-max) temp-file nil 'dont)))
 569
 570             (and
 571              local-copy
 572              (file-exists-p local-copy)
 573              (delete-file local-copy))
 574
 575             (kill-buffer temp-buffer))
 576
 577           temp-file)
 578
 579       (jka-compr-run-real-handler 'file-local-copy (list filename)))))
 580
 581
 582 ;; Support for loading compressed files.
 583 (defun jka-compr-load (file &optional noerror nomessage _nosuffix)
 584   "Documented as original."
 585
 586   (let* ((local-copy (jka-compr-file-local-copy file))
 587          (load-file (or local-copy file)))
 588
 589     (unwind-protect
 590
 591         (let (inhibit-file-name-operation
 592               inhibit-file-name-handlers)
 593           (or nomessage
 594               (message "Loading %s..." file))
 595
 596           (let ((load-force-doc-strings t))
 597             (load load-file noerror t t))
 598           (or nomessage
 599               (message "Loading %s...done." file))
 600           ;; Fix up the load history to point at the right library.
 601           (let ((l (or (assoc load-file load-history)
 602                        ;; On MS-Windows, if load-file is in
 603                        ;; temporary-file-directory, it will look like
 604                        ;; "c:/DOCUME~1/USER/LOCALS~1/foo", whereas
 605                        ;; readevalloop will record its truename in
 606                        ;; load-history.  Therefore try truename if the
 607                        ;; original name is not in load-history.
 608                        (assoc (file-truename load-file) load-history))))
 609             ;; Remove .gz and .elc?.
 610             (while (file-name-extension file)
 611               (setq file (file-name-sans-extension file)))
 612             (setcar l file)))
 613
 614       (delete-file local-copy))
 615
 616     t))
 617
 618 (defun jka-compr-byte-compiler-base-file-name (file)
 619   (let ((info (jka-compr-get-compression-info file)))
 620     (if (and info (jka-compr-info-strip-extension info))
 621         (save-match-data
 622           (substring file 0 (string-match (jka-compr-info-regexp info) file)))
 623       file)))
 624 \f
 625 (put 'write-region 'jka-compr 'jka-compr-write-region)
 626 (put 'insert-file-contents 'jka-compr 'jka-compr-insert-file-contents)
 627 (put 'file-local-copy 'jka-compr 'jka-compr-file-local-copy)
 628 (put 'load 'jka-compr 'jka-compr-load)
 629 (put 'byte-compiler-base-file-name 'jka-compr
 630      'jka-compr-byte-compiler-base-file-name)
 631
 632 ;;;###autoload
 633 (defvar jka-compr-inhibit nil
 634   "Non-nil means inhibit automatic uncompression temporarily.
 635 Lisp programs can bind this to t to do that.
 636 It is not recommended to set this variable permanently to anything but nil.")
 637
 638 ;;;###autoload
 639 (defun jka-compr-handler (operation &rest args)
 640   (save-match-data
 641     (let ((jka-op (get operation 'jka-compr)))
 642       (if (and jka-op (not jka-compr-inhibit))
 643           (apply jka-op args)
 644         (jka-compr-run-real-handler operation args)))))
 645
 646 ;; If we are given an operation that we don't handle,
 647 ;; call the Emacs primitive for that operation,
 648 ;; and manipulate the inhibit variables
 649 ;; to prevent the primitive from calling our handler again.
 650 (defun jka-compr-run-real-handler (operation args)
 651   (let ((inhibit-file-name-handlers
 652          (cons 'jka-compr-handler
 653                (and (eq inhibit-file-name-operation operation)
 654                     inhibit-file-name-handlers)))
 655         (inhibit-file-name-operation operation))
 656     (apply operation args)))
 657
 658 ;;;###autoload
 659 (defun jka-compr-uninstall ()
 660   "Uninstall jka-compr.
 661 This removes the entries in `file-name-handler-alist' and `auto-mode-alist'
 662 and `inhibit-local-variables-suffixes' that were added
 663 by `jka-compr-installed'."
 664   ;; Delete from inhibit-local-variables-suffixes what jka-compr-install added.
 665   (mapc
 666      (function (lambda (x)
 667                  (and (jka-compr-info-strip-extension x)
 668                       (setq inhibit-local-variables-suffixes
 669                             (delete (jka-compr-info-regexp x)
 670                                     inhibit-local-variables-suffixes)))))
 671      jka-compr-compression-info-list--internal)
 672
 673   (let* ((fnha (cons nil file-name-handler-alist))
 674          (last fnha))
 675
 676     (while (cdr last)
 677       (if (eq (cdr (car (cdr last))) 'jka-compr-handler)
 678           (setcdr last (cdr (cdr last)))
 679         (setq last (cdr last))))
 680
 681     (setq file-name-handler-alist (cdr fnha)))
 682
 683   (let* ((ama (cons nil auto-mode-alist))
 684          (last ama)
 685          entry)
 686
 687     (while (cdr last)
 688       (setq entry (car (cdr last)))
 689       (if (or (member entry jka-compr-mode-alist-additions--internal)
 690               (and (consp (cdr entry))
 691                    (eq (nth 2 entry) 'jka-compr)))
 692           (setcdr last (cdr (cdr last)))
 693         (setq last (cdr last))))
 694
 695     (setq auto-mode-alist (cdr ama)))
 696
 697   (while jka-compr-added-to-file-coding-system-alist
 698     (setq file-coding-system-alist
 699           (delq (car (member (pop jka-compr-added-to-file-coding-system-alist)
 700                              file-coding-system-alist))
 701                 file-coding-system-alist)))
 702
 703   ;; Remove the suffixes that were added by jka-compr.
 704   (dolist (suff jka-compr-load-suffixes--internal)
 705     (setq load-file-rep-suffixes (delete suff load-file-rep-suffixes)))
 706
 707   (setq jka-compr-compression-info-list--internal nil
 708         jka-compr-mode-alist-additions--internal nil
 709         jka-compr-load-suffixes--internal nil))
 710
 711 (provide 'jka-compr)
 712
 713 ;;; jka-compr.el ends here