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