lisp/jka-compr.el

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