1;;; jka-compr.el --- reading/writing/loading compressed files 2 3;; Copyright (C) 1993, 1994, 1995, 1997, 1999, 2000, 2001, 2002, 2003, 4;; 2004, 2005, 2006, 2007 Free Software Foundation, Inc. 5 6;; Author: jka@ece.cmu.edu (Jay K. Adams) 7;; Maintainer: FSF 8;; Keywords: data 9 10;; This file is part of GNU Emacs. 11 12;; GNU Emacs is free software; you can redistribute it and/or modify 13;; it under the terms of the GNU General Public License as published by 14;; the Free Software Foundation; either version 2, or (at your option) 15;; any later version. 16 17;; GNU Emacs is distributed in the hope that it will be useful, 18;; but WITHOUT ANY WARRANTY; without even the implied warranty of 19;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 20;; GNU General Public License for more details. 21 22;; You should have received a copy of the GNU General Public License 23;; along with GNU Emacs; see the file COPYING. If not, write to the 24;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 25;; Boston, MA 02110-1301, USA. 26 27;;; Commentary: 28 29;; This package implements low-level support for reading, writing, 30;; and loading compressed files. It hooks into the low-level file 31;; I/O functions (including write-region and insert-file-contents) so 32;; that they automatically compress or uncompress a file if the file 33;; appears to need it (based on the extension of the file name). 34;; Packages like Rmail, VM, GNUS, and Info should be able to work 35;; with compressed files without modification. 36 37 38;; INSTRUCTIONS: 39;; 40;; To use jka-compr, invoke the command `auto-compression-mode' (which 41;; see), or customize the variable of the same name. Its operation 42;; should be transparent to the user (except for messages appearing when 43;; a file is being compressed or uncompressed). 44;; 45;; The variable, jka-compr-compression-info-list can be used to 46;; customize jka-compr to work with other compression programs. 47;; The default value of this variable allows jka-compr to work with 48;; Unix compress and gzip. 49;; 50;; If you don't want messages about compressing and decompressing 51;; to show up in the echo area, you can set the compress-msg and 52;; decompress-msg fields of the jka-compr-compression-info-list to 53;; nil. 54 55 56;; APPLICATION NOTES: 57;; 58;; crypt++ 59;; jka-compr can coexist with crypt++ if you take all the decompression 60;; entries out of the crypt-encoding-list. Clearly problems will arise if 61;; you have two programs trying to compress/decompress files. jka-compr 62;; will not "work with" crypt++ in the following sense: you won't be able to 63;; decode encrypted compressed files--that is, files that have been 64;; compressed then encrypted (in that order). Theoretically, crypt++ and 65;; jka-compr could properly handle a file that has been encrypted then 66;; compressed, but there is little point in trying to compress an encrypted 67;; file. 68;; 69 70 71;; ACKNOWLEDGMENTS 72;; 73;; jka-compr is a V19 adaptation of jka-compr for V18 of Emacs. Many people 74;; have made helpful suggestions, reported bugs, and even fixed bugs in 75;; jka-compr. I recall the following people as being particularly helpful. 76;; 77;; Jean-loup Gailly 78;; David Hughes 79;; Richard Pieri 80;; Daniel Quinlan 81;; Chris P. Ross 82;; Rick Sladkey 83;; 84;; Andy Norman's ange-ftp was the inspiration for the original jka-compr for 85;; Version 18 of Emacs. 86;; 87;; After I had made progress on the original jka-compr for V18, I learned of a 88;; package written by Kazushi Jam Marukawa, called jam-zcat, that did exactly 89;; what I was trying to do. I looked over the jam-zcat source code and 90;; probably got some ideas from it. 91;; 92 93;;; Code: 94 95(require 'jka-cmpr-hook) 96 97(defcustom jka-compr-shell "sh" 98 "*Shell to be used for calling compression programs. 99NOTE: Not used in MS-DOS and Windows systems." 100 :type 'string 101 :group 'jka-compr) 102 103(defvar jka-compr-use-shell 104 (not (memq system-type '(ms-dos windows-nt)))) 105 106(defvar jka-compr-really-do-compress nil 107 "Non-nil in a buffer whose visited file was uncompressed on visiting it. 108This means compress the data on writing the file, even if the 109data appears to be compressed already.") 110(make-variable-buffer-local 'jka-compr-really-do-compress) 111(put 'jka-compr-really-do-compress 'permanent-local t) 112 113 114(put 'compression-error 'error-conditions '(compression-error file-error error)) 115 116 117(defvar jka-compr-acceptable-retval-list '(0 2 141)) 118 119 120(defun jka-compr-error (prog args infile message &optional errfile) 121 122 (let ((errbuf (get-buffer-create " *jka-compr-error*"))) 123 (with-current-buffer errbuf 124 (widen) (erase-buffer) 125 (insert (format "Error while executing \"%s %s < %s\"\n\n" 126 prog 127 (mapconcat 'identity args " ") 128 infile)) 129 130 (and errfile 131 (insert-file-contents errfile))) 132 (display-buffer errbuf)) 133 134 (signal 'compression-error 135 (list "Opening input file" (format "error %s" message) infile))) 136 137 138(defcustom jka-compr-dd-program "/bin/dd" 139 "How to invoke `dd'." 140 :type 'string 141 :group 'jka-compr) 142 143 144(defvar jka-compr-dd-blocksize 256) 145 146 147(defun jka-compr-partial-uncompress (prog message args infile beg len) 148 "Call program PROG with ARGS args taking input from INFILE. 149Fourth and fifth args, BEG and LEN, specify which part of the output 150to keep: LEN chars starting BEG chars from the beginning." 151 (let ((start (point)) 152 (prefix beg)) 153 (if (and jka-compr-use-shell jka-compr-dd-program) 154 ;; Put the uncompression output through dd 155 ;; to discard the part we don't want. 156 (let ((skip (/ beg jka-compr-dd-blocksize)) 157 (err-file (jka-compr-make-temp-name)) 158 ;; call-process barfs if default-directory is inaccessible. 159 (default-directory 160 (if (and default-directory 161 (file-accessible-directory-p default-directory)) 162 default-directory 163 (file-name-directory infile))) 164 count) 165 ;; Update PREFIX based on the text that we won't read in. 166 (setq prefix (- beg (* skip jka-compr-dd-blocksize)) 167 count (and len (1+ (/ (+ len prefix) jka-compr-dd-blocksize)))) 168 (unwind-protect 169 (or (memq (call-process 170 jka-compr-shell infile t nil "-c" 171 (format 172 "%s %s 2> %s | %s bs=%d skip=%d %s 2> %s" 173 prog 174 (mapconcat 'identity args " ") 175 err-file 176 jka-compr-dd-program 177 jka-compr-dd-blocksize 178 skip 179 ;; dd seems to be unreliable about 180 ;; providing the last block. So, always 181 ;; read one more than you think you need. 182 (if count (format "count=%d" (1+ count)) "") 183 null-device)) 184 jka-compr-acceptable-retval-list) 185 (jka-compr-error prog args infile message err-file)) 186 (jka-compr-delete-temp-file err-file))) 187 ;; Run the uncompression program directly. 188 ;; We get the whole file and must delete what we don't want. 189 (jka-compr-call-process prog message infile t nil args)) 190 191 ;; Delete the stuff after what we want, if there is any. 192 (and 193 len 194 (< (+ start prefix len) (point)) 195 (delete-region (+ start prefix len) (point))) 196 197 ;; Delete the stuff before what we want. 198 (delete-region start (+ start prefix)))) 199 200 201(defun jka-compr-call-process (prog message infile output temp args) 202 ;; call-process barfs if default-directory is inaccessible. 203 (let ((default-directory 204 (if (and default-directory 205 (file-accessible-directory-p default-directory)) 206 default-directory 207 (file-name-directory infile)))) 208 (if jka-compr-use-shell 209 (let ((err-file (jka-compr-make-temp-name)) 210 (coding-system-for-read (or coding-system-for-read 'undecided)) 211 (coding-system-for-write 'no-conversion)) 212 (unwind-protect 213 (or (memq 214 (call-process jka-compr-shell infile 215 (if (stringp output) nil output) 216 nil 217 "-c" 218 (format "%s %s 2> %s %s" 219 prog 220 (mapconcat 'identity args " ") 221 err-file 222 (if (stringp output) 223 (concat "> " output) 224 ""))) 225 jka-compr-acceptable-retval-list) 226 (jka-compr-error prog args infile message err-file)) 227 (jka-compr-delete-temp-file err-file))) 228 (or (eq 0 229 (apply 'call-process 230 prog infile (if (stringp output) temp output) 231 nil args)) 232 (jka-compr-error prog args infile message)) 233 (and (stringp output) 234 (with-current-buffer temp 235 (write-region (point-min) (point-max) output) 236 (erase-buffer)))))) 237 238 239;; Support for temp files. Much of this was inspired if not lifted 240;; from ange-ftp. 241 242(defcustom jka-compr-temp-name-template 243 (expand-file-name "jka-com" temporary-file-directory) 244 "Prefix added to all temp files created by jka-compr. 245There should be no more than seven characters after the final `/'." 246 :type 'string 247 :group 'jka-compr) 248 249(defun jka-compr-make-temp-name (&optional local-copy) 250 "This routine will return the name of a new file." 251 (make-temp-file jka-compr-temp-name-template)) 252 253(defalias 'jka-compr-delete-temp-file 'delete-file) 254 255 256(defun jka-compr-write-region (start end file &optional append visit) 257 (let* ((filename (expand-file-name file)) 258 (visit-file (if (stringp visit) (expand-file-name visit) filename)) 259 (info (jka-compr-get-compression-info visit-file)) 260 (magic (and info (jka-compr-info-file-magic-bytes info)))) 261 262 ;; If START is nil, use the whole buffer. 263 (if (null start) 264 (setq start 1 end (1+ (buffer-size)))) 265 266 ;; If we uncompressed this file when visiting it, 267 ;; then recompress it when writing it 268 ;; even if the contents look compressed already. 269 (if (and jka-compr-really-do-compress 270 (eq start 1) 271 (eq end (1+ (buffer-size)))) 272 (setq magic nil)) 273 274 (if (and info 275 ;; If the contents to be written out 276 ;; are properly compressed already, 277 ;; don't try to compress them over again. 278 (not (and magic 279 (equal (if (stringp start) 280 (substring start 0 (min (length start) 281 (length magic))) 282 (buffer-substring start 283 (min end 284 (+ start (length magic))))) 285 magic)))) 286 (let ((can-append (jka-compr-info-can-append info)) 287 (compress-program (jka-compr-info-compress-program info)) 288 (compress-message (jka-compr-info-compress-message info)) 289 (compress-args (jka-compr-info-compress-args info)) 290 (base-name (file-name-nondirectory visit-file)) 291 temp-file temp-buffer 292 ;; we need to leave `last-coding-system-used' set to its 293 ;; value after calling write-region the first time, so 294 ;; that `basic-save-buffer' sees the right value. 295 (coding-system-used last-coding-system-used)) 296 297 (or compress-program 298 (error "No compression program defined")) 299 300 (setq temp-buffer (get-buffer-create " *jka-compr-wr-temp*")) 301 (with-current-buffer temp-buffer 302 (widen) (erase-buffer)) 303 304 (if (and append 305 (not can-append) 306 (file-exists-p filename)) 307 308 (let* ((local-copy (file-local-copy filename)) 309 (local-file (or local-copy filename))) 310 311 (setq temp-file local-file)) 312 313 (setq temp-file (jka-compr-make-temp-name))) 314 315 (and 316 compress-message 317 (message "%s %s..." compress-message base-name)) 318 319 (jka-compr-run-real-handler 'write-region 320 (list start end temp-file t 'dont)) 321 ;; save value used by the real write-region 322 (setq coding-system-used last-coding-system-used) 323 324 ;; Here we must read the output of compress program as is 325 ;; without any code conversion. 326 (let ((coding-system-for-read 'no-conversion)) 327 (jka-compr-call-process compress-program 328 (concat compress-message 329 " " base-name) 330 temp-file 331 temp-buffer 332 nil 333 compress-args)) 334 335 (with-current-buffer temp-buffer 336 (let ((coding-system-for-write 'no-conversion)) 337 (if (memq system-type '(ms-dos windows-nt)) 338 (setq buffer-file-type t) ) 339 (jka-compr-run-real-handler 'write-region 340 (list (point-min) (point-max) 341 filename 342 (and append can-append) 'dont)) 343 (erase-buffer)) ) 344 345 (jka-compr-delete-temp-file temp-file) 346 347 (and 348 compress-message 349 (message "%s %s...done" compress-message base-name)) 350 351 (cond 352 ((eq visit t) 353 (setq buffer-file-name filename) 354 (setq jka-compr-really-do-compress t) 355 (set-visited-file-modtime)) 356 ((stringp visit) 357 (setq buffer-file-name visit) 358 (let ((buffer-file-name filename)) 359 (set-visited-file-modtime)))) 360 361 (and (or (eq visit t) 362 (eq visit nil) 363 (stringp visit)) 364 (message "Wrote %s" visit-file)) 365 366 ;; ensure `last-coding-system-used' has an appropriate value 367 (setq last-coding-system-used coding-system-used) 368 369 nil) 370 371 (jka-compr-run-real-handler 'write-region 372 (list start end filename append visit))))) 373 374 375(defun jka-compr-insert-file-contents (file &optional visit beg end replace) 376 (barf-if-buffer-read-only) 377 378 (and (or beg end) 379 visit 380 (error "Attempt to visit less than an entire file")) 381 382 (let* ((filename (expand-file-name file)) 383 (info (jka-compr-get-compression-info filename))) 384 385 (if info 386 387 (let ((uncompress-message (jka-compr-info-uncompress-message info)) 388 (uncompress-program (jka-compr-info-uncompress-program info)) 389 (uncompress-args (jka-compr-info-uncompress-args info)) 390 (base-name (file-name-nondirectory filename)) 391 (notfound nil) 392 (local-copy 393 (jka-compr-run-real-handler 'file-local-copy (list filename))) 394 local-file 395 size start) 396 397 (setq local-file (or local-copy filename)) 398 399 (and 400 visit 401 (setq buffer-file-name filename)) 402 403 (unwind-protect ; to make sure local-copy gets deleted 404 405 (progn 406 407 (and 408 uncompress-message 409 (message "%s %s..." uncompress-message base-name)) 410 411 (condition-case error-code 412 413 (let ((coding-system-for-read 'no-conversion)) 414 (if replace 415 (goto-char (point-min))) 416 (setq start (point)) 417 (if (or beg end) 418 (jka-compr-partial-uncompress uncompress-program 419 (concat uncompress-message 420 " " base-name) 421 uncompress-args 422 local-file 423 (or beg 0) 424 (if (and beg end) 425 (- end beg) 426 end)) 427 ;; If visiting, bind off buffer-file-name so that 428 ;; file-locking will not ask whether we should 429 ;; really edit the buffer. 430 (let ((buffer-file-name 431 (if visit nil buffer-file-name))) 432 (jka-compr-call-process uncompress-program 433 (concat uncompress-message 434 " " base-name) 435 local-file 436 t 437 nil 438 uncompress-args))) 439 (setq size (- (point) start)) 440 (if replace 441 (delete-region (point) (point-max))) 442 (goto-char start)) 443 (error 444 ;; If the file we wanted to uncompress does not exist, 445 ;; handle that according to VISIT as `insert-file-contents' 446 ;; would, maybe signaling the same error it normally would. 447 (if (and (eq (car error-code) 'file-error) 448 (eq (nth 3 error-code) local-file)) 449 (if visit 450 (setq notfound error-code) 451 (signal 'file-error 452 (cons "Opening input file" 453 (nthcdr 2 error-code)))) 454 ;; If the uncompression program can't be found, 455 ;; signal that as a non-file error 456 ;; so that find-file-noselect-1 won't handle it. 457 (if (and (eq (car error-code) 'file-error) 458 (equal (cadr error-code) "Searching for program")) 459 (error "Uncompression program `%s' not found" 460 (nth 3 error-code))) 461 (signal (car error-code) (cdr error-code)))))) 462 463 (and 464 local-copy 465 (file-exists-p local-copy) 466 (delete-file local-copy))) 467 468 (unless notfound 469 (decode-coding-inserted-region 470 (point) (+ (point) size) 471 (jka-compr-byte-compiler-base-file-name file) 472 visit beg end replace)) 473 474 (and 475 visit 476 (progn 477 (unlock-buffer) 478 (setq buffer-file-name filename) 479 (setq jka-compr-really-do-compress t) 480 (set-visited-file-modtime))) 481 482 (and 483 uncompress-message 484 (message "%s %s...done" uncompress-message base-name)) 485 486 (and 487 visit 488 notfound 489 (signal 'file-error 490 (cons "Opening input file" (nth 2 notfound)))) 491 492 ;; This is done in insert-file-contents after we return. 493 ;; That is a little weird, but better to go along with it now 494 ;; than to change it now. 495 496;;; ;; Run the functions that insert-file-contents would. 497;;; (let ((p after-insert-file-functions) 498;;; (insval size)) 499;;; (while p 500;;; (setq insval (funcall (car p) size)) 501;;; (if insval 502;;; (progn 503;;; (or (integerp insval) 504;;; (signal 'wrong-type-argument 505;;; (list 'integerp insval))) 506;;; (setq size insval))) 507;;; (setq p (cdr p)))) 508 509 (or (jka-compr-info-compress-program info) 510 (message "You can't save this buffer because compression program is not defined")) 511 512 (list filename size)) 513 514 (jka-compr-run-real-handler 'insert-file-contents 515 (list file visit beg end replace))))) 516 517 518(defun jka-compr-file-local-copy (file) 519 (let* ((filename (expand-file-name file)) 520 (info (jka-compr-get-compression-info filename))) 521 522 (if info 523 524 (let ((uncompress-message (jka-compr-info-uncompress-message info)) 525 (uncompress-program (jka-compr-info-uncompress-program info)) 526 (uncompress-args (jka-compr-info-uncompress-args info)) 527 (base-name (file-name-nondirectory filename)) 528 (local-copy 529 (jka-compr-run-real-handler 'file-local-copy (list filename))) 530 (temp-file (jka-compr-make-temp-name t)) 531 (temp-buffer (get-buffer-create " *jka-compr-flc-temp*")) 532 local-file) 533 534 (setq local-file (or local-copy filename)) 535 536 (unwind-protect 537 538 (with-current-buffer temp-buffer 539 540 (and 541 uncompress-message 542 (message "%s %s..." uncompress-message base-name)) 543 544 ;; Here we must read the output of uncompress program 545 ;; and write it to TEMP-FILE without any code 546 ;; conversion. An appropriate code conversion (if 547 ;; necessary) is done by the later I/O operation 548 ;; (e.g. load). 549 (let ((coding-system-for-read 'no-conversion) 550 (coding-system-for-write 'no-conversion)) 551 552 (jka-compr-call-process uncompress-program 553 (concat uncompress-message 554 " " base-name) 555 local-file 556 t 557 nil 558 uncompress-args) 559 560 (and 561 uncompress-message 562 (message "%s %s...done" uncompress-message base-name)) 563 564 (write-region 565 (point-min) (point-max) temp-file nil 'dont))) 566 567 (and 568 local-copy 569 (file-exists-p local-copy) 570 (delete-file local-copy)) 571 572 (kill-buffer temp-buffer)) 573 574 temp-file) 575 576 (jka-compr-run-real-handler 'file-local-copy (list filename))))) 577 578 579;; Support for loading compressed files. 580(defun jka-compr-load (file &optional noerror nomessage nosuffix) 581 "Documented as original." 582 583 (let* ((local-copy (jka-compr-file-local-copy file)) 584 (load-file (or local-copy file))) 585 586 (unwind-protect 587 588 (let (inhibit-file-name-operation 589 inhibit-file-name-handlers) 590 (or nomessage 591 (message "Loading %s..." file)) 592 593 (let ((load-force-doc-strings t)) 594 (load load-file noerror t t)) 595 (or nomessage 596 (message "Loading %s...done." file)) 597 ;; Fix up the load history to point at the right library. 598 (let ((l (assoc load-file load-history))) 599 ;; Remove .gz and .elc?. 600 (while (file-name-extension file) 601 (setq file (file-name-sans-extension file))) 602 (setcar l file))) 603 604 (jka-compr-delete-temp-file local-copy)) 605 606 t)) 607 608(defun jka-compr-byte-compiler-base-file-name (file) 609 (let ((info (jka-compr-get-compression-info file))) 610 (if (and info (jka-compr-info-strip-extension info)) 611 (save-match-data 612 (substring file 0 (string-match (jka-compr-info-regexp info) file))) 613 file))) 614 615(put 'write-region 'jka-compr 'jka-compr-write-region) 616(put 'insert-file-contents 'jka-compr 'jka-compr-insert-file-contents) 617(put 'file-local-copy 'jka-compr 'jka-compr-file-local-copy) 618(put 'load 'jka-compr 'jka-compr-load) 619(put 'byte-compiler-base-file-name 'jka-compr 620 'jka-compr-byte-compiler-base-file-name) 621 622;;;###autoload 623(defvar jka-compr-inhibit nil 624 "Non-nil means inhibit automatic uncompression temporarily. 625Lisp programs can bind this to t to do that. 626It is not recommended to set this variable permanently to anything but nil.") 627 628;;;###autoload 629(defun jka-compr-handler (operation &rest args) 630 (save-match-data 631 (let ((jka-op (get operation 'jka-compr))) 632 (if (and jka-op (not jka-compr-inhibit)) 633 (apply jka-op args) 634 (jka-compr-run-real-handler operation args))))) 635 636;; If we are given an operation that we don't handle, 637;; call the Emacs primitive for that operation, 638;; and manipulate the inhibit variables 639;; to prevent the primitive from calling our handler again. 640(defun jka-compr-run-real-handler (operation args) 641 (let ((inhibit-file-name-handlers 642 (cons 'jka-compr-handler 643 (and (eq inhibit-file-name-operation operation) 644 inhibit-file-name-handlers))) 645 (inhibit-file-name-operation operation)) 646 (apply operation args))) 647 648;;;###autoload 649(defun jka-compr-uninstall () 650 "Uninstall jka-compr. 651This removes the entries in `file-name-handler-alist' and `auto-mode-alist' 652and `inhibit-first-line-modes-suffixes' that were added 653by `jka-compr-installed'." 654 ;; Delete from inhibit-first-line-modes-suffixes 655 ;; what jka-compr-install added. 656 (mapc 657 (function (lambda (x) 658 (and (jka-compr-info-strip-extension x) 659 (setq inhibit-first-line-modes-suffixes 660 (delete (jka-compr-info-regexp x) 661 inhibit-first-line-modes-suffixes))))) 662 jka-compr-compression-info-list--internal) 663 664 (let* ((fnha (cons nil file-name-handler-alist)) 665 (last fnha)) 666 667 (while (cdr last) 668 (if (eq (cdr (car (cdr last))) 'jka-compr-handler) 669 (setcdr last (cdr (cdr last))) 670 (setq last (cdr last)))) 671 672 (setq file-name-handler-alist (cdr fnha))) 673 674 (let* ((ama (cons nil auto-mode-alist)) 675 (last ama) 676 entry) 677 678 (while (cdr last) 679 (setq entry (car (cdr last))) 680 (if (or (member entry jka-compr-mode-alist-additions--internal) 681 (and (consp (cdr entry)) 682 (eq (nth 2 entry) 'jka-compr))) 683 (setcdr last (cdr (cdr last))) 684 (setq last (cdr last)))) 685 686 (setq auto-mode-alist (cdr ama))) 687 688 (while jka-compr-added-to-file-coding-system-alist 689 (setq file-coding-system-alist 690 (delq (car (member (pop jka-compr-added-to-file-coding-system-alist) 691 file-coding-system-alist)) 692 file-coding-system-alist))) 693 694 ;; Remove the suffixes that were added by jka-compr. 695 (dolist (suff jka-compr-load-suffixes--internal) 696 (setq load-file-rep-suffixes (delete suff load-file-rep-suffixes))) 697 698 (setq jka-compr-compression-info-list--internal nil 699 jka-compr-mode-alist-additions--internal nil 700 jka-compr-load-suffixes--internal nil)) 701 702(provide 'jka-compr) 703 704;; arch-tag: 3f15b630-e9a7-46c4-a22a-94afdde86ebc 705;;; jka-compr.el ends here 706