lisp/jka-compr.el

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