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

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