;;; 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-1995, 1997, 1999-2012 Free Software Foundation, Inc.
;; Author: jka@ece.cmu.edu (Jay K. Adams)
;; Maintainer: FSF
;; 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
;; 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 <http://www.gnu.org/licenses/>.
;;; Commentary:
;; 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.
;;; Code:
+(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)
(make-variable-buffer-local 'jka-compr-really-do-compress)
(put 'jka-compr-really-do-compress 'permanent-local t)
\f
-;;; Functions for accessing the return value of jka-compr-get-compression-info
-(defun jka-compr-info-regexp (info) (aref info 0))
-(defun jka-compr-info-compress-message (info) (aref info 1))
-(defun jka-compr-info-compress-program (info) (aref info 2))
-(defun jka-compr-info-compress-args (info) (aref info 3))
-(defun jka-compr-info-uncompress-message (info) (aref info 4))
-(defun jka-compr-info-uncompress-program (info) (aref info 5))
-(defun jka-compr-info-uncompress-args (info) (aref info 6))
-(defun jka-compr-info-can-append (info) (aref info 7))
-(defun jka-compr-info-strip-extension (info) (aref info 8))
-(defun jka-compr-info-file-magic-bytes (info) (aref info 9))
-
-
-(defun jka-compr-get-compression-info (filename)
- "Return information about the compression scheme of FILENAME.
-The determination as to which compression scheme, if any, to use is
-based on the filename itself and `jka-compr-compression-info-list'."
- (catch 'compression-info
- (let ((case-fold-search nil))
- (mapcar
- (function (lambda (x)
- (and (string-match (jka-compr-info-regexp x) filename)
- (throw 'compression-info x))))
- jka-compr-compression-info-list)
- nil)))
-
(put 'compression-error 'error-conditions '(compression-error file-error error))
(defun jka-compr-error (prog args infile message &optional errfile)
- (let ((errbuf (get-buffer-create " *jka-compr-error*"))
- (curbuf (current-buffer)))
+ (let ((errbuf (get-buffer-create " *jka-compr-error*")))
(with-current-buffer errbuf
(widen) (erase-buffer)
(insert (format "Error while executing \"%s %s < %s\"\n\n"
;; 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))
(unwind-protect
(or (memq (call-process
jka-compr-shell infile t nil "-c"
+ ;; Windows shells need the program file name
+ ;; after the pipe symbol be quoted if they use
+ ;; forward slashes as directory separators.
(format
- "%s %s 2> %s | %s bs=%d skip=%d %s 2> %s"
+ "%s %s 2> %s | \"%s\" bs=%d skip=%d %s 2> %s"
prog
(mapconcat 'identity args " ")
err-file
null-device))
jka-compr-acceptable-retval-list)
(jka-compr-error prog args infile message err-file))
- (jka-compr-delete-temp-file err-file)))
+ (delete-file err-file)))
+
;; Run the uncompression program directly.
;; We get the whole file and must delete what we don't want.
(jka-compr-call-process prog message infile t nil args))
(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)))))
-
-
-;;; Support for temp files. Much of this was inspired if not lifted
-;;; from ange-ftp.
+ ;; call-process barfs if default-directory is inaccessible.
+ (let ((default-directory
+ (if (and default-directory
+ (not (file-remote-p 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))
+ (delete-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
+;; from ange-ftp.
(defcustom jka-compr-temp-name-template
(expand-file-name "jka-com" temporary-file-directory)
:type 'string
:group 'jka-compr)
-(defun jka-compr-make-temp-name (&optional local-copy)
+(defun jka-compr-make-temp-name (&optional _local-copy)
"This routine will return the name of a new file."
(make-temp-file jka-compr-temp-name-template))
-(defalias 'jka-compr-delete-temp-file 'delete-file)
-
-
(defun jka-compr-write-region (start end file &optional append visit)
(let* ((filename (expand-file-name file))
(visit-file (if (stringp visit) (expand-file-name visit) filename))
(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
(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))
(and
compress-message
+ jka-compr-verbose
(message "%s %s..." compress-message base-name))
(jka-compr-run-real-handler 'write-region
(and append can-append) 'dont))
(erase-buffer)) )
- (jka-compr-delete-temp-file temp-file)
+ (delete-file temp-file)
(and
compress-message
+ jka-compr-verbose
(message "%s %s...done" compress-message base-name))
(cond
(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
+ jka-compr-verbose
+ (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
+ jka-compr-verbose
+ (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)
(jka-compr-run-real-handler 'file-local-copy (list filename)))
(temp-file (jka-compr-make-temp-name t))
(temp-buffer (get-buffer-create " *jka-compr-flc-temp*"))
- (notfound nil)
local-file)
(setq local-file (or local-copy filename))
(and
uncompress-message
+ jka-compr-verbose
(message "%s %s..." uncompress-message base-name))
;; Here we must read the output of uncompress program
(and
uncompress-message
+ jka-compr-verbose
(message "%s %s...done" uncompress-message base-name))
(write-region
(jka-compr-run-real-handler 'file-local-copy (list filename)))))
-;;; Support for loading compressed files.
-(defun jka-compr-load (file &optional noerror nomessage nosuffix)
+;; Support for loading compressed files.
+(defun jka-compr-load (file &optional noerror nomessage _nosuffix)
"Documented as original."
(let* ((local-copy (jka-compr-file-local-copy file))
(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)))
(setcar l file)))
- (jka-compr-delete-temp-file local-copy))
+ (delete-file local-copy))
t))
(defun jka-compr-uninstall ()
"Uninstall jka-compr.
This removes the entries in `file-name-handler-alist' and `auto-mode-alist'
-and `inhibit-first-line-modes-suffixes' that were added
+and `inhibit-local-variables-suffixes' that were added
by `jka-compr-installed'."
- ;; Delete from inhibit-first-line-modes-suffixes
- ;; what jka-compr-install added.
- (mapcar
+ ;; Delete from inhibit-local-variables-suffixes what jka-compr-install added.
+ (mapc
(function (lambda (x)
(and (jka-compr-info-strip-extension x)
- (setq inhibit-first-line-modes-suffixes
+ (setq inhibit-local-variables-suffixes
(delete (jka-compr-info-regexp x)
- inhibit-first-line-modes-suffixes)))))
- jka-compr-compression-info-list)
+ inhibit-local-variables-suffixes)))))
+ jka-compr-compression-info-list--internal)
(let* ((fnha (cons nil file-name-handler-alist))
(last fnha))
(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)))
(setq auto-mode-alist (cdr ama)))
- (let* ((ama (cons nil file-coding-system-alist))
- (last ama)
- entry)
-
- (while (cdr last)
- (setq entry (car (cdr last)))
- (if (member entry jka-compr-added-to-file-coding-system-alist)
- (setcdr last (cdr (cdr last)))
- (setq last (cdr last))))
-
- (setq file-coding-system-alist (cdr ama)))
+ (while jka-compr-added-to-file-coding-system-alist
+ (setq file-coding-system-alist
+ (delq (car (member (pop jka-compr-added-to-file-coding-system-alist)
+ file-coding-system-alist))
+ 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)
-;;; arch-tag: 3f15b630-e9a7-46c4-a22a-94afdde86ebc
;;; jka-compr.el ends here