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