(require 'jka-cmpr-hook)
(defcustom jka-compr-shell "sh"
"*Shell to be used for calling compression programs.
NOTE: Not used in MS-DOS and Windows systems."
:type 'string
:group 'jka-compr)
(defvar jka-compr-use-shell
(not (memq system-type '(ms-dos windows-nt))))
(defvar jka-compr-really-do-compress nil
"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)
(put 'compression-error 'error-conditions '(compression-error file-error error))
(defvar jka-compr-acceptable-retval-list '(0 2 141))
(defun jka-compr-error (prog args infile message &optional errfile)
(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"
prog
(mapconcat 'identity args " ")
infile))
(and errfile
(insert-file-contents errfile)))
(display-buffer errbuf))
(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
:group 'jka-compr)
(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 keep: LEN chars starting BEG chars from the beginning."
(let ((start (point))
(prefix beg))
(if (and jka-compr-use-shell jka-compr-dd-program)
(let ((skip (/ beg jka-compr-dd-blocksize))
(err-file (jka-compr-make-temp-name))
(default-directory
(if (and default-directory
(file-accessible-directory-p default-directory))
default-directory
(file-name-directory infile)))
count)
(setq prefix (- beg (* skip jka-compr-dd-blocksize))
count (and len (1+ (/ (+ len prefix) jka-compr-dd-blocksize))))
(unwind-protect
(or (memq (call-process
jka-compr-shell infile t nil "-c"
(format
"%s %s 2> %s | %s bs=%d skip=%d %s 2> %s"
prog
(mapconcat 'identity args " ")
err-file
jka-compr-dd-program
jka-compr-dd-blocksize
skip
(if count (format "count=%d" (1+ count)) "")
null-device))
jka-compr-acceptable-retval-list)
(jka-compr-error prog args infile message err-file))
(jka-compr-delete-temp-file err-file)))
(jka-compr-call-process prog message infile t nil args))
(and
len
(< (+ start prefix len) (point))
(delete-region (+ start prefix len) (point)))
(delete-region start (+ start prefix))))
(defun jka-compr-call-process (prog message infile output temp args)
(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))))))
(defcustom jka-compr-temp-name-template
(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)
(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 (null start)
(setq start 1 end (1+ (buffer-size))))
(if (and jka-compr-really-do-compress
(eq start 1)
(eq end (1+ (buffer-size))))
(setq magic nil))
(if (and info
(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))
(compress-args (jka-compr-info-compress-args info))
(base-name (file-name-nondirectory visit-file))
temp-file temp-buffer
(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))
(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))
(setq coding-system-used last-coding-system-used)
(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)
(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))
(setq last-coding-system-used coding-system-used)
nil)
(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)
(barf-if-buffer-read-only)
(and (or beg end)
visit
(error "Attempt to visit less than an entire file"))
(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
(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))
(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 (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 (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))))
(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)))))
(defun jka-compr-file-local-copy (file)
(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))
(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-flc-temp*"))
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))
(let ((coding-system-for-read 'no-conversion)
(coding-system-for-write 'no-conversion))
(jka-compr-call-process uncompress-program
(concat uncompress-message
" " base-name)
local-file
t
nil
uncompress-args)
(and
uncompress-message
(message "%s %s...done" uncompress-message base-name))
(write-region
(point-min) (point-max) temp-file nil 'dont)))
(and
local-copy
(file-exists-p local-copy)
(delete-file local-copy))
(kill-buffer temp-buffer))
temp-file)
(jka-compr-run-real-handler 'file-local-copy (list filename)))))
(defun jka-compr-load (file &optional noerror nomessage nosuffix)
"Documented as original."
(let* ((local-copy (jka-compr-file-local-copy file))
(load-file (or local-copy file)))
(unwind-protect
(let (inhibit-file-name-operation
inhibit-file-name-handlers)
(or nomessage
(message "Loading %s..." file))
(let ((load-force-doc-strings t))
(load load-file noerror t t))
(or nomessage
(message "Loading %s...done." file))
(let ((l (assoc load-file load-history)))
(while (file-name-extension file)
(setq file (file-name-sans-extension file)))
(setcar l file)))
(jka-compr-delete-temp-file local-copy))
t))
(defun jka-compr-byte-compiler-base-file-name (file)
(let ((info (jka-compr-get-compression-info file)))
(if (and info (jka-compr-info-strip-extension info))
(save-match-data
(substring file 0 (string-match (jka-compr-info-regexp info) file)))
file)))
(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)
(put 'byte-compiler-base-file-name 'jka-compr
'jka-compr-byte-compiler-base-file-name)
(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.")
(defun jka-compr-handler (operation &rest args)
(save-match-data
(let ((jka-op (get operation 'jka-compr)))
(if (and jka-op (not jka-compr-inhibit))
(apply jka-op args)
(jka-compr-run-real-handler operation args)))))
(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 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
by `jka-compr-installed'."
(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--internal)
(let* ((fnha (cons nil file-name-handler-alist))
(last fnha))
(while (cdr last)
(if (eq (cdr (car (cdr last))) 'jka-compr-handler)
(setcdr last (cdr (cdr last)))
(setq last (cdr last))))
(setq file-name-handler-alist (cdr fnha)))
(let* ((ama (cons nil auto-mode-alist))
(last ama)
entry)
(while (cdr last)
(setq entry (car (cdr last)))
(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 last (cdr last))))
(setq auto-mode-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)))
(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)