;;; jka-compr.el --- reading/writing/loading compressed files
-;; Copyright (C) 1993, 1994, 1995, 1997, 1999, 2000 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 1994, 1995, 1997, 1999, 2000, 2002, 2003,
+;; 2004, 2005, 2006 Free Software Foundation, Inc.
;; Author: jka@ece.cmu.edu (Jay K. Adams)
;; Maintainer: FSF
;; 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., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; ACKNOWLEDGMENTS
-;;
+;;
;; jka-compr is a V19 adaptation of jka-compr for V18 of Emacs. Many people
-;; have made helpful suggestions, reported bugs, and even fixed bugs in
+;; have made helpful suggestions, reported bugs, and even fixed bugs in
;; jka-compr. I recall the following people as being particularly helpful.
;;
;; Jean-loup Gailly
;;; Code:
-(defgroup compression nil
- "Data compression utilities"
- :group 'data)
-
-(defgroup jka-compr nil
- "jka-compr customization"
- :group 'compression)
-
+(require 'jka-cmpr-hook)
(defcustom jka-compr-shell "sh"
"*Shell to be used for calling compression programs.
:type 'string
:group 'jka-compr)
-(defvar jka-compr-use-shell
+(defvar jka-compr-use-shell
(not (memq system-type '(ms-dos windows-nt))))
-;;; I have this defined so that .Z files are assumed to be in unix
-;;; compress format; and .gz files, in gzip format, and .bz2 files in bzip fmt.
-(defcustom jka-compr-compression-info-list
- ;;[regexp
- ;; compr-message compr-prog compr-args
- ;; uncomp-message uncomp-prog uncomp-args
- ;; can-append auto-mode-flag strip-extension-flag file-magic-bytes]
- '(["\\.Z\\(~\\|\\.~[0-9]+~\\)?\\'"
- "compressing" "compress" ("-c")
- "uncompressing" "uncompress" ("-c")
- nil t "\037\235"]
- ;; Formerly, these had an additional arg "-c", but that fails with
- ;; "Version 0.1pl2, 29-Aug-97." (RedHat 5.1 GNU/Linux) and
- ;; "Version 0.9.0b, 9-Sept-98".
- ["\\.bz2\\'"
- "bzip2ing" "bzip2" nil
- "bunzip2ing" "bzip2" ("-d")
- nil t "BZh"]
- ["\\.tgz\\'"
- "zipping" "gzip" ("-c" "-q")
- "unzipping" "gzip" ("-c" "-q" "-d")
- t nil "\037\213"]
- ["\\.g?z\\(~\\|\\.~[0-9]+~\\)?\\'"
- "zipping" "gzip" ("-c" "-q")
- "unzipping" "gzip" ("-c" "-q" "-d")
- t t "\037\213"])
-
- "List of vectors that describe available compression techniques.
-Each element, which describes a compression technique, is a vector of
-the form [REGEXP COMPRESS-MSG COMPRESS-PROGRAM COMPRESS-ARGS
-UNCOMPRESS-MSG UNCOMPRESS-PROGRAM UNCOMPRESS-ARGS
-APPEND-FLAG STRIP-EXTENSION-FLAG FILE-MAGIC-CHARS], where:
-
- regexp is a regexp that matches filenames that are
- compressed with this format
-
- compress-msg is the message to issue to the user when doing this
- type of compression (nil means no message)
-
- compress-program is a program that performs this compression
-
- compress-args is a list of args to pass to the compress program
-
- uncompress-msg is the message to issue to the user when doing this
- type of uncompression (nil means no message)
-
- uncompress-program is a program that performs this compression
-
- uncompress-args is a list of args to pass to the uncompress program
-
- append-flag is non-nil if this compression technique can be
- appended
-
- strip-extension-flag non-nil means strip the regexp from file names
- before attempting to set the mode.
-
- file-magic-chars is a string of characters that you would find
- at the beginning of a file compressed in this way.
-
-Because of the way `call-process' is defined, discarding the stderr output of
-a program adds the overhead of starting a shell each time the program is
-invoked."
- :type '(repeat (vector regexp
- (choice :tag "Compress Message"
- (string :format "%v")
- (const :tag "No Message" nil))
- (string :tag "Compress Program")
- (repeat :tag "Compress Arguments" string)
- (choice :tag "Uncompress Message"
- (string :format "%v")
- (const :tag "No Message" nil))
- (string :tag "Uncompress Program")
- (repeat :tag "Uncompress Arguments" string)
- (boolean :tag "Append")
- (boolean :tag "Strip Extension")
- (string :tag "Magic Bytes")))
- :group 'jka-compr)
-
-(defcustom jka-compr-mode-alist-additions
- (list (cons "\\.tgz\\'" 'tar-mode))
- "A list of pairs to add to `auto-mode-alist' when jka-compr is installed."
- :type '(repeat (cons string symbol))
- :group 'jka-compr)
-
-(defcustom jka-compr-load-suffixes '(".gz")
- "List of suffixes to try when loading files."
- :type '(repeat string)
- :group 'jka-compr)
-
-;; List of all the elements we actually added to file-coding-system-alist.
-(defvar jka-compr-added-to-file-coding-system-alist nil)
-
-(defvar jka-compr-file-name-handler-entry
- nil
- "The entry in `file-name-handler-alist' used by the jka-compr I/O functions.")
-
(defvar jka-compr-really-do-compress nil
- "Non-nil in a buffer whose visited file was uncompressed on visiting it.")
+ "Non-nil in a buffer whose visited file was uncompressed on visiting it.
+This means compress the data on writing the file, even if the
+data appears to be compressed already.")
+(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"
(signal 'compression-error
(list "Opening input file" (format "error %s" message) infile)))
-
-
+
+
(defcustom jka-compr-dd-program "/bin/dd"
"How to invoke `dd'."
:type 'string
(jka-compr-delete-temp-file err-file)))
- (or (zerop
+ (or (eq 0
(apply 'call-process
prog
infile
(erase-buffer)))))
-;;; Support for temp files. Much of this was inspired if not lifted
-;;; from ange-ftp.
+;; 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)
(let ((can-append (jka-compr-info-can-append info))
(compress-program (jka-compr-info-compress-program info))
(compress-message (jka-compr-info-compress-message info))
- (uncompress-program (jka-compr-info-uncompress-program info))
- (uncompress-message (jka-compr-info-uncompress-message info))
(compress-args (jka-compr-info-compress-args info))
- (uncompress-args (jka-compr-info-uncompress-args info))
(base-name (file-name-nondirectory visit-file))
temp-file temp-buffer
;; we need to leave `last-coding-system-used' set to its
;; that `basic-save-buffer' sees the right value.
(coding-system-used last-coding-system-used))
+ (or compress-program
+ (error "No compression program defined"))
+
(setq temp-buffer (get-buffer-create " *jka-compr-wr-temp*"))
(with-current-buffer temp-buffer
(widen) (erase-buffer))
(setq temp-file (jka-compr-make-temp-name)))
- (and
+ (and
compress-message
(message "%s %s..." compress-message base-name))
(setq last-coding-system-used coding-system-used)
nil)
-
+
(jka-compr-run-real-handler 'write-region
(list start end filename append visit)))))
(local-copy
(jka-compr-run-real-handler 'file-local-copy (list filename)))
local-file
- size start
- (coding-system-for-read
- (or coding-system-for-read
- ;; If multibyte characters are disabled,
- ;; don't do that conversion.
- (and (null enable-multibyte-characters)
- (or (auto-coding-alist-lookup
- (jka-compr-byte-compiler-base-file-name file))
- 'raw-text))
- (let ((coding (find-operation-coding-system
- 'insert-file-contents
- (jka-compr-byte-compiler-base-file-name file))))
- (and (consp coding) (car coding)))
- 'undecided)) )
+ size start)
(setq local-file (or local-copy 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
- (progn
+ (let ((coding-system-for-read 'no-conversion))
(if replace
(goto-char (point-min)))
(setq start (point))
uncompress-args)))
(setq size (- (point) start))
(if replace
- (let* ((del-beg (point))
- (del-end (+ del-beg size)))
- (delete-region del-beg
- (min del-end (point-max)))))
+ (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
+ (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
(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
(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))
;;; (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
(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))
(unwind-protect
(with-current-buffer temp-buffer
-
+
(and
uncompress-message
(message "%s %s..." uncompress-message base-name))
-
+
;; Here we must read the output of uncompress program
;; and write it to TEMP-FILE without any code
;; conversion. An appropriate code conversion (if
(kill-buffer temp-buffer))
temp-file)
-
+
(jka-compr-run-real-handler 'file-local-copy (list filename)))))
-;;; Support for loading compressed files.
+;; Support for loading compressed files.
(defun jka-compr-load (file &optional noerror nomessage nosuffix)
"Documented as original."
(put 'byte-compiler-base-file-name 'jka-compr
'jka-compr-byte-compiler-base-file-name)
+;;;###autoload
(defvar jka-compr-inhibit nil
"Non-nil means inhibit automatic uncompression temporarily.
Lisp programs can bind this to t to do that.
It is not recommended to set this variable permanently to anything but nil.")
-(put 'jka-compr-handler 'safe-magic t)
+;;;###autoload
(defun jka-compr-handler (operation &rest args)
(save-match-data
(let ((jka-op (get operation 'jka-compr)))
(inhibit-file-name-operation operation))
(apply operation args)))
-
-(defun jka-compr-build-file-regexp ()
- (mapconcat
- 'jka-compr-info-regexp
- jka-compr-compression-info-list
- "\\|"))
-
-
-(defun jka-compr-install ()
- "Install jka-compr.
-This adds entries to `file-name-handler-alist' and `auto-mode-alist'
-and `inhibit-first-line-modes-suffixes'."
-
- (setq jka-compr-file-name-handler-entry
- (cons (jka-compr-build-file-regexp) 'jka-compr-handler))
-
- (setq file-name-handler-alist (cons jka-compr-file-name-handler-entry
- file-name-handler-alist))
-
- (setq jka-compr-added-to-file-coding-system-alist nil)
-
- (mapcar
- (function (lambda (x)
- ;; Don't do multibyte encoding on the compressed files.
- (let ((elt (cons (jka-compr-info-regexp x)
- '(no-conversion . no-conversion))))
- (setq file-coding-system-alist
- (cons elt file-coding-system-alist))
- (setq jka-compr-added-to-file-coding-system-alist
- (cons elt jka-compr-added-to-file-coding-system-alist)))
-
- (and (jka-compr-info-strip-extension x)
- ;; Make entries in auto-mode-alist so that modes
- ;; are chosen right according to the file names
- ;; sans `.gz'.
- (setq auto-mode-alist
- (cons (list (jka-compr-info-regexp x)
- nil 'jka-compr)
- auto-mode-alist))
- ;; Also add these regexps to
- ;; inhibit-first-line-modes-suffixes, so that a
- ;; -*- line in the first file of a compressed tar
- ;; file doesn't override tar-mode.
- (setq inhibit-first-line-modes-suffixes
- (cons (jka-compr-info-regexp x)
- inhibit-first-line-modes-suffixes)))))
- jka-compr-compression-info-list)
- (setq auto-mode-alist
- (append auto-mode-alist jka-compr-mode-alist-additions))
-
- ;; Make sure that (load "foo") will find /bla/foo.el.gz.
- (setq load-suffixes
- (apply 'append
- (mapcar (lambda (suffix)
- (cons suffix
- (mapcar (lambda (ext) (concat suffix ext))
- jka-compr-load-suffixes)))
- load-suffixes))))
-
-
+;;;###autoload
(defun jka-compr-uninstall ()
"Uninstall jka-compr.
This removes the entries in `file-name-handler-alist' and `auto-mode-alist'
(eq (nth 2 entry) 'jka-compr)))
(setcdr last (cdr (cdr last)))
(setq last (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)
(push suffix suffixes)))
(setq load-suffixes (nreverse suffixes))))
-
-(defun jka-compr-installed-p ()
- "Return non-nil if jka-compr is installed.
-The return value is the entry in `file-name-handler-alist' for jka-compr."
-
- (let ((fnha file-name-handler-alist)
- (installed nil))
-
- (while (and fnha (not installed))
- (and (eq (cdr (car fnha)) 'jka-compr-handler)
- (setq installed (car fnha)))
- (setq fnha (cdr fnha)))
-
- installed))
-
-
-;;; Add the file I/O hook if it does not already exist.
-;;; Make sure that jka-compr-file-name-handler-entry is eq to the
-;;; entry for jka-compr in file-name-handler-alist.
-(and (jka-compr-installed-p)
- (jka-compr-uninstall))
-
-
-;;;###autoload
-(define-minor-mode auto-compression-mode
- "Toggle automatic file compression and uncompression.
-With prefix argument ARG, turn auto compression on if positive, else off.
-Returns the new status of auto compression (non-nil means on)."
- :global t :group 'jka-compr
- (let* ((installed (jka-compr-installed-p))
- (flag auto-compression-mode))
- (cond
- ((and flag installed) t) ; already installed
- ((and (not flag) (not installed)) nil) ; already not installed
- (flag (jka-compr-install))
- (t (jka-compr-uninstall)))))
-
-
-;;;###autoload
-(defmacro with-auto-compression-mode (&rest body)
- "Evalute BODY with automatic file compression and uncompression enabled."
- (let ((already-installed (make-symbol "already-installed")))
- `(let ((,already-installed (jka-compr-installed-p)))
- (unwind-protect
- (progn
- (unless ,already-installed
- (jka-compr-install))
- ,@body)
- (unless ,already-installed
- (jka-compr-uninstall))))))
-(put 'with-auto-compression-mode 'lisp-indent-function 0)
-
-
(provide 'jka-compr)
+;; arch-tag: 3f15b630-e9a7-46c4-a22a-94afdde86ebc
;;; jka-compr.el ends here