lisp/jka-compr.el

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