code.delx.au - gnu-emacs/blob - lisp/jka-compr.el

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