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