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