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