X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/bffa514a8b8c947c655b463e8073e8e5ac061bc7..3ecba0495e877769d3b29f67f0648af39352edb8:/lisp/jka-compr.el diff --git a/lisp/jka-compr.el b/lisp/jka-compr.el index c15cfbdea3..34ffcc90a7 100644 --- a/lisp/jka-compr.el +++ b/lisp/jka-compr.el @@ -1,7 +1,7 @@ ;;; jka-compr.el --- reading/writing/loading compressed files -;; Copyright (C) 1993, 1994, 1995, 1997, 1999, 2000, 2002, 2003, -;; 2004, 2005 Free Software Foundation, Inc. +;; Copyright (C) 1993, 1994, 1995, 1997, 1999, 2000, 2001, 2002, 2003, +;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ;; Author: jka@ece.cmu.edu (Jay K. Adams) ;; Maintainer: FSF @@ -9,10 +9,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of @@ -20,9 +20,7 @@ ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: @@ -47,18 +45,9 @@ ;; The default value of this variable allows jka-compr to work with ;; Unix compress and gzip. ;; -;; If you are concerned about the stderr output of gzip and other -;; compression/decompression programs showing up in your buffers, you -;; should set the discard-error flag in the compression-info-list. -;; This will cause the stderr of all programs to be discarded. -;; However, it also causes emacs to call compression/uncompression -;; programs through a shell (which is specified by jka-compr-shell). -;; This may be a drag if, on your system, starting up a shell is -;; slow. -;; ;; If you don't want messages about compressing and decompressing -;; to show up in the echo area, you can set the compress-name and -;; decompress-name fields of the jka-compr-compression-info-list to +;; to show up in the echo area, you can set the compress-msg and +;; decompress-msg fields of the jka-compr-compression-info-list to ;; nil. @@ -104,10 +93,8 @@ (require 'jka-cmpr-hook) (defcustom jka-compr-shell "sh" - "*Shell to be used for calling compression programs. -The value of this variable only matters if you want to discard the -stderr of a compression/decompression program (see the documentation -for `jka-compr-compression-info-list')." + "Shell to be used for calling compression programs. +NOTE: Not used in MS-DOS and Windows systems." :type 'string :group 'jka-compr) @@ -166,6 +153,12 @@ to keep: LEN chars starting BEG chars from the beginning." ;; to discard the part we don't want. (let ((skip (/ beg jka-compr-dd-blocksize)) (err-file (jka-compr-make-temp-name)) + ;; call-process barfs if default-directory is inaccessible. + (default-directory + (if (and default-directory + (file-accessible-directory-p default-directory)) + default-directory + (file-name-directory infile))) count) ;; Update PREFIX based on the text that we won't read in. (setq prefix (- beg (* skip jka-compr-dd-blocksize)) @@ -204,45 +197,41 @@ to keep: LEN chars starting BEG chars from the beginning." (defun jka-compr-call-process (prog message infile output temp args) - (if jka-compr-use-shell - - (let ((err-file (jka-compr-make-temp-name)) - (coding-system-for-read (or coding-system-for-read 'undecided)) - (coding-system-for-write 'no-conversion)) - - (unwind-protect - - (or (memq - (call-process jka-compr-shell infile - (if (stringp output) nil output) - nil - "-c" - (format "%s %s 2> %s %s" - prog - (mapconcat 'identity args " ") - err-file - (if (stringp output) - (concat "> " output) - ""))) - jka-compr-acceptable-retval-list) - - (jka-compr-error prog args infile message err-file)) - - (jka-compr-delete-temp-file err-file))) - - (or (eq 0 - (apply 'call-process - prog - infile - (if (stringp output) temp output) - nil - args)) - (jka-compr-error prog args infile message)) - - (and (stringp output) - (with-current-buffer temp - (write-region (point-min) (point-max) output) - (erase-buffer))))) + ;; call-process barfs if default-directory is inaccessible. + (let ((default-directory + (if (and default-directory + (file-accessible-directory-p default-directory)) + default-directory + (file-name-directory infile)))) + (if jka-compr-use-shell + (let ((err-file (jka-compr-make-temp-name)) + (coding-system-for-read (or coding-system-for-read 'undecided)) + (coding-system-for-write 'no-conversion)) + (unwind-protect + (or (memq + (call-process jka-compr-shell infile + (if (stringp output) nil output) + nil + "-c" + (format "%s %s 2> %s %s" + prog + (mapconcat 'identity args " ") + err-file + (if (stringp output) + (concat "> " output) + ""))) + jka-compr-acceptable-retval-list) + (jka-compr-error prog args infile message err-file)) + (jka-compr-delete-temp-file err-file))) + (or (eq 0 + (apply 'call-process + prog infile (if (stringp output) temp output) + nil args)) + (jka-compr-error prog args infile message)) + (and (stringp output) + (with-current-buffer temp + (write-region (point-min) (point-max) output) + (erase-buffer)))))) ;; Support for temp files. Much of this was inspired if not lifted @@ -268,16 +257,12 @@ There should be no more than seven characters after the final `/'." (info (jka-compr-get-compression-info visit-file)) (magic (and info (jka-compr-info-file-magic-bytes info)))) - ;; If START is nil, use the whole buffer. - (if (null start) - (setq start 1 end (1+ (buffer-size)))) - ;; If we uncompressed this file when visiting it, ;; then recompress it when writing it ;; even if the contents look compressed already. (if (and jka-compr-really-do-compress - (eq start 1) - (eq end (1+ (buffer-size)))) + (or (null start) + (= (- end start) (buffer-size)))) (setq magic nil)) (if (and info @@ -288,9 +273,10 @@ There should be no more than seven characters after the final `/'." (equal (if (stringp start) (substring start 0 (min (length start) (length magic))) - (buffer-substring start - (min end - (+ start (length magic))))) + (let* ((from (or start (point-min))) + (to (min (or end (point-max)) + (+ from (length magic))))) + (buffer-substring from to))) magic)))) (let ((can-append (jka-compr-info-can-append info)) (compress-program (jka-compr-info-compress-program info)) @@ -391,137 +377,137 @@ There should be no more than seven characters after the final `/'." (let* ((filename (expand-file-name file)) (info (jka-compr-get-compression-info filename))) - (if info - - (let ((uncompress-message (jka-compr-info-uncompress-message info)) - (uncompress-program (jka-compr-info-uncompress-program info)) - (uncompress-args (jka-compr-info-uncompress-args info)) - (base-name (file-name-nondirectory filename)) - (notfound nil) - (local-copy - (jka-compr-run-real-handler 'file-local-copy (list filename))) - local-file - size start) - - (setq local-file (or local-copy filename)) - - (and - visit - (setq buffer-file-name filename)) - - (unwind-protect ; to make sure local-copy gets deleted - - (progn - - (and - uncompress-message - (message "%s %s..." uncompress-message base-name)) - - (condition-case error-code - - (let ((coding-system-for-read 'no-conversion)) - (if replace - (goto-char (point-min))) - (setq start (point)) - (if (or beg end) - (jka-compr-partial-uncompress uncompress-program - (concat uncompress-message - " " base-name) - uncompress-args - local-file - (or beg 0) - (if (and beg end) - (- end beg) - end)) - ;; If visiting, bind off buffer-file-name so that - ;; file-locking will not ask whether we should - ;; really edit the buffer. - (let ((buffer-file-name - (if visit nil buffer-file-name))) - (jka-compr-call-process uncompress-program - (concat uncompress-message - " " base-name) - local-file - t - nil - uncompress-args))) - (setq size (- (point) start)) - (if replace - (delete-region (point) (point-max))) - (goto-char start)) - (error - ;; If the file we wanted to uncompress does not exist, - ;; handle that according to VISIT as `insert-file-contents' - ;; would, maybe signaling the same error it normally would. - (if (and (eq (car error-code) 'file-error) - (eq (nth 3 error-code) local-file)) - (if visit - (setq notfound error-code) - (signal 'file-error - (cons "Opening input file" - (nthcdr 2 error-code)))) - ;; If the uncompression program can't be found, - ;; signal that as a non-file error - ;; so that find-file-noselect-1 won't handle it. - (if (and (eq (car error-code) 'file-error) - (equal (cadr error-code) "Searching for program")) - (error "Uncompression program `%s' not found" - (nth 3 error-code))) - (signal (car error-code) (cdr error-code)))))) - - (and - local-copy - (file-exists-p local-copy) - (delete-file local-copy))) - - (unless notfound - (decode-coding-inserted-region - (point) (+ (point) size) - (jka-compr-byte-compiler-base-file-name file) - visit beg end replace)) - - (and - visit - (progn - (unlock-buffer) - (setq buffer-file-name filename) - (setq jka-compr-really-do-compress t) - (set-visited-file-modtime))) - - (and - uncompress-message - (message "%s %s...done" uncompress-message base-name)) - - (and - visit - notfound - (signal 'file-error - (cons "Opening input file" (nth 2 notfound)))) - - ;; This is done in insert-file-contents after we return. - ;; That is a little weird, but better to go along with it now - ;; than to change it now. - -;;; ;; Run the functions that insert-file-contents would. -;;; (let ((p after-insert-file-functions) -;;; (insval size)) -;;; (while p -;;; (setq insval (funcall (car p) size)) -;;; (if insval -;;; (progn -;;; (or (integerp insval) -;;; (signal 'wrong-type-argument -;;; (list 'integerp insval))) -;;; (setq size insval))) -;;; (setq p (cdr p)))) - - (or (jka-compr-info-compress-program info) - (message "You can't save this buffer because compression program is not defined")) - - (list filename size)) - - (jka-compr-run-real-handler 'insert-file-contents - (list file visit beg end replace))))) + (if (not info) + + (jka-compr-run-real-handler 'insert-file-contents + (list file visit beg end replace)) + + (let ((uncompress-message (jka-compr-info-uncompress-message info)) + (uncompress-program (jka-compr-info-uncompress-program info)) + (uncompress-args (jka-compr-info-uncompress-args info)) + (base-name (file-name-nondirectory filename)) + (notfound nil) + (local-copy + (jka-compr-run-real-handler 'file-local-copy (list filename))) + local-file + size start) + + (setq local-file (or local-copy filename)) + + (and + visit + (setq buffer-file-name filename)) + + (unwind-protect ; to make sure local-copy gets deleted + + (progn + + (and + uncompress-message + (message "%s %s..." uncompress-message base-name)) + + (condition-case error-code + + (let ((coding-system-for-read 'no-conversion)) + (if replace + (goto-char (point-min))) + (setq start (point)) + (if (or beg end) + (jka-compr-partial-uncompress uncompress-program + (concat uncompress-message + " " base-name) + uncompress-args + local-file + (or beg 0) + (if (and beg end) + (- end beg) + end)) + ;; If visiting, bind off buffer-file-name so that + ;; file-locking will not ask whether we should + ;; really edit the buffer. + (let ((buffer-file-name + (if visit nil buffer-file-name))) + (jka-compr-call-process uncompress-program + (concat uncompress-message + " " base-name) + local-file + t + nil + uncompress-args))) + (setq size (- (point) start)) + (if replace + (delete-region (point) (point-max))) + (goto-char start)) + (error + ;; If the file we wanted to uncompress does not exist, + ;; handle that according to VISIT as `insert-file-contents' + ;; would, maybe signaling the same error it normally would. + (if (and (eq (car error-code) 'file-error) + (eq (nth 3 error-code) local-file)) + (if visit + (setq notfound error-code) + (signal 'file-error + (cons "Opening input file" + (nthcdr 2 error-code)))) + ;; If the uncompression program can't be found, + ;; signal that as a non-file error + ;; so that find-file-noselect-1 won't handle it. + (if (and (eq (car error-code) 'file-error) + (equal (cadr error-code) "Searching for program")) + (error "Uncompression program `%s' not found" + (nth 3 error-code))) + (signal (car error-code) (cdr error-code)))))) + + (and + local-copy + (file-exists-p local-copy) + (delete-file local-copy))) + + (unless notfound + (decode-coding-inserted-region + (point) (+ (point) size) + (jka-compr-byte-compiler-base-file-name file) + visit beg end replace)) + + (and + visit + (progn + (unlock-buffer) + (setq buffer-file-name filename) + (setq jka-compr-really-do-compress t) + (set-visited-file-modtime))) + + (and + uncompress-message + (message "%s %s...done" uncompress-message base-name)) + + (and + visit + notfound + (signal 'file-error + (cons "Opening input file" (nth 2 notfound)))) + + ;; This is done in insert-file-contents after we return. + ;; That is a little weird, but better to go along with it now + ;; than to change it now. + + ;; ;; Run the functions that insert-file-contents would. + ;; (let ((p after-insert-file-functions) + ;; (insval size)) + ;; (while p + ;; (setq insval (funcall (car p) size)) + ;; (if insval + ;; (progn + ;; (or (integerp insval) + ;; (signal 'wrong-type-argument + ;; (list 'integerp insval))) + ;; (setq size insval))) + ;; (setq p (cdr p)))) + + (or (jka-compr-info-compress-program info) + (message "You can't save this buffer because compression program is not defined")) + + (list filename size))))) (defun jka-compr-file-local-copy (file) @@ -604,7 +590,14 @@ There should be no more than seven characters after the final `/'." (or nomessage (message "Loading %s...done." file)) ;; Fix up the load history to point at the right library. - (let ((l (assoc load-file load-history))) + (let ((l (or (assoc load-file load-history) + ;; On MS-Windows, if load-file is in + ;; temporary-file-directory, it will look like + ;; "c:/DOCUME~1/USER/LOCALS~1/foo", whereas + ;; readevalloop will record its truename in + ;; load-history. Therefore try truename if the + ;; original name is not in load-history. + (assoc (file-truename load-file) load-history)))) ;; Remove .gz and .elc?. (while (file-name-extension file) (setq file (file-name-sans-extension file))) @@ -662,13 +655,13 @@ and `inhibit-first-line-modes-suffixes' that were added by `jka-compr-installed'." ;; Delete from inhibit-first-line-modes-suffixes ;; what jka-compr-install added. - (mapcar + (mapc (function (lambda (x) (and (jka-compr-info-strip-extension x) (setq inhibit-first-line-modes-suffixes (delete (jka-compr-info-regexp x) inhibit-first-line-modes-suffixes))))) - jka-compr-compression-info-list) + jka-compr-compression-info-list--internal) (let* ((fnha (cons nil file-name-handler-alist)) (last fnha)) @@ -686,7 +679,7 @@ by `jka-compr-installed'." (while (cdr last) (setq entry (car (cdr last))) - (if (or (member entry jka-compr-mode-alist-additions) + (if (or (member entry jka-compr-mode-alist-additions--internal) (and (consp (cdr entry)) (eq (nth 2 entry) 'jka-compr))) (setcdr last (cdr (cdr last))) @@ -701,12 +694,12 @@ by `jka-compr-installed'." file-coding-system-alist))) ;; Remove the suffixes that were added by jka-compr. - (let ((suffixes nil) - (re (jka-compr-build-file-regexp))) - (dolist (suffix load-suffixes) - (unless (string-match re suffix) - (push suffix suffixes))) - (setq load-suffixes (nreverse suffixes)))) + (dolist (suff jka-compr-load-suffixes--internal) + (setq load-file-rep-suffixes (delete suff load-file-rep-suffixes))) + + (setq jka-compr-compression-info-list--internal nil + jka-compr-mode-alist-additions--internal nil + jka-compr-load-suffixes--internal nil)) (provide 'jka-compr)