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