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