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

   1 ;;; jka-compr.el --- reading/writing/loading compressed files
   2
   3 ;; Copyright (C) 1993, 1994, 1995, 1997  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 t)
 121
 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.
 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     ["\\.tgz\\'"
 135      "zipping"        "gzip"         ("-c" "-q")
 136      "unzipping"      "gzip"         ("-c" "-q" "-d")
 137      t nil]
 138     ["\\.gz\\(~\\|\\.~[0-9]+~\\)?\\'"
 139      "zipping"        "gzip"         ("-c" "-q")
 140      "unzipping"      "gzip"         ("-c" "-q" "-d")
 141      t t])
 142
 143   "List of vectors that describe available compression techniques.
 144 Each element, which describes a compression technique, is a vector of
 145 the form [REGEXP COMPRESS-MSG COMPRESS-PROGRAM COMPRESS-ARGS
 146 UNCOMPRESS-MSG UNCOMPRESS-PROGRAM UNCOMPRESS-ARGS
 147 APPEND-FLAG EXTENSION], where:
 148
 149    regexp                is a regexp that matches filenames that are
 150                          compressed with this format
 151
 152    compress-msg          is the message to issue to the user when doing this
 153                          type of compression (nil means no message)
 154
 155    compress-program      is a program that performs this compression
 156
 157    compress-args         is a list of args to pass to the compress program
 158
 159    uncompress-msg        is the message to issue to the user when doing this
 160                          type of uncompression (nil means no message)
 161
 162    uncompress-program    is a program that performs this compression
 163
 164    uncompress-args       is a list of args to pass to the uncompress program
 165
 166    append-flag           is non-nil if this compression technique can be
 167                          appended
 168
 169    auto-mode flag        non-nil means strip the regexp from file names
 170                          before attempting to set the mode.
 171
 172 Because of the way `call-process' is defined, discarding the stderr output of
 173 a program adds the overhead of starting a shell each time the program is
 174 invoked."
 175   :type '(repeat (vector regexp
 176                          (choice :tag "Compress Message"
 177                                  (string :format "%v")
 178                                  (const :tag "No Message" nil))
 179                          (string :tag "Compress Program")
 180                          (repeat :tag "Compress Arguments" string)
 181                          (choice :tag "Uncompress Message"
 182                                  (string :format "%v")
 183                                  (const :tag "No Message" nil))
 184                          (string :tag "Uncompress Program")
 185                          (repeat :tag "Uncompress Arguments" string)
 186                          (boolean :tag "Append")
 187                          (boolean :tag "Auto Mode")))
 188   :group 'jka-compr)
 189
 190 (defvar jka-compr-mode-alist-additions
 191   (list (cons "\\.tgz\\'" 'tar-mode))
 192   "A list of pairs to add to `auto-mode-alist' when jka-compr is installed.")
 193
 194 ;; List of all the elements we actually added to file-coding-system-alist.
 195 (defvar jka-compr-added-to-file-coding-system-alist nil)
 196
 197 (defvar jka-compr-file-name-handler-entry
 198   nil
 199   "The entry in `file-name-handler-alist' used by the jka-compr I/O functions.")
 200 \f
 201 ;;; Functions for accessing the return value of jka-compr-get-compression-info
 202 (defun jka-compr-info-regexp               (info)  (aref info 0))
 203 (defun jka-compr-info-compress-message     (info)  (aref info 1))
 204 (defun jka-compr-info-compress-program     (info)  (aref info 2))
 205 (defun jka-compr-info-compress-args        (info)  (aref info 3))
 206 (defun jka-compr-info-uncompress-message   (info)  (aref info 4))
 207 (defun jka-compr-info-uncompress-program   (info)  (aref info 5))
 208 (defun jka-compr-info-uncompress-args      (info)  (aref info 6))
 209 (defun jka-compr-info-can-append           (info)  (aref info 7))
 210 (defun jka-compr-info-strip-extension      (info)  (aref info 8))
 211
 212
 213 (defun jka-compr-get-compression-info (filename)
 214   "Return information about the compression scheme of FILENAME.
 215 The determination as to which compression scheme, if any, to use is
 216 based on the filename itself and `jka-compr-compression-info-list'."
 217   (catch 'compression-info
 218     (let ((case-fold-search nil))
 219       (mapcar
 220        (function (lambda (x)
 221                    (and (string-match (jka-compr-info-regexp x) filename)
 222                         (throw 'compression-info x))))
 223        jka-compr-compression-info-list)
 224       nil)))
 225
 226
 227 (put 'compression-error 'error-conditions '(compression-error file-error error))
 228
 229
 230 (defvar jka-compr-acceptable-retval-list '(0 2 141))
 231
 232
 233 (defun jka-compr-error (prog args infile message &optional errfile)
 234
 235   (let ((errbuf (get-buffer-create " *jka-compr-error*"))
 236         (curbuf (current-buffer)))
 237     (with-current-buffer errbuf
 238       (widen) (erase-buffer)
 239       (insert (format "Error while executing \"%s %s < %s\"\n\n"
 240                       prog
 241                       (mapconcat 'identity args " ")
 242                       infile))
 243
 244       (and errfile
 245            (insert-file-contents errfile)))
 246      (display-buffer errbuf))
 247
 248   (signal 'compression-error
 249           (list "Opening input file" (format "error %s" message) infile)))
 250
 251
 252 (defvar jka-compr-dd-program
 253   "/bin/dd")
 254
 255
 256 (defvar jka-compr-dd-blocksize 256)
 257
 258
 259 (defun jka-compr-partial-uncompress (prog message args infile beg len)
 260   "Call program PROG with ARGS args taking input from INFILE.
 261 Fourth and fifth args, BEG and LEN, specify which part of the output
 262 to keep: LEN chars starting BEG chars from the beginning."
 263   (let* ((skip (/ beg jka-compr-dd-blocksize))
 264          (prefix (- beg (* skip jka-compr-dd-blocksize)))
 265          (count (and len (1+ (/ (+ len prefix) jka-compr-dd-blocksize))))
 266          (start (point))
 267          (err-file (jka-compr-make-temp-name))
 268          (run-string (format "%s %s 2> %s | %s bs=%d skip=%d %s 2> /dev/null"
 269                              prog
 270                              (mapconcat 'identity args " ")
 271                              err-file
 272                              jka-compr-dd-program
 273                              jka-compr-dd-blocksize
 274                              skip
 275                              ;; dd seems to be unreliable about
 276                              ;; providing the last block.  So, always
 277                              ;; read one more than you think you need.
 278                              (if count (concat "count=" (1+ count)) ""))))
 279
 280     (unwind-protect
 281         (or (memq (call-process jka-compr-shell
 282                                 infile t nil "-c"
 283                                 run-string)
 284                   jka-compr-acceptable-retval-list)
 285
 286             (jka-compr-error prog args infile message err-file))
 287
 288       (jka-compr-delete-temp-file err-file))
 289
 290     ;; Delete the stuff after what we want, if there is any.
 291     (and
 292      len
 293      (< (+ start prefix len) (point))
 294      (delete-region (+ start prefix len) (point)))
 295
 296     ;; Delete the stuff before what we want.
 297     (delete-region start (+ start prefix))))
 298
 299
 300 (defun jka-compr-call-process (prog message infile output temp args)
 301   (if jka-compr-use-shell
 302
 303       (let ((err-file (jka-compr-make-temp-name))
 304             (coding-system-for-read (or coding-system-for-read 'undecided))
 305             (coding-system-for-write 'no-conversion) )
 306
 307         (unwind-protect
 308
 309             (or (memq
 310                  (call-process jka-compr-shell infile
 311                                (if (stringp output) nil output)
 312                                nil
 313                                "-c"
 314                                (format "%s %s 2> %s %s"
 315                                        prog
 316                                        (mapconcat 'identity args " ")
 317                                        err-file
 318                                        (if (stringp output)
 319                                            (concat "> " output)
 320                                          "")))
 321                  jka-compr-acceptable-retval-list)
 322
 323                 (jka-compr-error prog args infile message err-file))
 324
 325           (jka-compr-delete-temp-file err-file)))
 326
 327     (or (zerop
 328          (apply 'call-process
 329                 prog
 330                 infile
 331                 (if (stringp output) temp output)
 332                 nil
 333                 args))
 334         (jka-compr-error prog args infile message))
 335
 336     (and (stringp output)
 337          (with-current-buffer temp
 338            (write-region (point-min) (point-max) output)
 339            (erase-buffer)))))
 340
 341
 342 ;;; Support for temp files.  Much of this was inspired if not lifted
 343 ;;; from ange-ftp.
 344
 345 (defcustom jka-compr-temp-name-template
 346   (expand-file-name "jka-com"
 347                     (or (getenv "TMPDIR") "/tmp/"))
 348   "Prefix added to all temp files created by jka-compr.
 349 There should be no more than seven characters after the final `/'."
 350   :type 'string
 351   :group 'jka-compr)
 352
 353 (defvar jka-compr-temp-name-table (make-vector 31 nil))
 354
 355 (defun jka-compr-make-temp-name (&optional local-copy)
 356   "This routine will return the name of a new file."
 357   (let* ((lastchar ?a)
 358          (prevchar ?a)
 359          (template (concat jka-compr-temp-name-template "aa"))
 360          (lastpos (1- (length template)))
 361          (not-done t)
 362          file
 363          entry)
 364
 365     (while not-done
 366       (aset template lastpos lastchar)
 367       (setq file (concat (make-temp-name template) "#"))
 368       (setq entry (intern file jka-compr-temp-name-table))
 369       (if (or (get entry 'active)
 370               (file-exists-p file))
 371
 372           (progn
 373             (setq lastchar (1+ lastchar))
 374             (if (> lastchar ?z)
 375                 (progn
 376                   (setq prevchar (1+ prevchar))
 377                   (setq lastchar ?a)
 378                   (if (> prevchar ?z)
 379                       (error "Can't allocate temp file.")
 380                     (aset template (1- lastpos) prevchar)))))
 381
 382         (put entry 'active (not local-copy))
 383         (setq not-done nil)))
 384
 385     file))
 386
 387
 388 (defun jka-compr-delete-temp-file (temp)
 389
 390   (put (intern temp jka-compr-temp-name-table)
 391        'active nil)
 392
 393   (condition-case ()
 394       (delete-file temp)
 395     (error nil)))
 396
 397
 398 (defun jka-compr-write-region (start end file &optional append visit)
 399   (let* ((filename (expand-file-name file))
 400          (visit-file (if (stringp visit) (expand-file-name visit) filename))
 401          (info (jka-compr-get-compression-info visit-file)))
 402
 403       (if info
 404
 405           (let ((can-append (jka-compr-info-can-append info))
 406                 (compress-program (jka-compr-info-compress-program info))
 407                 (compress-message (jka-compr-info-compress-message info))
 408                 (uncompress-program (jka-compr-info-uncompress-program info))
 409                 (uncompress-message (jka-compr-info-uncompress-message info))
 410                 (compress-args (jka-compr-info-compress-args info))
 411                 (uncompress-args (jka-compr-info-uncompress-args info))
 412                 (base-name (file-name-nondirectory visit-file))
 413                 temp-file temp-buffer)
 414
 415             (setq temp-buffer (get-buffer-create " *jka-compr-wr-temp*"))
 416             (with-current-buffer temp-buffer
 417               (widen) (erase-buffer))
 418
 419             (if (and append
 420                      (not can-append)
 421                      (file-exists-p filename))
 422
 423                 (let* ((local-copy (file-local-copy filename))
 424                        (local-file (or local-copy filename)))
 425
 426                   (setq temp-file local-file))
 427
 428               (setq temp-file (jka-compr-make-temp-name)))
 429
 430             (and
 431              compress-message
 432              (message "%s %s..." compress-message base-name))
 433
 434             (jka-compr-run-real-handler 'write-region
 435                                         (list start end temp-file t 'dont))
 436
 437             ;; Here we must read the output of compress program as is
 438             ;; without any code conversion.
 439             (let ((coding-system-for-read 'no-conversion))
 440               (jka-compr-call-process compress-program
 441                                       (concat compress-message
 442                                               " " base-name)
 443                                       temp-file
 444                                       temp-buffer
 445                                       nil
 446                                       compress-args))
 447
 448             (with-current-buffer temp-buffer
 449               (let ((coding-system-for-write 'no-conversion))
 450                 (if (memq system-type '(ms-dos windows-nt))
 451                     (setq buffer-file-type t) )
 452                 (jka-compr-run-real-handler 'write-region
 453                                             (list (point-min) (point-max)
 454                                                   filename
 455                                                   (and append can-append) 'dont))
 456                 (erase-buffer)) )
 457
 458             (jka-compr-delete-temp-file temp-file)
 459
 460             (and
 461              compress-message
 462              (message "%s %s...done" compress-message base-name))
 463
 464             (cond
 465              ((eq visit t)
 466               (setq buffer-file-name filename)
 467               (set-visited-file-modtime))
 468              ((stringp visit)
 469               (setq buffer-file-name visit)
 470               (let ((buffer-file-name filename))
 471                 (set-visited-file-modtime))))
 472
 473             (and (or (eq visit t)
 474                      (eq visit nil)
 475                      (stringp visit))
 476                  (message "Wrote %s" visit-file))
 477
 478             nil)
 479
 480         (jka-compr-run-real-handler 'write-region
 481                                     (list start end filename append visit)))))
 482
 483
 484 (defun jka-compr-insert-file-contents (file &optional visit beg end replace)
 485   (barf-if-buffer-read-only)
 486
 487   (and (or beg end)
 488        visit
 489        (error "Attempt to visit less than an entire file"))
 490
 491   (let* ((filename (expand-file-name file))
 492          (info (jka-compr-get-compression-info filename)))
 493
 494     (if info
 495
 496         (let ((uncompress-message (jka-compr-info-uncompress-message info))
 497               (uncompress-program (jka-compr-info-uncompress-program info))
 498               (uncompress-args (jka-compr-info-uncompress-args info))
 499               (base-name (file-name-nondirectory filename))
 500               (notfound nil)
 501               (local-copy
 502                (jka-compr-run-real-handler 'file-local-copy (list filename)))
 503               local-file
 504               size start
 505               (coding-system-for-read
 506                (or coding-system-for-read
 507                    (let ((tail file-coding-system-alist)
 508                          (newfile
 509                           (jka-compr-byte-compiler-base-file-name file))
 510                          result)
 511                      (while tail
 512                        (if (string-match (car (car tail)) newfile)
 513                            (setq result (car (cdr (car tail)))
 514                                  tail nil))
 515                        (setq tail (cdr tail)))
 516                      result)
 517                    'undecided)) )
 518
 519           (setq local-file (or local-copy filename))
 520
 521           (and
 522            visit
 523            (setq buffer-file-name filename))
 524
 525           (unwind-protect               ; to make sure local-copy gets deleted
 526
 527               (progn
 528
 529                 (and
 530                  uncompress-message
 531                  (message "%s %s..." uncompress-message base-name))
 532
 533                 (condition-case error-code
 534
 535                     (progn
 536                       (if replace
 537                           (goto-char (point-min)))
 538                       (setq start (point))
 539                       (if (or beg end)
 540                           (jka-compr-partial-uncompress uncompress-program
 541                                                         (concat uncompress-message
 542                                                                 " " base-name)
 543                                                         uncompress-args
 544                                                         local-file
 545                                                         (or beg 0)
 546                                                         (if (and beg end)
 547                                                             (- end beg)
 548                                                           end))
 549                         ;; If visiting, bind off buffer-file-name so that
 550                         ;; file-locking will not ask whether we should
 551                         ;; really edit the buffer.
 552                         (let ((buffer-file-name
 553                                (if visit nil buffer-file-name)))
 554                           (jka-compr-call-process uncompress-program
 555                                                   (concat uncompress-message
 556                                                           " " base-name)
 557                                                   local-file
 558                                                   t
 559                                                   nil
 560                                                   uncompress-args)))
 561                       (setq size (- (point) start))
 562                       (if replace
 563                           (let* ((del-beg (point))
 564                                  (del-end (+ del-beg size)))
 565                             (delete-region del-beg
 566                                            (min del-end (point-max)))))
 567                       (goto-char start))
 568                   (error
 569                    (if (and (eq (car error-code) 'file-error)
 570                             (eq (nth 3 error-code) local-file))
 571                        (if visit
 572                            (setq notfound error-code)
 573                          (signal 'file-error
 574                                  (cons "Opening input file"
 575                                        (nthcdr 2 error-code))))
 576                      (signal (car error-code) (cdr error-code))))))
 577
 578             (and
 579              local-copy
 580              (file-exists-p local-copy)
 581              (delete-file local-copy)))
 582
 583           (and
 584            visit
 585            (progn
 586              (unlock-buffer)
 587              (setq buffer-file-name filename)
 588              (set-visited-file-modtime)))
 589
 590           (and
 591            uncompress-message
 592            (message "%s %s...done" uncompress-message base-name))
 593
 594           (and
 595            visit
 596            notfound
 597            (signal 'file-error
 598                    (cons "Opening input file" (nth 2 notfound))))
 599
 600           ;; Run the functions that insert-file-contents would.
 601           (let ((p after-insert-file-functions)
 602                 (insval size))
 603             (while p
 604               (setq insval (funcall (car p) size))
 605               (if insval
 606                   (progn
 607                     (or (integerp insval)
 608                         (signal 'wrong-type-argument
 609                                 (list 'integerp insval)))
 610                     (setq size insval)))
 611               (setq p (cdr p))))
 612
 613           (list filename size))
 614
 615       (jka-compr-run-real-handler 'insert-file-contents
 616                                   (list file visit beg end replace)))))
 617
 618
 619 (defun jka-compr-file-local-copy (file)
 620   (let* ((filename (expand-file-name file))
 621          (info (jka-compr-get-compression-info filename)))
 622
 623     (if info
 624
 625         (let ((uncompress-message (jka-compr-info-uncompress-message info))
 626               (uncompress-program (jka-compr-info-uncompress-program info))
 627               (uncompress-args (jka-compr-info-uncompress-args info))
 628               (base-name (file-name-nondirectory filename))
 629               (local-copy
 630                (jka-compr-run-real-handler 'file-local-copy (list filename)))
 631               (temp-file (jka-compr-make-temp-name t))
 632               (temp-buffer (get-buffer-create " *jka-compr-flc-temp*"))
 633               (notfound nil)
 634               local-file)
 635
 636           (setq local-file (or local-copy filename))
 637
 638           (unwind-protect
 639
 640               (with-current-buffer temp-buffer
 641
 642                 (and
 643                  uncompress-message
 644                  (message "%s %s..." uncompress-message base-name))
 645
 646                 ;; Here we must read the output of uncompress program
 647                 ;; and write it to TEMP-FILE without any code
 648                 ;; conversion.  An appropriate code conversion (if
 649                 ;; necessary) is done by the later I/O operation
 650                 ;; (e.g. load).
 651                 (let ((coding-system-for-read 'no-conversion)
 652                       (coding-system-for-write 'no-conversion))
 653
 654                   (jka-compr-call-process uncompress-program
 655                                           (concat uncompress-message
 656                                                   " " base-name)
 657                                           local-file
 658                                           t
 659                                           nil
 660                                           uncompress-args)
 661
 662                   (and
 663                    uncompress-message
 664                    (message "%s %s...done" uncompress-message base-name))
 665
 666                   (write-region
 667                    (point-min) (point-max) temp-file nil 'dont)))
 668
 669             (and
 670              local-copy
 671              (file-exists-p local-copy)
 672              (delete-file local-copy))
 673
 674             (kill-buffer temp-buffer))
 675
 676           temp-file)
 677
 678       (jka-compr-run-real-handler 'file-local-copy (list filename)))))
 679
 680
 681 ;;; Support for loading compressed files.
 682 (defun jka-compr-load (file &optional noerror nomessage nosuffix)
 683   "Documented as original."
 684
 685   (let* ((local-copy (jka-compr-file-local-copy file))
 686          (load-file (or local-copy file)))
 687
 688     (unwind-protect
 689
 690         (let (inhibit-file-name-operation
 691               inhibit-file-name-handlers)
 692           (or nomessage
 693               (message "Loading %s..." file))
 694
 695           (let ((load-force-doc-strings t))
 696             (load load-file noerror t t))
 697
 698           (or nomessage
 699               (message "Loading %s...done." file)))
 700
 701       (jka-compr-delete-temp-file local-copy))
 702
 703     t))
 704
 705 (defun jka-compr-byte-compiler-base-file-name (file)
 706   (let ((info (jka-compr-get-compression-info file)))
 707     (if (and info (jka-compr-info-strip-extension info))
 708         (save-match-data
 709           (substring file 0 (string-match (jka-compr-info-regexp info) file)))
 710       file)))
 711 \f
 712 (put 'write-region 'jka-compr 'jka-compr-write-region)
 713 (put 'insert-file-contents 'jka-compr 'jka-compr-insert-file-contents)
 714 (put 'file-local-copy 'jka-compr 'jka-compr-file-local-copy)
 715 (put 'load 'jka-compr 'jka-compr-load)
 716 (put 'byte-compiler-base-file-name 'jka-compr
 717      'jka-compr-byte-compiler-base-file-name)
 718
 719 (defun jka-compr-handler (operation &rest args)
 720   (save-match-data
 721     (let ((jka-op (get operation 'jka-compr)))
 722       (if jka-op
 723           (apply jka-op args)
 724         (jka-compr-run-real-handler operation args)))))
 725
 726 ;; If we are given an operation that we don't handle,
 727 ;; call the Emacs primitive for that operation,
 728 ;; and manipulate the inhibit variables
 729 ;; to prevent the primitive from calling our handler again.
 730 (defun jka-compr-run-real-handler (operation args)
 731   (let ((inhibit-file-name-handlers
 732          (cons 'jka-compr-handler
 733                (and (eq inhibit-file-name-operation operation)
 734                     inhibit-file-name-handlers)))
 735         (inhibit-file-name-operation operation))
 736     (apply operation args)))
 737
 738 ;;;###autoload(defun auto-compression-mode (&optional arg)
 739 ;;;###autoload  "\
 740 ;;;###autoloadToggle automatic file compression and uncompression.
 741 ;;;###autoloadWith prefix argument ARG, turn auto compression on if positive, else off.
 742 ;;;###autoloadReturns the new status of auto compression (non-nil means on)."
 743 ;;;###autoload  (interactive "P")
 744 ;;;###autoload  (if (not (fboundp 'jka-compr-installed-p))
 745 ;;;###autoload      (progn
 746 ;;;###autoload        (require 'jka-compr)
 747 ;;;###autoload        ;; That turned the mode on, so make it initially off.
 748 ;;;###autoload        (toggle-auto-compression)))
 749 ;;;###autoload  (toggle-auto-compression arg t))
 750
 751 (defun toggle-auto-compression (&optional arg message)
 752   "Toggle automatic file compression and uncompression.
 753 With prefix argument ARG, turn auto compression on if positive, else off.
 754 Returns the new status of auto compression (non-nil means on).
 755 If the argument MESSAGE is non-nil, it means to print a message
 756 saying whether the mode is now on or off."
 757   (interactive "P\np")
 758   (let* ((installed (jka-compr-installed-p))
 759          (flag (if (null arg)
 760                    (not installed)
 761                  (or (eq arg t) (listp arg) (and (integerp arg) (> arg 0))))))
 762
 763     (cond
 764      ((and flag installed) t)           ; already installed
 765
 766      ((and (not flag) (not installed)) nil) ; already not installed
 767
 768      (flag
 769       (jka-compr-install))
 770
 771      (t
 772       (jka-compr-uninstall)))
 773
 774
 775     (and message
 776          (if flag
 777              (message "Automatic file (de)compression is now ON.")
 778            (message "Automatic file (de)compression is now OFF.")))
 779
 780     flag))
 781
 782 (defun jka-compr-build-file-regexp ()
 783   (concat
 784    "\\("
 785    (mapconcat
 786     'jka-compr-info-regexp
 787     jka-compr-compression-info-list
 788     "\\)\\|\\(")
 789    "\\)"))
 790
 791
 792 (defun jka-compr-install ()
 793   "Install jka-compr.
 794 This adds entries to `file-name-handler-alist' and `auto-mode-alist'
 795 and `inhibit-first-line-modes-suffixes'."
 796
 797   (setq jka-compr-file-name-handler-entry
 798         (cons (jka-compr-build-file-regexp) 'jka-compr-handler))
 799
 800   (setq file-name-handler-alist (cons jka-compr-file-name-handler-entry
 801                                       file-name-handler-alist))
 802
 803   (setq jka-compr-added-to-file-coding-system-alist nil)
 804
 805   (mapcar
 806    (function (lambda (x)
 807                ;; Don't do multibyte encoding on the compressed files.
 808                (let ((elt (cons (jka-compr-info-regexp x)
 809                                  '(no-conversion . no-conversion))))
 810                  (setq file-coding-system-alist
 811                        (cons elt file-coding-system-alist))
 812                  (setq jka-compr-added-to-file-coding-system-alist
 813                        (cons elt jka-compr-added-to-file-coding-system-alist)))
 814
 815                (and (jka-compr-info-strip-extension x)
 816                     ;; Make entries in auto-mode-alist so that modes
 817                     ;; are chosen right according to the file names
 818                     ;; sans `.gz'.
 819                     (setq auto-mode-alist
 820                           (cons (list (jka-compr-info-regexp x)
 821                                       nil 'jka-compr)
 822                                 auto-mode-alist))
 823                     ;; Also add these regexps to
 824                     ;; inhibit-first-line-modes-suffixes, so that a
 825                     ;; -*- line in the first file of a compressed tar
 826                     ;; file doesn't override tar-mode.
 827                     (setq inhibit-first-line-modes-suffixes
 828                           (cons (jka-compr-info-regexp x)
 829                                 inhibit-first-line-modes-suffixes)))))
 830    jka-compr-compression-info-list)
 831   (setq auto-mode-alist
 832         (append auto-mode-alist jka-compr-mode-alist-additions)))
 833
 834
 835 (defun jka-compr-uninstall ()
 836   "Uninstall jka-compr.
 837 This removes the entries in `file-name-handler-alist' and `auto-mode-alist'
 838 and `inhibit-first-line-modes-suffixes' that were added
 839 by `jka-compr-installed'."
 840   ;; Delete from inhibit-first-line-modes-suffixes
 841   ;; what jka-compr-install added.
 842   (mapcar
 843      (function (lambda (x)
 844                  (and (jka-compr-info-strip-extension x)
 845                       (setq inhibit-first-line-modes-suffixes
 846                             (delete (jka-compr-info-regexp x)
 847                                     inhibit-first-line-modes-suffixes)))))
 848      jka-compr-compression-info-list)
 849
 850   (let* ((fnha (cons nil file-name-handler-alist))
 851          (last fnha))
 852
 853     (while (cdr last)
 854       (if (eq (cdr (car (cdr last))) 'jka-compr-handler)
 855           (setcdr last (cdr (cdr last)))
 856         (setq last (cdr last))))
 857
 858     (setq file-name-handler-alist (cdr fnha)))
 859
 860   (let* ((ama (cons nil auto-mode-alist))
 861          (last ama)
 862          entry)
 863
 864     (while (cdr last)
 865       (setq entry (car (cdr last)))
 866       (if (or (member entry jka-compr-mode-alist-additions)
 867               (and (consp (cdr entry))
 868                    (eq (nth 2 entry) 'jka-compr)))
 869           (setcdr last (cdr (cdr last)))
 870         (setq last (cdr last))))
 871
 872     (setq auto-mode-alist (cdr ama)))
 873
 874   (let* ((ama (cons nil file-coding-system-alist))
 875          (last ama)
 876          entry)
 877
 878     (while (cdr last)
 879       (setq entry (car (cdr last)))
 880       (if (member entry jka-compr-added-to-file-coding-system-alist)
 881           (setcdr last (cdr (cdr last)))
 882         (setq last (cdr last))))
 883
 884     (setq file-coding-system-alist (cdr ama))))
 885
 886
 887 (defun jka-compr-installed-p ()
 888   "Return non-nil if jka-compr is installed.
 889 The return value is the entry in `file-name-handler-alist' for jka-compr."
 890
 891   (let ((fnha file-name-handler-alist)
 892         (installed nil))
 893
 894     (while (and fnha (not installed))
 895      (and (eq (cdr (car fnha)) 'jka-compr-handler)
 896            (setq installed (car fnha)))
 897       (setq fnha (cdr fnha)))
 898
 899     installed))
 900
 901
 902 ;;; Add the file I/O hook if it does not already exist.
 903 ;;; Make sure that jka-compr-file-name-handler-entry is eq to the
 904 ;;; entry for jka-compr in file-name-handler-alist.
 905 (and (jka-compr-installed-p)
 906      (jka-compr-uninstall))
 907
 908 (jka-compr-install)
 909
 910
 911 (provide 'jka-compr)
 912
 913 ;; jka-compr.el ends here.