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