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

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