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