lisp/jka-compr.el

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