;;; Copyright (C) 1993, 1994 Free Software Foundation, Inc.
;; Author: jka@ece.cmu.edu (Jay K. Adams)
-;; Version: 0.10
;; Keywords: data
;;; Commentary:
;;; I/O functions (including write-region and insert-file-contents) so
;;; that they automatically compress or uncompress a file if the file
;;; appears to need it (based on the extension of the file name).
-;;; Packages like Rmail, Vm, Gnus, and Info should be able to work
+;;; Packages like Rmail, VM, GNUS, and Info should be able to work
;;; with compressed files without modification.
"*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).")
+for `jka-compr-compression-info-list').")
(defvar jka-compr-use-shell t)
;;; compress format; and .gz files, in gzip format.
(defvar jka-compr-compression-info-list
;;[regexp
- ;; compr-message compr-prog compr-discard compr-args
- ;; uncomp-message uncomp-prog uncomp-discard uncomp-args
+ ;; compr-message compr-prog compr-args
+ ;; uncomp-message uncomp-prog uncomp-args
;; can-append auto-mode-flag]
- '(["\\.Z~?\\'"
+ '(["\\.Z\\(~\\|\\.~[0-9]+~\\)?\\'"
"compressing" "compress" ("-c")
"uncompressing" "uncompress" ("-c")
nil t]
- ["\\.gz~?\\'"
+ ["\\.gz\\(~\\|\\.~[0-9]+~\\)?\\'"
"zipping" "gzip" ("-c" "-q")
"unzipping" "gzip" ("-c" "-q" "-d")
t t])
"List of vectors that describe available compression techniques.
Each element, which describes a compression technique, is a vector of
-the form [regexp magic compress-name compress-program compress-discard-err
-compress-args uncompress-name uncompress-program uncompress-discard-err
-uncompress-args append-flag extension] where:
+the form [REGEXP COMPRESS-MSG COMPRESS-PROGRAM COMPRESS-ARGS
+UNCOMPRESS-MSG UNCOMPRESS-PROGRAM UNCOMPRESS-ARGS
+APPEND-FLAG EXTENSION], 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-message is the message to issue to the user when this
- type of uncompression is taking place (nil
- means don't issue any message)
+ 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
auto-mode flag non-nil means strip the regexp from file names
before attempting to set the mode.
-Because of the way call-process is defined, discarding the stderr output of
+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.")
+\f
;;; Functions for accessing the return value of jka-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-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."
+based on the filename itself and `jka-compr-compression-info-list'."
(catch 'compression-info
(let ((case-fold-search nil))
(mapcar
"/bin/dd")
-(defvar jka-compr-dd-blocksize 512)
+(defvar jka-compr-dd-blocksize 256)
(defun jka-compr-partial-uncompress (prog message args infile beg len)
"Call program PROG with ARGS args taking input from INFILE.
Fourth and fifth args, BEG and LEN, specify which part of the output
-to discard. All output is discarded unless it comes within LEN chars after
-the BEGth char."
-
+to keep: LEN chars starting BEG chars from the beginning."
(let* ((skip (/ beg jka-compr-dd-blocksize))
(prefix (- beg (* skip jka-compr-dd-blocksize)))
(count (and len (1+ (/ (+ len prefix) jka-compr-dd-blocksize))))
(start (point))
- (end (and count (+ start (* count jka-compr-dd-blocksize))))
(err-file (jka-compr-make-temp-name))
(run-string (format "%s %s 2> %s | %s bs=%d skip=%d %s 2> /dev/null"
prog
jka-compr-dd-program
jka-compr-dd-blocksize
skip
- (if count (concat "count=" count) ""))))
+ ;; dd seems to be unreliable about
+ ;; providing the last block. So, always
+ ;; read one more than you think you need.
+ (if count (concat "count=" (1+ count)) ""))))
(unwind-protect
(or (memq (call-process jka-compr-shell
(jka-compr-delete-temp-file err-file))
+ ;; Delete the stuff after what we want, if there is any.
(and
- end
- (delete-region (+ start prefix len) end))
+ len
+ (< (+ start prefix len) (point))
+ (delete-region (+ start prefix len) (point)))
+ ;; Delete the stuff before what we want.
(delete-region start (+ start prefix))))
(defvar jka-compr-temp-name-template
"/tmp/jka-com"
"Prefix added to all temp files created by jka-compr.
-There should be no more than seven characters after the final '/'")
+There should be no more than seven characters after the final `/'")
(defvar jka-compr-temp-name-table (make-vector 31 nil))
(defun jka-compr-write-region (start end file &optional append visit)
- "Documented as original."
- (interactive "r\nFWrite region to file: ")
-
(let* ((filename (expand-file-name file))
(visit-file (if (stringp visit) (expand-file-name visit) filename))
(info (jka-compr-get-compression-info visit-file)))
compress-message
(message "%s %s..." compress-message base-name))
- (write-region start end temp-file t 'dont)
+ (jka-compr-run-real-handler 'write-region
+ (list start end temp-file t 'dont))
(jka-compr-call-process compress-program
(concat compress-message
compress-args)
(set-buffer temp-buffer)
- (write-region (point-min) (point-max)
- filename (and append can-append) 'dont)
+ (jka-compr-run-real-handler 'write-region
+ (list (point-min) (point-max)
+ filename
+ (and append can-append) 'dont))
(erase-buffer)
(set-buffer cbuf)
nil)
- (write-region 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)
- "Documented as original."
+(defun jka-compr-insert-file-contents (file &optional visit beg end replace)
(barf-if-buffer-read-only)
(and (or beg end)
(uncompress-args (jka-compr-info-uncompress-args info))
(base-name (file-name-nondirectory filename))
(notfound nil)
- (local-copy (file-local-copy filename))
+ (local-copy
+ (jka-compr-run-real-handler 'file-local-copy (list filename)))
local-file
size start)
(condition-case error-code
(progn
+ (if replace
+ (goto-char (point-min)))
(setq start (point))
(if (or beg end)
(jka-compr-partial-uncompress uncompress-program
nil
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)))))
(goto-char start))
-
-
(error
(if (and (eq (car error-code) 'file-error)
(eq (nth 3 error-code) local-file))
(and
visit
(progn
+ (unlock-buffer)
(setq buffer-file-name filename)
(set-visited-file-modtime)))
(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))))
+
(list filename size))
- (insert-file-contents file visit beg end))))
+ (jka-compr-run-real-handler 'insert-file-contents
+ (list file visit beg end replace)))))
(defun jka-compr-file-local-copy (file)
- "Documented as original."
-
(let* ((filename (expand-file-name file))
(info (jka-compr-get-compression-info filename)))
(uncompress-program (jka-compr-info-uncompress-program info))
(uncompress-args (jka-compr-info-uncompress-args info))
(base-name (file-name-nondirectory filename))
- (local-copy (file-local-copy filename))
+ (local-copy
+ (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-temp*"))
(notfound nil)
temp-file)
- (file-local-copy filename))))
+ (jka-compr-run-real-handler 'file-local-copy (list filename)))))
;;; Support for loading compressed files.
(unwind-protect
- (progn
-
- (setq file-name-handler-alist
- (cons jka-compr-file-name-handler-entry
- file-name-handler-alist))
-
+ (let (inhibit-file-name-operation
+ inhibit-file-name-handlers)
(or nomessage
(message "Loading %s..." file))
(or nomessage
(message "Loading %s...done." file)))
- (setq file-name-handler-alist
- (delq jka-compr-file-name-handler-entry
- file-name-handler-alist))
-
(jka-compr-delete-temp-file local-copy))
t))
-
-
-(defvar jka-compr-file-name-handler-entry
- nil
- "The entry in file-name-handler-alist used by the jka-compr I/O functions.")
-
+\f
+(put 'write-region 'jka-compr 'jka-compr-write-region)
+(put 'insert-file-contents 'jka-compr 'jka-compr-insert-file-contents)
+(put 'file-local-copy 'jka-compr 'jka-compr-file-local-copy)
+(put 'load 'jka-compr 'jka-compr-load)
(defun jka-compr-handler (operation &rest args)
-
- (let ((jka-op (intern-soft (symbol-name operation) jka-compr-op-table)))
-
- (unwind-protect
- (progn
- (setq file-name-handler-alist
- (delq jka-compr-file-name-handler-entry
- file-name-handler-alist))
- (if jka-op
- (apply jka-op args)
- (apply operation args)))
-
- (setq file-name-handler-alist
- (cons jka-compr-file-name-handler-entry
- file-name-handler-alist)))))
-
-
-(defvar jka-compr-op-table
- (make-vector 127 0)
- "Hash table of operations supported by jka-compr")
-
-
-(defun jka-compr-intern-operation (op)
- (let ((opsym (intern (symbol-name op) jka-compr-op-table))
- (jka-fn (intern (concat "jka-compr-" (symbol-name op)))))
- (fset opsym jka-fn)))
-
-
-(defvar jka-compr-operation-list
- '(
- write-region
- insert-file-contents
- file-local-copy
- load
- )
- "List of file operations implemented by jka-compr.")
-
-
-(mapcar
- (function
- (lambda (fn)
- (jka-compr-intern-operation fn)))
- jka-compr-operation-list)
-
+ (save-match-data
+ (let ((jka-op (get operation 'jka-compr)))
+ (if jka-op
+ (apply jka-op args)
+ (jka-compr-run-real-handler operation args)))))
+
+;; If we are given an operation that we don't handle,
+;; call the Emacs primitive for that operation,
+;; and manipulate the inhibit variables
+;; to prevent the primitive from calling our handler again.
+(defun jka-compr-run-real-handler (operation args)
+ (let ((inhibit-file-name-handlers
+ (cons 'jka-compr-handler
+ (and (eq inhibit-file-name-operation operation)
+ inhibit-file-name-handlers)))
+ (inhibit-file-name-operation operation))
+ (apply operation args)))
(defun toggle-auto-compression (arg)
"Toggle automatic file compression and decompression.
(defun jka-compr-install ()
"Install jka-compr.
-Appropriate entries are added to file-name-handler-alist and auto-mode-alist."
+This adds entries to `file-name-handler-alist' and `auto-mode-alist'."
(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))
+ ;; Make entries in auto-mode-alist so that modes are chosen right
+ ;; according to the file names sans `.gz'.
(mapcar
(function (lambda (x)
(and
(defun jka-compr-uninstall ()
"Uninstall jka-compr.
-Entries in file-name-handler-alist and auto-mode-alist that were created by
-jka-compr-installed are removed."
+This removes the entries in `file-name-handler-alist' and `auto-mode-alist'
+that were created by `jka-compr-installed'."
(let* ((fnha (cons nil file-name-handler-alist))
(last fnha))
(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."
+The return value is the entry in `file-name-handler-alist' for jka-compr."
(let ((fnha file-name-handler-alist)
(installed nil))
HCoop / bpt / emacs.git / blobdiff