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  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., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, 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, simply load this package, and edit as usual.
  40 ;; Its operation should be transparent to the user (except for
  41 ;; messages appearing when a file is being compressed or
  42 ;; 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 crpyt++ 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 (defgroup compression nil
 104   "Data compression utilities"
 105   :group 'data)
 106
 107 (defgroup jka-compr nil
 108   "jka-compr customization"
 109   :group 'compression)
 110
 111
 112 (defcustom jka-compr-shell "sh"
 113   "*Shell to be used for calling compression programs.
 114 The value of this variable only matters if you want to discard the
 115 stderr of a compression/decompression program (see the documentation
 116 for `jka-compr-compression-info-list')."
 117   :type 'string
 118   :group 'jka-compr)
 119
 120 (defvar jka-compr-use-shell
 121   (not (memq system-type '(ms-dos windows-nt))))
 122
 123 ;;; I have this defined so that .Z files are assumed to be in unix
 124 ;;; compress format; and .gz files, in gzip format, and .bz2 files in bzip fmt.
 125 (defcustom jka-compr-compression-info-list
 126   ;;[regexp
 127   ;; compr-message  compr-prog  compr-args
 128   ;; uncomp-message uncomp-prog uncomp-args
 129   ;; can-append auto-mode-flag]
 130   '(["\\.Z\\(~\\|\\.~[0-9]+~\\)?\\'"
 131      "compressing"    "compress"     ("-c")
 132      "uncompressing"  "uncompress"   ("-c")
 133      nil t]
 134     ["\\.bz2\\'"
 135      "bzip2ing"        "bzip2"         ("-c")
 136      "bunzip2ing"      "bzip2"         ("-d" "-c")
 137      nil t]
 138     ["\\.tgz\\'"
 139      "zipping"        "gzip"         ("-c" "-q")
 140      "unzipping"      "gzip"         ("-c" "-q" "-d")
 141      t nil]
 142     ["\\.gz\\(~\\|\\.~[0-9]+~\\)?\\'"
 143      "zipping"        "gzip"         ("-c" "-q")
 144      "unzipping"      "gzip"         ("-c" "-q" "-d")
 145      t t])
 146
 147   "List of vectors that describe available compression techniques.
 148 Each element, which describes a compression technique, is a vector of
 149 the form [REGEXP COMPRESS-MSG COMPRESS-PROGRAM COMPRESS-ARGS
 150 UNCOMPRESS-MSG UNCOMPRESS-PROGRAM UNCOMPRESS-ARGS
 151 APPEND-FLAG EXTENSION], where:
 152
 153    regexp                is a regexp that matches filenames that are
 154                          compressed with this format
 155
 156    compress-msg          is the message to issue to the user when doing this
 157                          type of compression (nil means no message)
 158
 159    compress-program      is a program that performs this compression
 160
 161    compress-args         is a list of args to pass to the compress program
 162
 163    uncompress-msg        is the message to issue to the user when doing this
 164                          type of uncompression (nil means no message)
 165
 166    uncompress-program    is a program that performs this compression
 167
 168    uncompress-args       is a list of args to pass to the uncompress program
 169
 170    append-flag           is non-nil if this compression technique can be
 171                          appended
 172
 173    auto-mode flag        non-nil means strip the regexp from file names
 174                          before attempting to set the mode.
 175
 176 Because of the way `call-process' is defined, discarding the stderr output of
 177 a program adds the overhead of starting a shell each time the program is
 178 invoked."
 179   :type '(repeat (vector regexp
 180                          (choice :tag "Compress Message"
 181                                  (string :format "%v")
 182                                  (const :tag "No Message" nil))
 183                          (string :tag "Compress Program")
 184                          (repeat :tag "Compress Arguments" string)
 185                          (choice :tag "Uncompress Message"
 186                                  (string :format "%v")
 187                                  (const :tag "No Message" nil))
 188                          (string :tag "Uncompress Program")
 189                          (repeat :tag "Uncompress Arguments" string)
 190                          (boolean :tag "Append")
 191                          (boolean :tag "Auto Mode")))
 192   :group 'jka-compr)
 193
 194 (defvar jka-compr-mode-alist-additions
 195   (list (cons "\\.tgz\\'" 'tar-mode))
 196   "A list of pairs to add to `auto-mode-alist' when jka-compr is installed.")
 197
 198 ;; List of all the elements we actually added to file-coding-system-alist.
 199 (defvar jka-compr-added-to-file-coding-system-alist nil)
 200
 201 (defvar jka-compr-file-name-handler-entry
 202   nil
 203   "The entry in `file-name-handler-alist' used by the jka-compr I/O functions.")
 204 \f
 205 ;;; Functions for accessing the return value of jka-compr-get-compression-info
 206 (defun jka-compr-info-regexp               (info)  (aref info 0))
 207 (defun jka-compr-info-compress-message     (info)  (aref info 1))
 208 (defun jka-compr-info-compress-program     (info)  (aref info 2))
 209 (defun jka-compr-info-compress-args        (info)  (aref info 3))
 210 (defun jka-compr-info-uncompress-message   (info)  (aref info 4))
 211 (defun jka-compr-info-uncompress-program   (info)  (aref info 5))
 212 (defun jka-compr-info-uncompress-args      (info)  (aref info 6))
 213 (defun jka-compr-info-can-append           (info)  (aref info 7))
 214 (defun jka-compr-info-strip-extension      (info)  (aref info 8))
 215
 216
 217 (defun jka-compr-get-compression-info (filename)
 218   "Return information about the compression scheme of FILENAME.
 219 The determination as to which compression scheme, if any, to use is
 220 based on the filename itself and `jka-compr-compression-info-list'."
 221   (catch 'compression-info
 222     (let ((case-fold-search nil))
 223       (mapcar
 224        (function (lambda (x)
 225                    (and (string-match (jka-compr-info-regexp x) filename)
 226                         (throw 'compression-info x))))
 227        jka-compr-compression-info-list)
 228       nil)))
 229
 230
 231 (put 'compression-error 'error-conditions '(compression-error file-error error))
 232
 233
 234 (defvar jka-compr-acceptable-retval-list '(0 2 141))
 235
 236
 237 (defun jka-compr-error (prog args infile message &optional errfile)
 238
 239   (let ((errbuf (get-buffer-create " *jka-compr-error*"))
 240         (curbuf (current-buffer)))
 241     (with-current-buffer errbuf
 242       (widen) (erase-buffer)
 243       (insert (format "Error while executing \"%s %s < %s\"\n\n"
 244                       prog
 245                       (mapconcat 'identity args " ")
 246                       infile))
 247
 248       (and errfile
 249            (insert-file-contents errfile)))
 250      (display-buffer errbuf))
 251
 252   (signal 'compression-error
 253           (list "Opening input file" (format "error %s" message) infile)))
 254
 255
 256 (defvar jka-compr-dd-program
 257   "/bin/dd")
 258
 259
 260 (defvar jka-compr-dd-blocksize 256)
 261
 262
 263 (defun jka-compr-partial-uncompress (prog message args infile beg len)
 264   "Call program PROG with ARGS args taking input from INFILE.
 265 Fourth and fifth args, BEG and LEN, specify which part of the output
 266 to keep: LEN chars starting BEG chars from the beginning."
 267   (let* ((skip (/ beg jka-compr-dd-blocksize))
 268          (prefix (- beg (* skip jka-compr-dd-blocksize)))
 269          (count (and len (1+ (/ (+ len prefix) jka-compr-dd-blocksize))))
 270          (start (point))
 271          (err-file (jka-compr-make-temp-name))
 272          (run-string (format "%s %s 2> %s | %s bs=%d skip=%d %s 2> /dev/null"
 273                              prog
 274                              (mapconcat 'identity args " ")
 275                              err-file
 276                              jka-compr-dd-program
 277                              jka-compr-dd-blocksize
 278                              skip
 279                              ;; dd seems to be unreliable about
 280                              ;; providing the last block.  So, always
 281                              ;; read one more than you think you need.
 282                              (if count (concat "count=" (1+ count)) ""))))
 283
 284     (unwind-protect
 285         (or (memq (call-process jka-compr-shell
 286                                 infile t nil "-c"
 287                                 run-string)
 288                   jka-compr-acceptable-retval-list)
 289
 290             (jka-compr-error prog args infile message err-file))
 291
 292       (jka-compr-delete-temp-file err-file))
 293
 294     ;; Delete the stuff after what we want, if there is any.
 295     (and
 296      len
 297      (< (+ start prefix len) (point))
 298      (delete-region (+ start prefix len) (point)))
 299
 300     ;; Delete the stuff before what we want.
 301     (delete-region start (+ start prefix))))
 302
 303
 304 (defun jka-compr-call-process (prog message infile output temp args)
 305   (if jka-compr-use-shell
 306
 307       (let ((err-file (jka-compr-make-temp-name))
 308             (coding-system-for-read (or coding-system-for-read 'undecided))
 309             (coding-system-for-write 'no-conversion))
 310
 311         (unwind-protect
 312
 313             (or (memq
 314                  (call-process jka-compr-shell infile
 315                                (if (stringp output) nil output)
 316                                nil
 317                                "-c"
 318                                (format "%s %s 2> %s %s"
 319                                        prog
 320                                        (mapconcat 'identity args " ")
 321                                        err-file
 322                                        (if (stringp output)
 323                                            (concat "> " output)
 324                                          "")))
 325                  jka-compr-acceptable-retval-list)
 326
 327                 (jka-compr-error prog args infile message err-file))
 328
 329           (jka-compr-delete-temp-file err-file)))
 330
 331     (or (zerop
 332          (apply 'call-process
 333                 prog
 334                 infile
 335                 (if (stringp output) temp output)
 336                 nil
 337                 args))
 338         (jka-compr-error prog args infile message))
 339
 340     (and (stringp output)
 341          (with-current-buffer temp
 342            (write-region (point-min) (point-max) output)
 343            (erase-buffer)))))
 344
 345
 346 ;;; Support for temp files.  Much of this was inspired if not lifted
 347 ;;; from ange-ftp.
 348
 349 (defcustom jka-compr-temp-name-template
 350   (expand-file-name "jka-com" temporary-file-directory)
 351   "Prefix added to all temp files created by jka-compr.
 352 There should be no more than seven characters after the final `/'."
 353   :type 'string
 354   :group 'jka-compr)
 355
 356 (defvar jka-compr-temp-name-table (make-vector 31 nil))
 357
 358 (defun jka-compr-make-temp-name (&optional local-copy)
 359   "This routine will return the name of a new file."
 360   (let* ((lastchar ?a)
 361          (prevchar ?a)
 362          (template (concat jka-compr-temp-name-template "aa"))
 363          (lastpos (1- (length template)))
 364          (not-done t)
 365          file
 366          entry)
 367
 368     (while not-done
 369       (aset template lastpos lastchar)
 370       (setq file (concat (make-temp-name template) "#"))
 371       (setq entry (intern file jka-compr-temp-name-table))
 372       (if (or (get entry 'active)
 373               (file-exists-p file))
 374
 375           (progn
 376             (setq lastchar (1+ lastchar))
 377             (if (> lastchar ?z)
 378                 (progn
 379                   (setq prevchar (1+ prevchar))
 380                   (setq lastchar ?a)
 381                   (if (> prevchar ?z)
 382                       (error "Can't allocate temp file.")
 383                     (aset template (1- lastpos) prevchar)))))
 384
 385         (put entry 'active (not local-copy))
 386         (setq not-done nil)))
 387
 388     file))
 389
 390
 391 (defun jka-compr-delete-temp-file (temp)
 392
 393   (put (intern temp jka-compr-temp-name-table)
 394        'active nil)
 395
 396   (condition-case ()
 397       (delete-file temp)
 398     (error nil)))
 399
 400
 401 (defun jka-compr-write-region (start end file &optional append visit)
 402   (let* ((filename (expand-file-name file))
 403          (visit-file (if (stringp visit) (expand-file-name visit) filename))
 404          (info (jka-compr-get-compression-info visit-file)))
 405
 406       (if info
 407
 408           (let ((can-append (jka-compr-info-can-append info))
 409                 (compress-program (jka-compr-info-compress-program info))
 410                 (compress-message (jka-compr-info-compress-message info))
 411                 (uncompress-program (jka-compr-info-uncompress-program info))
 412                 (uncompress-message (jka-compr-info-uncompress-message info))
 413                 (compress-args (jka-compr-info-compress-args info))
 414                 (uncompress-args (jka-compr-info-uncompress-args info))
 415                 (base-name (file-name-nondirectory visit-file))
 416                 temp-file temp-buffer
 417                 ;; we need to leave `last-coding-system-used' set to its
 418                 ;; value after calling write-region the first time, so
 419                 ;; that `basic-save-buffer' sees the right value.
 420                 (coding-system-used last-coding-system-used))
 421
 422             (setq temp-buffer (get-buffer-create " *jka-compr-wr-temp*"))
 423             (with-current-buffer temp-buffer
 424               (widen) (erase-buffer))
 425
 426             (if (and append
 427                      (not can-append)
 428                      (file-exists-p filename))
 429
 430                 (let* ((local-copy (file-local-copy filename))
 431                        (local-file (or local-copy filename)))
 432
 433                   (setq temp-file local-file))
 434
 435               (setq temp-file (jka-compr-make-temp-name)))
 436
 437             (and
 438              compress-message
 439              (message "%s %s..." compress-message base-name))
 440
 441             (jka-compr-run-real-handler 'write-region
 442                                         (list start end temp-file t 'dont))
 443             ;; save value used by the real write-region
 444             (setq coding-system-used last-coding-system-used)
 445
 446             ;; Here we must read the output of compress program as is
 447             ;; without any code conversion.
 448             (let ((coding-system-for-read 'no-conversion))
 449               (jka-compr-call-process compress-program
 450                                       (concat compress-message
 451                                               " " base-name)
 452                                       temp-file
 453                                       temp-buffer
 454                                       nil
 455                                       compress-args))
 456
 457             (with-current-buffer temp-buffer
 458               (let ((coding-system-for-write 'no-conversion))
 459                 (if (memq system-type '(ms-dos windows-nt))
 460                     (setq buffer-file-type t) )
 461                 (jka-compr-run-real-handler 'write-region
 462                                             (list (point-min) (point-max)
 463                                                   filename
 464                                                   (and append can-append) 'dont))
 465                 (erase-buffer)) )
 466
 467             (jka-compr-delete-temp-file temp-file)
 468
 469             (and
 470              compress-message
 471              (message "%s %s...done" compress-message base-name))
 472
 473             (cond
 474              ((eq visit t)
 475               (setq buffer-file-name filename)
 476               (set-visited-file-modtime))
 477              ((stringp visit)
 478               (setq buffer-file-name visit)
 479               (let ((buffer-file-name filename))
 480                 (set-visited-file-modtime))))
 481
 482             (and (or (eq visit t)
 483                      (eq visit nil)
 484                      (stringp visit))
 485                  (message "Wrote %s" visit-file))
 486
 487             ;; ensure `last-coding-system-used' has an appropriate value
 488             (setq last-coding-system-used coding-system-used)
 489
 490             nil)
 491
 492         (jka-compr-run-real-handler 'write-region
 493                                     (list start end filename append visit)))))
 494
 495
 496 (defun jka-compr-insert-file-contents (file &optional visit beg end replace)
 497   (barf-if-buffer-read-only)
 498
 499   (and (or beg end)
 500        visit
 501        (error "Attempt to visit less than an entire file"))
 502
 503   (let* ((filename (expand-file-name file))
 504          (info (jka-compr-get-compression-info filename)))
 505
 506     (if info
 507
 508         (let ((uncompress-message (jka-compr-info-uncompress-message info))
 509               (uncompress-program (jka-compr-info-uncompress-program info))
 510               (uncompress-args (jka-compr-info-uncompress-args info))
 511               (base-name (file-name-nondirectory filename))
 512               (notfound nil)
 513               (local-copy
 514                (jka-compr-run-real-handler 'file-local-copy (list filename)))
 515               local-file
 516               size start
 517               (coding-system-for-read
 518                (or coding-system-for-read
 519                    ;; If multibyte characters are disabled,
 520                    ;; don't do that conversion.
 521                    (and (null enable-multibyte-characters)
 522                         'raw-text)
 523                    (let ((coding (find-operation-coding-system
 524                                   'insert-file-contents
 525                                   (jka-compr-byte-compiler-base-file-name file))))
 526                      (and (consp coding) (car coding)))
 527                    'undecided)) )
 528
 529           (setq local-file (or local-copy filename))
 530
 531           (and
 532            visit
 533            (setq buffer-file-name filename))
 534
 535           (unwind-protect               ; to make sure local-copy gets deleted
 536
 537               (progn
 538
 539                 (and
 540                  uncompress-message
 541                  (message "%s %s..." uncompress-message base-name))
 542
 543                 (condition-case error-code
 544
 545                     (progn
 546                       (if replace
 547                           (goto-char (point-min)))
 548                       (setq start (point))
 549                       (if (or beg end)
 550                           (jka-compr-partial-uncompress uncompress-program
 551                                                         (concat uncompress-message
 552                                                                 " " base-name)
 553                                                         uncompress-args
 554                                                         local-file
 555                                                         (or beg 0)
 556                                                         (if (and beg end)
 557                                                             (- end beg)
 558                                                           end))
 559                         ;; If visiting, bind off buffer-file-name so that
 560                         ;; file-locking will not ask whether we should
 561                         ;; really edit the buffer.
 562                         (let ((buffer-file-name
 563                                (if visit nil buffer-file-name)))
 564                           (jka-compr-call-process uncompress-program
 565                                                   (concat uncompress-message
 566                                                           " " base-name)
 567                                                   local-file
 568                                                   t
 569                                                   nil
 570                                                   uncompress-args)))
 571                       (setq size (- (point) start))
 572                       (if replace
 573                           (let* ((del-beg (point))
 574                                  (del-end (+ del-beg size)))
 575                             (delete-region del-beg
 576                                            (min del-end (point-max)))))
 577                       (goto-char start))
 578                   (error
 579                    (if (and (eq (car error-code) 'file-error)
 580                             (eq (nth 3 error-code) local-file))
 581                        (if visit
 582                            (setq notfound error-code)
 583                          (signal 'file-error
 584                                  (cons "Opening input file"
 585                                        (nthcdr 2 error-code))))
 586                      (signal (car error-code) (cdr error-code))))))
 587
 588             (and
 589              local-copy
 590              (file-exists-p local-copy)
 591              (delete-file local-copy)))
 592
 593           (and
 594            visit
 595            (progn
 596              (unlock-buffer)
 597              (setq buffer-file-name filename)
 598              (set-visited-file-modtime)))
 599
 600           (and
 601            uncompress-message
 602            (message "%s %s...done" uncompress-message base-name))
 603
 604           (and
 605            visit
 606            notfound
 607            (signal 'file-error
 608                    (cons "Opening input file" (nth 2 notfound))))
 609
 610           ;; This is done in insert-file-contents after we return.
 611           ;; That is a little weird, but better to go along with it now
 612           ;; than to change it now.
 613
 614 ;;;       ;; Run the functions that insert-file-contents would.
 615 ;;;       (let ((p after-insert-file-functions)
 616 ;;;             (insval size))
 617 ;;;         (while p
 618 ;;;           (setq insval (funcall (car p) size))
 619 ;;;           (if insval
 620 ;;;               (progn
 621 ;;;                 (or (integerp insval)
 622 ;;;                     (signal 'wrong-type-argument
 623 ;;;                             (list 'integerp insval)))
 624 ;;;                 (setq size insval)))
 625 ;;;           (setq p (cdr p))))
 626
 627           (list filename size))
 628
 629       (jka-compr-run-real-handler 'insert-file-contents
 630                                   (list file visit beg end replace)))))
 631
 632
 633 (defun jka-compr-file-local-copy (file)
 634   (let* ((filename (expand-file-name file))
 635          (info (jka-compr-get-compression-info filename)))
 636
 637     (if info
 638
 639         (let ((uncompress-message (jka-compr-info-uncompress-message info))
 640               (uncompress-program (jka-compr-info-uncompress-program info))
 641               (uncompress-args (jka-compr-info-uncompress-args info))
 642               (base-name (file-name-nondirectory filename))
 643               (local-copy
 644                (jka-compr-run-real-handler 'file-local-copy (list filename)))
 645               (temp-file (jka-compr-make-temp-name t))
 646               (temp-buffer (get-buffer-create " *jka-compr-flc-temp*"))
 647               (notfound nil)
 648               local-file)
 649
 650           (setq local-file (or local-copy filename))
 651
 652           (unwind-protect
 653
 654               (with-current-buffer temp-buffer
 655
 656                 (and
 657                  uncompress-message
 658                  (message "%s %s..." uncompress-message base-name))
 659
 660                 ;; Here we must read the output of uncompress program
 661                 ;; and write it to TEMP-FILE without any code
 662                 ;; conversion.  An appropriate code conversion (if
 663                 ;; necessary) is done by the later I/O operation
 664                 ;; (e.g. load).
 665                 (let ((coding-system-for-read 'no-conversion)
 666                       (coding-system-for-write 'no-conversion))
 667
 668                   (jka-compr-call-process uncompress-program
 669                                           (concat uncompress-message
 670                                                   " " base-name)
 671                                           local-file
 672                                           t
 673                                           nil
 674                                           uncompress-args)
 675
 676                   (and
 677                    uncompress-message
 678                    (message "%s %s...done" uncompress-message base-name))
 679
 680                   (write-region
 681                    (point-min) (point-max) temp-file nil 'dont)))
 682
 683             (and
 684              local-copy
 685              (file-exists-p local-copy)
 686              (delete-file local-copy))
 687
 688             (kill-buffer temp-buffer))
 689
 690           temp-file)
 691
 692       (jka-compr-run-real-handler 'file-local-copy (list filename)))))
 693
 694
 695 ;;; Support for loading compressed files.
 696 (defun jka-compr-load (file &optional noerror nomessage nosuffix)
 697   "Documented as original."
 698
 699   (let* ((local-copy (jka-compr-file-local-copy file))
 700          (load-file (or local-copy file)))
 701
 702     (unwind-protect
 703
 704         (let (inhibit-file-name-operation
 705               inhibit-file-name-handlers)
 706           (or nomessage
 707               (message "Loading %s..." file))
 708
 709           (let ((load-force-doc-strings t))
 710             (load load-file noerror t t))
 711
 712           (or nomessage
 713               (message "Loading %s...done." file)))
 714
 715       (jka-compr-delete-temp-file local-copy))
 716
 717     t))
 718
 719 (defun jka-compr-byte-compiler-base-file-name (file)
 720   (let ((info (jka-compr-get-compression-info file)))
 721     (if (and info (jka-compr-info-strip-extension info))
 722         (save-match-data
 723           (substring file 0 (string-match (jka-compr-info-regexp info) file)))
 724       file)))
 725 \f
 726 (put 'write-region 'jka-compr 'jka-compr-write-region)
 727 (put 'insert-file-contents 'jka-compr 'jka-compr-insert-file-contents)
 728 (put 'file-local-copy 'jka-compr 'jka-compr-file-local-copy)
 729 (put 'load 'jka-compr 'jka-compr-load)
 730 (put 'byte-compiler-base-file-name 'jka-compr
 731      'jka-compr-byte-compiler-base-file-name)
 732
 733 (defvar jka-compr-inhibit nil
 734   "Non-nil means inhibit automatic uncompression temporarily.
 735 Lisp programs can bind this to t to do that.
 736 It is not recommended to set this variable permanently to anything but nil.")
 737
 738 (defun jka-compr-handler (operation &rest args)
 739   (save-match-data
 740     (let ((jka-op (get operation 'jka-compr)))
 741       (if (and jka-op (not jka-compr-inhibit))
 742           (apply jka-op args)
 743         (jka-compr-run-real-handler operation args)))))
 744
 745 ;; If we are given an operation that we don't handle,
 746 ;; call the Emacs primitive for that operation,
 747 ;; and manipulate the inhibit variables
 748 ;; to prevent the primitive from calling our handler again.
 749 (defun jka-compr-run-real-handler (operation args)
 750   (let ((inhibit-file-name-handlers
 751          (cons 'jka-compr-handler
 752                (and (eq inhibit-file-name-operation operation)
 753                     inhibit-file-name-handlers)))
 754         (inhibit-file-name-operation operation))
 755     (apply operation args)))
 756
 757 ;;;###autoload(defun auto-compression-mode (&optional arg)
 758 ;;;###autoload  "\
 759 ;;;###autoloadToggle automatic file compression and uncompression.
 760 ;;;###autoloadWith prefix argument ARG, turn auto compression on if positive, else off.
 761 ;;;###autoloadReturns the new status of auto compression (non-nil means on)."
 762 ;;;###autoload  (interactive "P")
 763 ;;;###autoload  (if (not (fboundp 'jka-compr-installed-p))
 764 ;;;###autoload      (progn
 765 ;;;###autoload        (require 'jka-compr)
 766 ;;;###autoload        ;; That turned the mode on, so make it initially off.
 767 ;;;###autoload        (toggle-auto-compression)))
 768 ;;;###autoload  (toggle-auto-compression arg t))
 769
 770 (defun toggle-auto-compression (&optional arg message)
 771   "Toggle automatic file compression and uncompression.
 772 With prefix argument ARG, turn auto compression on if positive, else off.
 773 Returns the new status of auto compression (non-nil means on).
 774 If the argument MESSAGE is non-nil, it means to print a message
 775 saying whether the mode is now on or off."
 776   (interactive "P\np")
 777   (let* ((installed (jka-compr-installed-p))
 778          (flag (if (null arg)
 779                    (not installed)
 780                  (or (eq arg t) (listp arg) (and (integerp arg) (> arg 0))))))
 781
 782     (cond
 783      ((and flag installed) t)           ; already installed
 784
 785      ((and (not flag) (not installed)) nil) ; already not installed
 786
 787      (flag
 788       (jka-compr-install))
 789
 790      (t
 791       (jka-compr-uninstall)))
 792
 793
 794     (and message
 795          (if flag
 796              (message "Automatic file (de)compression is now ON.")
 797            (message "Automatic file (de)compression is now OFF.")))
 798
 799     flag))
 800
 801 (defun jka-compr-build-file-regexp ()
 802   (concat
 803    "\\("
 804    (mapconcat
 805     'jka-compr-info-regexp
 806     jka-compr-compression-info-list
 807     "\\)\\|\\(")
 808    "\\)"))
 809
 810
 811 (defun jka-compr-install ()
 812   "Install jka-compr.
 813 This adds entries to `file-name-handler-alist' and `auto-mode-alist'
 814 and `inhibit-first-line-modes-suffixes'."
 815
 816   (setq jka-compr-file-name-handler-entry
 817         (cons (jka-compr-build-file-regexp) 'jka-compr-handler))
 818
 819   (setq file-name-handler-alist (cons jka-compr-file-name-handler-entry
 820                                       file-name-handler-alist))
 821
 822   (setq jka-compr-added-to-file-coding-system-alist nil)
 823
 824   (mapcar
 825    (function (lambda (x)
 826                ;; Don't do multibyte encoding on the compressed files.
 827                (let ((elt (cons (jka-compr-info-regexp x)
 828                                  '(no-conversion . no-conversion))))
 829                  (setq file-coding-system-alist
 830                        (cons elt file-coding-system-alist))
 831                  (setq jka-compr-added-to-file-coding-system-alist
 832                        (cons elt jka-compr-added-to-file-coding-system-alist)))
 833
 834                (and (jka-compr-info-strip-extension x)
 835                     ;; Make entries in auto-mode-alist so that modes
 836                     ;; are chosen right according to the file names
 837                     ;; sans `.gz'.
 838                     (setq auto-mode-alist
 839                           (cons (list (jka-compr-info-regexp x)
 840                                       nil 'jka-compr)
 841                                 auto-mode-alist))
 842                     ;; Also add these regexps to
 843                     ;; inhibit-first-line-modes-suffixes, so that a
 844                     ;; -*- line in the first file of a compressed tar
 845                     ;; file doesn't override tar-mode.
 846                     (setq inhibit-first-line-modes-suffixes
 847                           (cons (jka-compr-info-regexp x)
 848                                 inhibit-first-line-modes-suffixes)))))
 849    jka-compr-compression-info-list)
 850   (setq auto-mode-alist
 851         (append auto-mode-alist jka-compr-mode-alist-additions)))
 852
 853
 854 (defun jka-compr-uninstall ()
 855   "Uninstall jka-compr.
 856 This removes the entries in `file-name-handler-alist' and `auto-mode-alist'
 857 and `inhibit-first-line-modes-suffixes' that were added
 858 by `jka-compr-installed'."
 859   ;; Delete from inhibit-first-line-modes-suffixes
 860   ;; what jka-compr-install added.
 861   (mapcar
 862      (function (lambda (x)
 863                  (and (jka-compr-info-strip-extension x)
 864                       (setq inhibit-first-line-modes-suffixes
 865                             (delete (jka-compr-info-regexp x)
 866                                     inhibit-first-line-modes-suffixes)))))
 867      jka-compr-compression-info-list)
 868
 869   (let* ((fnha (cons nil file-name-handler-alist))
 870          (last fnha))
 871
 872     (while (cdr last)
 873       (if (eq (cdr (car (cdr last))) 'jka-compr-handler)
 874           (setcdr last (cdr (cdr last)))
 875         (setq last (cdr last))))
 876
 877     (setq file-name-handler-alist (cdr fnha)))
 878
 879   (let* ((ama (cons nil auto-mode-alist))
 880          (last ama)
 881          entry)
 882
 883     (while (cdr last)
 884       (setq entry (car (cdr last)))
 885       (if (or (member entry jka-compr-mode-alist-additions)
 886               (and (consp (cdr entry))
 887                    (eq (nth 2 entry) 'jka-compr)))
 888           (setcdr last (cdr (cdr last)))
 889         (setq last (cdr last))))
 890
 891     (setq auto-mode-alist (cdr ama)))
 892
 893   (let* ((ama (cons nil file-coding-system-alist))
 894          (last ama)
 895          entry)
 896
 897     (while (cdr last)
 898       (setq entry (car (cdr last)))
 899       (if (member entry jka-compr-added-to-file-coding-system-alist)
 900           (setcdr last (cdr (cdr last)))
 901         (setq last (cdr last))))
 902
 903     (setq file-coding-system-alist (cdr ama))))
 904
 905
 906 (defun jka-compr-installed-p ()
 907   "Return non-nil if jka-compr is installed.
 908 The return value is the entry in `file-name-handler-alist' for jka-compr."
 909
 910   (let ((fnha file-name-handler-alist)
 911         (installed nil))
 912
 913     (while (and fnha (not installed))
 914      (and (eq (cdr (car fnha)) 'jka-compr-handler)
 915            (setq installed (car fnha)))
 916       (setq fnha (cdr fnha)))
 917
 918     installed))
 919
 920
 921 ;;; Add the file I/O hook if it does not already exist.
 922 ;;; Make sure that jka-compr-file-name-handler-entry is eq to the
 923 ;;; entry for jka-compr in file-name-handler-alist.
 924 (and (jka-compr-installed-p)
 925      (jka-compr-uninstall))
 926
 927 (jka-compr-install)
 928
 929
 930 (provide 'jka-compr)
 931
 932 ;; jka-compr.el ends here.