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