lisp/jka-compr.el

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