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