;;; jka-compr.el --- reading/writing/loading compressed files
-;; Copyright (C) 1993, 1994, 1995, 1997 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 1994, 1995, 1997, 1999 Free Software Foundation, Inc.
;; Author: jka@ece.cmu.edu (Jay K. Adams)
;; Maintainer: FSF
:type 'string
:group 'jka-compr)
-(defvar jka-compr-use-shell t)
-
+(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.
+;;; 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]
+ ;; can-append auto-mode-flag strip-extension-flag file-magic-bytes]
'(["\\.Z\\(~\\|\\.~[0-9]+~\\)?\\'"
"compressing" "compress" ("-c")
"uncompressing" "uncompress" ("-c")
- nil t]
+ 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]
- ["\\.gz\\(~\\|\\.~[0-9]+~\\)?\\'"
+ t nil "\037\213"]
+ ["\\.g?z\\(~\\|\\.~[0-9]+~\\)?\\'"
"zipping" "gzip" ("-c" "-q")
"unzipping" "gzip" ("-c" "-q" "-d")
- t t])
+ 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 EXTENSION], where:
+APPEND-FLAG STRIP-EXTENSION-FLAG FILE-MAGIC-CHARS], where:
regexp is a regexp that matches filenames that are
compressed with this format
append-flag is non-nil if this compression technique can be
appended
- auto-mode flag non-nil means strip the regexp from file names
+ 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."
(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.")
+(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-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)
(let ((err-file (jka-compr-make-temp-name))
(coding-system-for-read (or coding-system-for-read 'undecided))
- (coding-system-for-write 'no-conversion) )
+ (coding-system-for-write 'no-conversion))
(unwind-protect
;;; from ange-ftp.
(defcustom jka-compr-temp-name-template
- (expand-file-name "jka-com"
- (or (getenv "TMPDIR") "/tmp/"))
+ (expand-file-name "jka-com" temporary-file-directory)
"Prefix added to all temp files created by jka-compr.
There should be no more than seven characters after the final `/'."
:type 'string
:group 'jka-compr)
-(defvar jka-compr-temp-name-table (make-vector 31 nil))
-
(defun jka-compr-make-temp-name (&optional local-copy)
"This routine will return the name of a new file."
- (let* ((lastchar ?a)
- (prevchar ?a)
- (template (concat jka-compr-temp-name-template "aa"))
- (lastpos (1- (length template)))
- (not-done t)
- file
- entry)
-
- (while not-done
- (aset template lastpos lastchar)
- (setq file (concat (make-temp-name template) "#"))
- (setq entry (intern file jka-compr-temp-name-table))
- (if (or (get entry 'active)
- (file-exists-p file))
-
- (progn
- (setq lastchar (1+ lastchar))
- (if (> lastchar ?z)
- (progn
- (setq prevchar (1+ prevchar))
- (setq lastchar ?a)
- (if (> prevchar ?z)
- (error "Can't allocate temp file.")
- (aset template (1- lastpos) prevchar)))))
-
- (put entry 'active (not local-copy))
- (setq not-done nil)))
-
- file))
-
-
-(defun jka-compr-delete-temp-file (temp)
-
- (put (intern temp jka-compr-temp-name-table)
- 'active nil)
+ (make-temp-file jka-compr-temp-name-template))
- (condition-case ()
- (delete-file temp)
- (error nil)))
+(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)))
-
- (if info
-
- (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)
-
- (setq temp-buffer (get-buffer-create " *jka-compr-wr-temp*"))
- (with-current-buffer temp-buffer
- (widen) (erase-buffer))
-
- (if (and append
- (not can-append)
- (file-exists-p filename))
-
- (let* ((local-copy (file-local-copy filename))
- (local-file (or local-copy filename)))
-
- (setq temp-file local-file))
-
- (setq temp-file (jka-compr-make-temp-name)))
-
- (and
- compress-message
- (message "%s %s..." compress-message base-name))
-
- (jka-compr-run-real-handler 'write-region
- (list start end temp-file t 'dont))
-
- ;; Here we must read the output of compress program as is
- ;; without any code conversion.
- (let ((coding-system-for-read 'no-conversion))
- (jka-compr-call-process compress-program
- (concat compress-message
- " " base-name)
- temp-file
- temp-buffer
- nil
- compress-args))
-
- (with-current-buffer temp-buffer
- (let ((coding-system-for-write 'no-conversion))
- (if (memq system-type '(ms-dos windows-nt))
- (setq buffer-file-type t) )
- (jka-compr-run-real-handler 'write-region
- (list (point-min) (point-max)
- filename
- (and append can-append) 'dont))
- (erase-buffer)) )
-
- (jka-compr-delete-temp-file temp-file)
+ (info (jka-compr-get-compression-info visit-file))
+ (magic (and info (jka-compr-info-file-magic-bytes info))))
+
+ ;; 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))))
+ (setq magic nil))
+
+ (if (and info
+ ;; If the contents to be written out
+ ;; are properly compressed already,
+ ;; don't try to compress them over again.
+ (not (and magic
+ (equal (if (stringp start)
+ (substring start 0 (min (length start)
+ (length magic)))
+ (buffer-substring start
+ (min end
+ (+ start (length magic)))))
+ magic))))
+ (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
+ ;; value after calling write-region the first time, so
+ ;; that `basic-save-buffer' sees the right value.
+ (coding-system-used last-coding-system-used))
+
+ (setq temp-buffer (get-buffer-create " *jka-compr-wr-temp*"))
+ (with-current-buffer temp-buffer
+ (widen) (erase-buffer))
+
+ (if (and append
+ (not can-append)
+ (file-exists-p filename))
+
+ (let* ((local-copy (file-local-copy filename))
+ (local-file (or local-copy filename)))
+
+ (setq temp-file local-file))
+
+ (setq temp-file (jka-compr-make-temp-name)))
+
+ (and
+ compress-message
+ (message "%s %s..." compress-message base-name))
+
+ (jka-compr-run-real-handler 'write-region
+ (list start end temp-file t 'dont))
+ ;; save value used by the real write-region
+ (setq coding-system-used last-coding-system-used)
+
+ ;; Here we must read the output of compress program as is
+ ;; without any code conversion.
+ (let ((coding-system-for-read 'no-conversion))
+ (jka-compr-call-process compress-program
+ (concat compress-message
+ " " base-name)
+ temp-file
+ temp-buffer
+ nil
+ compress-args))
+
+ (with-current-buffer temp-buffer
+ (let ((coding-system-for-write 'no-conversion))
+ (if (memq system-type '(ms-dos windows-nt))
+ (setq buffer-file-type t) )
+ (jka-compr-run-real-handler 'write-region
+ (list (point-min) (point-max)
+ filename
+ (and append can-append) 'dont))
+ (erase-buffer)) )
+
+ (jka-compr-delete-temp-file temp-file)
- (and
- compress-message
- (message "%s %s...done" compress-message base-name))
-
- (cond
- ((eq visit t)
- (setq buffer-file-name filename)
- (set-visited-file-modtime))
- ((stringp visit)
- (setq buffer-file-name visit)
- (let ((buffer-file-name filename))
- (set-visited-file-modtime))))
-
- (and (or (eq visit t)
- (eq visit nil)
- (stringp visit))
- (message "Wrote %s" visit-file))
-
- nil)
+ (and
+ compress-message
+ (message "%s %s...done" compress-message base-name))
+
+ (cond
+ ((eq visit t)
+ (setq buffer-file-name filename)
+ (setq jka-compr-really-do-compress t)
+ (set-visited-file-modtime))
+ ((stringp visit)
+ (setq buffer-file-name visit)
+ (let ((buffer-file-name filename))
+ (set-visited-file-modtime))))
+
+ (and (or (eq visit t)
+ (eq visit nil)
+ (stringp visit))
+ (message "Wrote %s" visit-file))
+
+ ;; ensure `last-coding-system-used' has an appropriate value
+ (setq last-coding-system-used coding-system-used)
+
+ nil)
- (jka-compr-run-real-handler 'write-region
- (list start end filename append visit)))))
+ (jka-compr-run-real-handler 'write-region
+ (list start end filename append visit)))))
(defun jka-compr-insert-file-contents (file &optional visit beg end replace)
;; If multibyte characters are disabled,
;; don't do that conversion.
(and (null enable-multibyte-characters)
- 'raw-text)
- (let ((tail file-coding-system-alist)
- (newfile
- (jka-compr-byte-compiler-base-file-name file))
- result)
- (while tail
- (if (string-match (car (car tail)) newfile)
- (setq result (car (cdr (car tail)))
- tail nil))
- (setq tail (cdr tail)))
- result)
+ (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)) )
(setq local-file (or local-copy filename))
(progn
(unlock-buffer)
(setq buffer-file-name filename)
+ (setq jka-compr-really-do-compress t)
(set-visited-file-modtime)))
(and
(signal 'file-error
(cons "Opening input file" (nth 2 notfound))))
- ;; 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))))
+ ;; 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))))
(list filename size))
(let ((load-force-doc-strings t))
(load load-file noerror t t))
-
(or nomessage
- (message "Loading %s...done." file)))
+ (message "Loading %s...done." file))
+ ;; Fix up the load history to point at the right library.
+ (let ((l (assoc 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))
(inhibit-file-name-operation operation))
(apply operation args)))
+;;;###autoload
+(defcustom auto-compression-mode nil
+ "Toggle automatic file compression and uncompression.
+Setting this variable directly does not take effect;
+use either \\[customize] or the function `auto-compression-mode'."
+ :set (lambda (symbol value)
+ (auto-compression-mode (or value 0)))
+ :initialize 'custom-initialize-default
+ :group 'jka-compr
+ :version "21.1"
+ :type 'boolean
+ :require 'jka-compr)
+
;;;###autoload(defun auto-compression-mode (&optional arg)
;;;###autoload "\
;;;###autoloadToggle automatic file compression and uncompression.
HCoop / bpt / emacs.git / blobdiff