|
2
|
1 ;;; jka-compr.el --- reading/writing/loading compressed files
|
|
|
2
|
|
|
3 ;; Copyright (C) 1993, 1994 Free Software Foundation, Inc.
|
|
0
|
4
|
|
|
5 ;; Author: jka@ece.cmu.edu (Jay K. Adams)
|
|
|
6 ;; Keywords: data
|
|
|
7
|
|
2
|
8 ;; This file is part of XEmacs.
|
|
|
9
|
|
|
10 ;; XEmacs is free software; you can redistribute it and/or modify it
|
|
|
11 ;; under the terms of the GNU General Public License as published by
|
|
|
12 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
13 ;; any later version.
|
|
|
14
|
|
|
15 ;; XEmacs is distributed in the hope that it will be useful, but
|
|
|
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
|
18 ;; General Public License for more details.
|
|
|
19
|
|
|
20 ;; You should have received a copy of the GNU General Public License
|
|
|
21 ;; along with XEmacs; see the file COPYING. If not, write to the Free
|
|
|
22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
|
|
23 ;; 02111-1307, USA.
|
|
|
24
|
|
|
25 ;; Synched up with: FSF 19.34
|
|
0
|
26
|
|
|
27 ;;; Commentary:
|
|
|
28
|
|
2
|
29 ;; This package implements low-level support for reading, writing,
|
|
|
30 ;; and loading compressed files. It hooks into the low-level file
|
|
|
31 ;; I/O functions (including write-region and insert-file-contents) so
|
|
|
32 ;; that they automatically compress or uncompress a file if the file
|
|
|
33 ;; appears to need it (based on the extension of the file name).
|
|
|
34 ;; Packages like Rmail, VM, GNUS, and Info should be able to work
|
|
|
35 ;; with compressed files without modification.
|
|
0
|
36
|
|
|
37
|
|
2
|
38 ;; INSTRUCTIONS:
|
|
|
39 ;;
|
|
|
40 ;; To use jka-compr, simply load this package, and edit as usual.
|
|
|
41 ;; Its operation should be transparent to the user (except for
|
|
|
42 ;; messages appearing when a file is being compressed or
|
|
|
43 ;; uncompressed).
|
|
|
44 ;;
|
|
|
45 ;; The variable, jka-compr-compression-info-list can be used to
|
|
|
46 ;; customize jka-compr to work with other compression programs.
|
|
|
47 ;; The default value of this variable allows jka-compr to work with
|
|
|
48 ;; Unix compress and gzip.
|
|
|
49 ;;
|
|
|
50 ;; If you are concerned about the stderr output of gzip and other
|
|
|
51 ;; compression/decompression programs showing up in your buffers, you
|
|
|
52 ;; should set the discard-error flag in the compression-info-list.
|
|
|
53 ;; This will cause the stderr of all programs to be discarded.
|
|
|
54 ;; However, it also causes emacs to call compression/uncompression
|
|
|
55 ;; programs through a shell (which is specified by jka-compr-shell).
|
|
|
56 ;; This may be a drag if, on your system, starting up a shell is
|
|
|
57 ;; slow.
|
|
|
58 ;;
|
|
|
59 ;; If you don't want messages about compressing and decompressing
|
|
|
60 ;; to show up in the echo area, you can set the compress-name and
|
|
|
61 ;; decompress-name fields of the jka-compr-compression-info-list to
|
|
|
62 ;; nil.
|
|
0
|
63
|
|
|
64
|
|
2
|
65 ;; APPLICATION NOTES:
|
|
|
66 ;;
|
|
|
67 ;; crypt++
|
|
86
|
68 ;; jka-compr can coexist with crypt++ if you take all the decompression
|
|
2
|
69 ;; entries out of the crypt-encoding-list. Clearly problems will arise if
|
|
|
70 ;; you have two programs trying to compress/decompress files. jka-compr
|
|
|
71 ;; will not "work with" crypt++ in the following sense: you won't be able to
|
|
|
72 ;; decode encrypted compressed files--that is, files that have been
|
|
|
73 ;; compressed then encrypted (in that order). Theoretically, crypt++ and
|
|
|
74 ;; jka-compr could properly handle a file that has been encrypted then
|
|
|
75 ;; compressed, but there is little point in trying to compress an encrypted
|
|
|
76 ;; file.
|
|
|
77 ;;
|
|
0
|
78
|
|
|
79
|
|
2
|
80 ;; ACKNOWLEDGMENTS
|
|
|
81 ;;
|
|
|
82 ;; jka-compr is a V19 adaptation of jka-compr for V18 of Emacs. Many people
|
|
|
83 ;; have made helpful suggestions, reported bugs, and even fixed bugs in
|
|
|
84 ;; jka-compr. I recall the following people as being particularly helpful.
|
|
|
85 ;;
|
|
|
86 ;; Jean-loup Gailly
|
|
|
87 ;; David Hughes
|
|
|
88 ;; Richard Pieri
|
|
|
89 ;; Daniel Quinlan
|
|
|
90 ;; Chris P. Ross
|
|
|
91 ;; Rick Sladkey
|
|
|
92 ;;
|
|
|
93 ;; Andy Norman's ange-ftp was the inspiration for the original jka-compr for
|
|
|
94 ;; Version 18 of Emacs.
|
|
|
95 ;;
|
|
|
96 ;; After I had made progress on the original jka-compr for V18, I learned of a
|
|
|
97 ;; package written by Kazushi Jam Marukawa, called jam-zcat, that did exactly
|
|
|
98 ;; what I was trying to do. I looked over the jam-zcat source code and
|
|
|
99 ;; probably got some ideas from it.
|
|
|
100 ;;
|
|
0
|
101
|
|
|
102 ;;; Code:
|
|
|
103
|
|
120
|
104 (defgroup compression nil
|
|
|
105 "Data compression utilities"
|
|
|
106 :group 'data)
|
|
|
107
|
|
189
|
108 (defgroup jka-compr nil
|
|
|
109 "jka-compr customization"
|
|
|
110 :group 'compression)
|
|
120
|
111
|
|
|
112
|
|
|
113 (defcustom jka-compr-shell "sh"
|
|
0
|
114 "*Shell to be used for calling compression programs.
|
|
|
115 The value of this variable only matters if you want to discard the
|
|
|
116 stderr of a compression/decompression program (see the documentation
|
|
120
|
117 for `jka-compr-compression-info-list')."
|
|
|
118 :type 'string
|
|
|
119 :group 'jka-compr)
|
|
0
|
120
|
|
|
121 (defvar jka-compr-use-shell t)
|
|
|
122
|
|
|
123
|
|
|
124 ;;; I have this defined so that .Z files are assumed to be in unix
|
|
|
125 ;;; compress format; and .gz files, in gzip format.
|
|
120
|
126 (defcustom jka-compr-compression-info-list
|
|
0
|
127 ;;[regexp
|
|
|
128 ;; compr-message compr-prog compr-args
|
|
|
129 ;; uncomp-message uncomp-prog uncomp-args
|
|
|
130 ;; can-append auto-mode-flag]
|
|
|
131 '(["\\.Z\\(~\\|\\.~[0-9]+~\\)?\\'"
|
|
|
132 "compressing" "compress" ("-c")
|
|
|
133 "uncompressing" "uncompress" ("-c")
|
|
|
134 nil t]
|
|
|
135 ["\\.tgz\\'"
|
|
|
136 "zipping" "gzip" ("-c" "-q")
|
|
|
137 "unzipping" "gzip" ("-c" "-q" "-d")
|
|
|
138 t nil]
|
|
|
139 ["\\.gz\\(~\\|\\.~[0-9]+~\\)?\\'"
|
|
|
140 "zipping" "gzip" ("-c" "-q")
|
|
|
141 "unzipping" "gzip" ("-c" "-q" "-d")
|
|
207
|
142 t t]
|
|
|
143 ["\\.bz2\\(~\\|\\.~[0-9]+~\\)?\\'"
|
|
|
144 "bzipping" "bzip2" ("-f")
|
|
|
145 "unbzipping" "bzip2" ("-d")
|
|
|
146 nil t])
|
|
0
|
147
|
|
|
148 "List of vectors that describe available compression techniques.
|
|
|
149 Each element, which describes a compression technique, is a vector of
|
|
|
150 the form [REGEXP COMPRESS-MSG COMPRESS-PROGRAM COMPRESS-ARGS
|
|
|
151 UNCOMPRESS-MSG UNCOMPRESS-PROGRAM UNCOMPRESS-ARGS
|
|
|
152 APPEND-FLAG EXTENSION], where:
|
|
|
153
|
|
|
154 regexp is a regexp that matches filenames that are
|
|
|
155 compressed with this format
|
|
|
156
|
|
|
157 compress-msg is the message to issue to the user when doing this
|
|
|
158 type of compression (nil means no message)
|
|
|
159
|
|
|
160 compress-program is a program that performs this compression
|
|
|
161
|
|
|
162 compress-args is a list of args to pass to the compress program
|
|
|
163
|
|
|
164 uncompress-msg is the message to issue to the user when doing this
|
|
|
165 type of uncompression (nil means no message)
|
|
|
166
|
|
|
167 uncompress-program is a program that performs this compression
|
|
|
168
|
|
|
169 uncompress-args is a list of args to pass to the uncompress program
|
|
|
170
|
|
207
|
171 append-flag is non-nil if files compressed with this technique can
|
|
|
172 be appended to without decompressing them first.
|
|
0
|
173
|
|
|
174 auto-mode flag non-nil means strip the regexp from file names
|
|
|
175 before attempting to set the mode.
|
|
|
176
|
|
|
177 Because of the way `call-process' is defined, discarding the stderr output of
|
|
|
178 a program adds the overhead of starting a shell each time the program is
|
|
120
|
179 invoked."
|
|
189
|
180 :type '(repeat (vector :tag "Compression Technique"
|
|
|
181 regexp
|
|
120
|
182 (choice :tag "Compress Message"
|
|
|
183 (string :format "%v")
|
|
|
184 (const :tag "No Message" nil))
|
|
|
185 (string :tag "Compress Program")
|
|
|
186 (repeat :tag "Compress Arguments" string)
|
|
|
187 (choice :tag "Uncompress Message"
|
|
|
188 (string :format "%v")
|
|
|
189 (const :tag "No Message" nil))
|
|
|
190 (string :tag "Uncompress Program")
|
|
|
191 (repeat :tag "Uncompress Arguments" string)
|
|
|
192 (boolean :tag "Append")
|
|
|
193 (boolean :tag "Auto Mode")))
|
|
|
194 :group 'jka-compr)
|
|
0
|
195
|
|
|
196 (defvar jka-compr-mode-alist-additions
|
|
|
197 (list (cons "\\.tgz\\'" 'tar-mode))
|
|
|
198 "A list of pairs to add to auto-mode-alist when jka-compr is installed.")
|
|
|
199
|
|
|
200 (defvar jka-compr-file-name-handler-entry
|
|
|
201 nil
|
|
|
202 "The entry in `file-name-handler-alist' used by the jka-compr I/O functions.")
|
|
|
203
|
|
2
|
204 ;;; Functions for accessing the return value of jka-compr-get-compression-info
|
|
0
|
205 (defun jka-compr-info-regexp (info) (aref info 0))
|
|
|
206 (defun jka-compr-info-compress-message (info) (aref info 1))
|
|
|
207 (defun jka-compr-info-compress-program (info) (aref info 2))
|
|
|
208 (defun jka-compr-info-compress-args (info) (aref info 3))
|
|
|
209 (defun jka-compr-info-uncompress-message (info) (aref info 4))
|
|
|
210 (defun jka-compr-info-uncompress-program (info) (aref info 5))
|
|
|
211 (defun jka-compr-info-uncompress-args (info) (aref info 6))
|
|
|
212 (defun jka-compr-info-can-append (info) (aref info 7))
|
|
|
213 (defun jka-compr-info-strip-extension (info) (aref info 8))
|
|
|
214
|
|
|
215
|
|
|
216 (defun jka-compr-get-compression-info (filename)
|
|
|
217 "Return information about the compression scheme of FILENAME.
|
|
|
218 The determination as to which compression scheme, if any, to use is
|
|
|
219 based on the filename itself and `jka-compr-compression-info-list'."
|
|
|
220 (catch 'compression-info
|
|
|
221 (let ((case-fold-search nil))
|
|
|
222 (mapcar
|
|
|
223 (function (lambda (x)
|
|
|
224 (and (string-match (jka-compr-info-regexp x) filename)
|
|
|
225 (throw 'compression-info x))))
|
|
|
226 jka-compr-compression-info-list)
|
|
|
227 nil)))
|
|
|
228
|
|
|
229
|
|
|
230 ;; XEmacs change
|
|
|
231 (define-error 'compression-error "Compression error" 'file-error)
|
|
|
232
|
|
|
233 (defvar jka-compr-acceptable-retval-list '(0 2 141))
|
|
|
234
|
|
|
235
|
|
|
236 (defun jka-compr-error (prog args infile message &optional errfile)
|
|
|
237 (let ((errbuf (get-buffer-create " *jka-compr-error*"))
|
|
|
238 (curbuf (current-buffer)))
|
|
|
239 (set-buffer errbuf)
|
|
|
240 (widen) (erase-buffer)
|
|
|
241 (insert (format "Error while executing \"%s %s < %s\"\n\n"
|
|
|
242 prog
|
|
|
243 (mapconcat 'identity args " ")
|
|
|
244 infile))
|
|
|
245
|
|
|
246 (and errfile
|
|
|
247 (insert-file-contents errfile))
|
|
|
248
|
|
|
249 (set-buffer curbuf)
|
|
|
250 (display-buffer errbuf))
|
|
189
|
251 (signal 'compression-error (list "Opening input file"
|
|
|
252 (format "error %s" message)
|
|
|
253 infile)))
|
|
0
|
254
|
|
189
|
255
|
|
0
|
256 (defvar jka-compr-dd-program
|
|
|
257 "/bin/dd")
|
|
|
258
|
|
|
259
|
|
|
260 (defvar jka-compr-dd-blocksize 256)
|
|
|
261
|
|
|
262
|
|
|
263 (defun jka-compr-partial-uncompress (prog message args infile beg len)
|
|
|
264 "Call program PROG with ARGS args taking input from INFILE.
|
|
|
265 Fourth and fifth args, BEG and LEN, specify which part of the output
|
|
|
266 to keep: LEN chars starting BEG chars from the beginning."
|
|
|
267 (let* ((skip (/ beg jka-compr-dd-blocksize))
|
|
|
268 (prefix (- beg (* skip jka-compr-dd-blocksize)))
|
|
|
269 (count (and len (1+ (/ (+ len prefix) jka-compr-dd-blocksize))))
|
|
|
270 (start (point))
|
|
|
271 (err-file (jka-compr-make-temp-name))
|
|
|
272 (run-string (format "%s %s 2> %s | %s bs=%d skip=%d %s 2> /dev/null"
|
|
|
273 prog
|
|
|
274 (mapconcat 'identity args " ")
|
|
|
275 err-file
|
|
|
276 jka-compr-dd-program
|
|
|
277 jka-compr-dd-blocksize
|
|
|
278 skip
|
|
|
279 ;; dd seems to be unreliable about
|
|
|
280 ;; providing the last block. So, always
|
|
|
281 ;; read one more than you think you need.
|
|
|
282 (if count (concat "count=" (1+ count)) ""))))
|
|
|
283
|
|
|
284 (unwind-protect
|
|
|
285 (or (memq (call-process jka-compr-shell
|
|
|
286 infile t nil "-c"
|
|
|
287 run-string)
|
|
|
288 jka-compr-acceptable-retval-list)
|
|
|
289
|
|
|
290 (jka-compr-error prog args infile message err-file))
|
|
|
291
|
|
|
292 (jka-compr-delete-temp-file err-file))
|
|
|
293
|
|
|
294 ;; Delete the stuff after what we want, if there is any.
|
|
|
295 (and
|
|
|
296 len
|
|
|
297 (< (+ start prefix len) (point))
|
|
|
298 (delete-region (+ start prefix len) (point)))
|
|
|
299
|
|
|
300 ;; Delete the stuff before what we want.
|
|
|
301 (delete-region start (+ start prefix))))
|
|
|
302
|
|
|
303
|
|
|
304 (defun jka-compr-call-process (prog message infile output temp args)
|
|
|
305 (if jka-compr-use-shell
|
|
|
306
|
|
|
307 (let ((err-file (jka-compr-make-temp-name)))
|
|
|
308
|
|
|
309 (unwind-protect
|
|
|
310
|
|
|
311 (or (memq
|
|
|
312 (call-process jka-compr-shell infile
|
|
|
313 (if (stringp output) nil output)
|
|
|
314 nil
|
|
|
315 "-c"
|
|
|
316 (format "%s %s 2> %s %s"
|
|
|
317 prog
|
|
|
318 (mapconcat 'identity args " ")
|
|
|
319 err-file
|
|
|
320 (if (stringp output)
|
|
|
321 (concat "> " output)
|
|
|
322 "")))
|
|
|
323 jka-compr-acceptable-retval-list)
|
|
|
324
|
|
|
325 (jka-compr-error prog args infile message err-file))
|
|
|
326
|
|
|
327 (jka-compr-delete-temp-file err-file)))
|
|
|
328
|
|
|
329 (or (zerop
|
|
|
330 (apply 'call-process
|
|
|
331 prog
|
|
|
332 infile
|
|
|
333 (if (stringp output) temp output)
|
|
|
334 nil
|
|
|
335 args))
|
|
|
336 (jka-compr-error prog args infile message))
|
|
|
337
|
|
|
338 (and (stringp output)
|
|
|
339 (let ((cbuf (current-buffer)))
|
|
|
340 (set-buffer temp)
|
|
|
341 (write-region (point-min) (point-max) output)
|
|
|
342 (erase-buffer)
|
|
|
343 (set-buffer cbuf)))))
|
|
|
344
|
|
|
345
|
|
|
346 ;;; Support for temp files. Much of this was inspired if not lifted
|
|
|
347 ;;; from ange-ftp.
|
|
|
348
|
|
120
|
349 (defcustom jka-compr-temp-name-template
|
|
0
|
350 "/tmp/jka-com"
|
|
|
351 "Prefix added to all temp files created by jka-compr.
|
|
120
|
352 There should be no more than seven characters after the final `/'"
|
|
|
353 :type 'string
|
|
|
354 :group 'jka-compr)
|
|
0
|
355
|
|
|
356 (defvar jka-compr-temp-name-table (make-vector 31 nil))
|
|
|
357
|
|
|
358 (defun jka-compr-make-temp-name (&optional local-copy)
|
|
|
359 "This routine will return the name of a new file."
|
|
|
360 (let* ((lastchar ?a)
|
|
|
361 (prevchar ?a)
|
|
|
362 (template (concat jka-compr-temp-name-template "aa"))
|
|
|
363 (lastpos (1- (length template)))
|
|
|
364 (not-done t)
|
|
|
365 file
|
|
|
366 entry)
|
|
|
367
|
|
|
368 (while not-done
|
|
|
369 (aset template lastpos lastchar)
|
|
|
370 (setq file (concat (make-temp-name template) "#"))
|
|
|
371 (setq entry (intern file jka-compr-temp-name-table))
|
|
|
372 (if (or (get entry 'active)
|
|
|
373 (file-exists-p file))
|
|
|
374
|
|
|
375 (progn
|
|
|
376 (setq lastchar (1+ lastchar))
|
|
|
377 (if (> lastchar ?z)
|
|
|
378 (progn
|
|
|
379 (setq prevchar (1+ prevchar))
|
|
|
380 (setq lastchar ?a)
|
|
|
381 (if (> prevchar ?z)
|
|
|
382 (error "Can't allocate temp file.")
|
|
|
383 (aset template (1- lastpos) prevchar)))))
|
|
|
384
|
|
|
385 (put entry 'active (not local-copy))
|
|
|
386 (setq not-done nil)))
|
|
|
387
|
|
|
388 file))
|
|
|
389
|
|
|
390
|
|
|
391 (defun jka-compr-delete-temp-file (temp)
|
|
|
392
|
|
|
393 (put (intern temp jka-compr-temp-name-table)
|
|
|
394 'active nil)
|
|
|
395
|
|
|
396 (condition-case ()
|
|
|
397 (delete-file temp)
|
|
|
398 (error nil)))
|
|
|
399
|
|
86
|
400 ;;; 20.0-b92 change
|
|
|
401 ;;; Now receives both `lockname' and `codesys' from Fwrite_region_internal
|
|
|
402 ;;; what makes it compatible with write-region
|
|
|
403 (defun jka-compr-write-region (start end file &optional append visit lockname coding-system)
|
|
0
|
404 (let* ((filename (expand-file-name file))
|
|
|
405 (visit-file (if (stringp visit) (expand-file-name visit) filename))
|
|
|
406 (info (jka-compr-get-compression-info visit-file)))
|
|
|
407
|
|
|
408 (if info
|
|
|
409
|
|
|
410 (let ((can-append (jka-compr-info-can-append info))
|
|
|
411 (compress-program (jka-compr-info-compress-program info))
|
|
|
412 (compress-message (jka-compr-info-compress-message info))
|
|
|
413 (uncompress-program (jka-compr-info-uncompress-program info))
|
|
|
414 (uncompress-message (jka-compr-info-uncompress-message info))
|
|
|
415 (compress-args (jka-compr-info-compress-args info))
|
|
|
416 (uncompress-args (jka-compr-info-uncompress-args info))
|
|
|
417 (base-name (file-name-nondirectory visit-file))
|
|
|
418 temp-file cbuf temp-buffer)
|
|
|
419
|
|
|
420 (setq cbuf (current-buffer)
|
|
|
421 temp-buffer (get-buffer-create " *jka-compr-wr-temp*"))
|
|
|
422 (set-buffer temp-buffer)
|
|
|
423 (widen) (erase-buffer)
|
|
|
424 (set-buffer cbuf)
|
|
|
425
|
|
|
426 (if (and append
|
|
|
427 (not can-append)
|
|
|
428 (file-exists-p filename))
|
|
|
429
|
|
|
430 (let* ((local-copy (file-local-copy filename))
|
|
|
431 (local-file (or local-copy filename)))
|
|
|
432
|
|
|
433 (setq temp-file local-file))
|
|
|
434
|
|
|
435 (setq temp-file (jka-compr-make-temp-name)))
|
|
|
436
|
|
|
437 (and
|
|
|
438 compress-message
|
|
|
439 (message "%s %s..." compress-message base-name))
|
|
|
440
|
|
|
441 (jka-compr-run-real-handler 'write-region
|
|
86
|
442 (list start end temp-file t 'dont lockname coding-system))
|
|
0
|
443
|
|
|
444 (jka-compr-call-process compress-program
|
|
|
445 (concat compress-message
|
|
|
446 " " base-name)
|
|
|
447 temp-file
|
|
|
448 temp-buffer
|
|
|
449 nil
|
|
|
450 compress-args)
|
|
|
451
|
|
|
452 (set-buffer temp-buffer)
|
|
|
453 (jka-compr-run-real-handler 'write-region
|
|
|
454 (list (point-min) (point-max)
|
|
|
455 filename
|
|
155
|
456 (and append can-append)
|
|
|
457 'dont lockname 'binary))
|
|
0
|
458 (erase-buffer)
|
|
|
459 (set-buffer cbuf)
|
|
|
460
|
|
|
461 (jka-compr-delete-temp-file temp-file)
|
|
|
462
|
|
|
463 (and
|
|
|
464 compress-message
|
|
|
465 (message "%s %s...done" compress-message base-name))
|
|
|
466
|
|
|
467 (cond
|
|
|
468 ((eq visit t)
|
|
|
469 (setq buffer-file-name filename)
|
|
|
470 (set-visited-file-modtime))
|
|
|
471 ((stringp visit)
|
|
|
472 (setq buffer-file-name visit)
|
|
|
473 (let ((buffer-file-name filename))
|
|
|
474 (set-visited-file-modtime))))
|
|
|
475
|
|
|
476 (and (or (eq visit t)
|
|
|
477 (eq visit nil)
|
|
|
478 (stringp visit))
|
|
|
479 (message "Wrote %s" visit-file))
|
|
|
480
|
|
|
481 nil)
|
|
|
482
|
|
|
483 (jka-compr-run-real-handler 'write-region
|
|
86
|
484 (list start end filename append visit lockname coding-system)))))
|
|
0
|
485
|
|
|
486
|
|
|
487 (defun jka-compr-insert-file-contents (file &optional visit beg end replace)
|
|
|
488 (barf-if-buffer-read-only)
|
|
|
489
|
|
|
490 (and (or beg end)
|
|
|
491 visit
|
|
|
492 (error "Attempt to visit less than an entire file"))
|
|
|
493
|
|
|
494 (let* ((filename (expand-file-name file))
|
|
|
495 (info (jka-compr-get-compression-info filename)))
|
|
|
496
|
|
|
497 (if info
|
|
|
498
|
|
|
499 (let ((uncompress-message (jka-compr-info-uncompress-message info))
|
|
|
500 (uncompress-program (jka-compr-info-uncompress-program info))
|
|
|
501 (uncompress-args (jka-compr-info-uncompress-args info))
|
|
|
502 (base-name (file-name-nondirectory filename))
|
|
|
503 (notfound nil)
|
|
|
504 (local-copy
|
|
|
505 (jka-compr-run-real-handler 'file-local-copy (list filename)))
|
|
|
506 local-file
|
|
|
507 size start)
|
|
|
508
|
|
|
509 (setq local-file (or local-copy filename))
|
|
|
510
|
|
|
511 (and
|
|
|
512 visit
|
|
|
513 (setq buffer-file-name filename))
|
|
|
514
|
|
|
515 (unwind-protect ; to make sure local-copy gets deleted
|
|
|
516
|
|
|
517 (progn
|
|
|
518
|
|
|
519 (and
|
|
|
520 uncompress-message
|
|
|
521 (message "%s %s..." uncompress-message base-name))
|
|
|
522
|
|
|
523 (condition-case error-code
|
|
|
524
|
|
|
525 (progn
|
|
|
526 (if replace
|
|
|
527 (goto-char (point-min)))
|
|
|
528 (setq start (point))
|
|
|
529 (if (or beg end)
|
|
|
530 (jka-compr-partial-uncompress uncompress-program
|
|
|
531 (concat uncompress-message
|
|
|
532 " " base-name)
|
|
|
533 uncompress-args
|
|
|
534 local-file
|
|
|
535 (or beg 0)
|
|
|
536 (if (and beg end)
|
|
|
537 (- end beg)
|
|
|
538 end))
|
|
2
|
539 ;; If visiting, bind off buffer-file-name so that
|
|
|
540 ;; file-locking will not ask whether we should
|
|
|
541 ;; really edit the buffer.
|
|
|
542 (let ((buffer-file-name
|
|
|
543 (if visit nil buffer-file-name)))
|
|
|
544 (jka-compr-call-process uncompress-program
|
|
|
545 (concat uncompress-message
|
|
|
546 " " base-name)
|
|
|
547 local-file
|
|
|
548 t
|
|
|
549 nil
|
|
|
550 uncompress-args)))
|
|
0
|
551 (setq size (- (point) start))
|
|
|
552 (if replace
|
|
|
553 (let* ((del-beg (point))
|
|
|
554 (del-end (+ del-beg size)))
|
|
|
555 (delete-region del-beg
|
|
|
556 (min del-end (point-max)))))
|
|
|
557 (goto-char start))
|
|
|
558 (error
|
|
|
559 (if (and (eq (car error-code) 'file-error)
|
|
|
560 (eq (nth 3 error-code) local-file))
|
|
|
561 (if visit
|
|
|
562 (setq notfound error-code)
|
|
|
563 (signal 'file-error
|
|
|
564 (cons "Opening input file"
|
|
|
565 (nthcdr 2 error-code))))
|
|
|
566 (signal (car error-code) (cdr error-code))))))
|
|
|
567
|
|
|
568 (and
|
|
|
569 local-copy
|
|
|
570 (file-exists-p local-copy)
|
|
|
571 (delete-file local-copy)))
|
|
|
572
|
|
|
573 (and
|
|
|
574 visit
|
|
|
575 (progn
|
|
|
576 (unlock-buffer)
|
|
|
577 (setq buffer-file-name filename)
|
|
|
578 (set-visited-file-modtime)))
|
|
|
579
|
|
|
580 (and
|
|
|
581 uncompress-message
|
|
|
582 (message "%s %s...done" uncompress-message base-name))
|
|
|
583
|
|
|
584 (and
|
|
|
585 visit
|
|
|
586 notfound
|
|
|
587 (signal 'file-error
|
|
|
588 (cons "Opening input file" (nth 2 notfound))))
|
|
|
589
|
|
|
590 ;; Run the functions that insert-file-contents would.
|
|
|
591 (let ((p after-insert-file-functions)
|
|
|
592 (insval size))
|
|
|
593 (while p
|
|
|
594 (setq insval (funcall (car p) size))
|
|
|
595 (if insval
|
|
|
596 (progn
|
|
|
597 (or (integerp insval)
|
|
|
598 (signal 'wrong-type-argument
|
|
|
599 (list 'integerp insval)))
|
|
|
600 (setq size insval)))
|
|
|
601 (setq p (cdr p))))
|
|
|
602
|
|
|
603 (list filename size))
|
|
|
604
|
|
|
605 (jka-compr-run-real-handler 'insert-file-contents
|
|
|
606 (list file visit beg end replace)))))
|
|
|
607
|
|
|
608
|
|
|
609 (defun jka-compr-file-local-copy (file)
|
|
|
610 (let* ((filename (expand-file-name file))
|
|
|
611 (info (jka-compr-get-compression-info filename)))
|
|
|
612
|
|
|
613 (if info
|
|
|
614
|
|
|
615 (let ((uncompress-message (jka-compr-info-uncompress-message info))
|
|
|
616 (uncompress-program (jka-compr-info-uncompress-program info))
|
|
|
617 (uncompress-args (jka-compr-info-uncompress-args info))
|
|
|
618 (base-name (file-name-nondirectory filename))
|
|
|
619 (local-copy
|
|
|
620 (jka-compr-run-real-handler 'file-local-copy (list filename)))
|
|
|
621 (temp-file (jka-compr-make-temp-name t))
|
|
|
622 (temp-buffer (get-buffer-create " *jka-compr-flc-temp*"))
|
|
|
623 (notfound nil)
|
|
|
624 (cbuf (current-buffer))
|
|
|
625 local-file)
|
|
|
626
|
|
|
627 (setq local-file (or local-copy filename))
|
|
|
628
|
|
|
629 (unwind-protect
|
|
|
630
|
|
|
631 (progn
|
|
|
632
|
|
|
633 (and
|
|
|
634 uncompress-message
|
|
|
635 (message "%s %s..." uncompress-message base-name))
|
|
|
636
|
|
|
637 (set-buffer temp-buffer)
|
|
|
638
|
|
|
639 (jka-compr-call-process uncompress-program
|
|
|
640 (concat uncompress-message
|
|
|
641 " " base-name)
|
|
|
642 local-file
|
|
|
643 t
|
|
|
644 nil
|
|
|
645 uncompress-args)
|
|
|
646
|
|
|
647 (and
|
|
|
648 uncompress-message
|
|
|
649 (message "%s %s...done" uncompress-message base-name))
|
|
|
650
|
|
|
651 (write-region
|
|
|
652 (point-min) (point-max) temp-file nil 'dont))
|
|
|
653
|
|
|
654 (and
|
|
|
655 local-copy
|
|
|
656 (file-exists-p local-copy)
|
|
|
657 (delete-file local-copy))
|
|
|
658
|
|
|
659 (set-buffer cbuf)
|
|
|
660 (kill-buffer temp-buffer))
|
|
|
661
|
|
|
662 temp-file)
|
|
|
663
|
|
|
664 (jka-compr-run-real-handler 'file-local-copy (list filename)))))
|
|
|
665
|
|
|
666
|
|
|
667 ;;; Support for loading compressed files.
|
|
2
|
668 ;;; XEmacs: autoload this function
|
|
0
|
669 ;;;###autoload
|
|
|
670 (defun jka-compr-load (file &optional noerror nomessage nosuffix)
|
|
|
671 "Documented as original."
|
|
|
672
|
|
|
673 (let* ((local-copy (jka-compr-file-local-copy file))
|
|
|
674 (load-file (or local-copy file)))
|
|
|
675
|
|
|
676 (unwind-protect
|
|
|
677
|
|
|
678 (let (inhibit-file-name-operation
|
|
|
679 inhibit-file-name-handlers)
|
|
|
680 (or nomessage
|
|
|
681 (message "Loading %s..." file))
|
|
|
682
|
|
2
|
683 (let ((load-force-doc-strings t))
|
|
|
684 (load load-file noerror t t))
|
|
0
|
685
|
|
|
686 (or nomessage
|
|
|
687 (message "Loading %s...done." file)))
|
|
|
688
|
|
|
689 (jka-compr-delete-temp-file local-copy))
|
|
|
690
|
|
|
691 t))
|
|
2
|
692
|
|
|
693 (defun jka-compr-byte-compiler-base-file-name (file)
|
|
|
694 (let ((info (jka-compr-get-compression-info file)))
|
|
|
695 (if (and info (jka-compr-info-strip-extension info))
|
|
|
696 (save-match-data
|
|
|
697 (substring file 0 (string-match (jka-compr-info-regexp info) file)))
|
|
|
698 file)))
|
|
0
|
699
|
|
|
700 (put 'write-region 'jka-compr 'jka-compr-write-region)
|
|
|
701 (put 'insert-file-contents 'jka-compr 'jka-compr-insert-file-contents)
|
|
|
702 (put 'file-local-copy 'jka-compr 'jka-compr-file-local-copy)
|
|
|
703 (put 'load 'jka-compr 'jka-compr-load)
|
|
2
|
704 (put 'byte-compiler-base-file-name 'jka-compr
|
|
|
705 'jka-compr-byte-compiler-base-file-name)
|
|
0
|
706
|
|
|
707 (defun jka-compr-handler (operation &rest args)
|
|
|
708 (save-match-data
|
|
|
709 (let ((jka-op (get operation 'jka-compr)))
|
|
|
710 (if jka-op
|
|
|
711 (apply jka-op args)
|
|
|
712 (jka-compr-run-real-handler operation args)))))
|
|
|
713
|
|
|
714 ;; If we are given an operation that we don't handle,
|
|
|
715 ;; call the Emacs primitive for that operation,
|
|
|
716 ;; and manipulate the inhibit variables
|
|
|
717 ;; to prevent the primitive from calling our handler again.
|
|
|
718 (defun jka-compr-run-real-handler (operation args)
|
|
|
719 (let ((inhibit-file-name-handlers
|
|
|
720 (cons 'jka-compr-handler
|
|
|
721 (and (eq inhibit-file-name-operation operation)
|
|
|
722 inhibit-file-name-handlers)))
|
|
|
723 (inhibit-file-name-operation operation))
|
|
|
724 (apply operation args)))
|
|
|
725
|
|
2
|
726 ;; XEmacs change: I don't have a clue what this is trying do. -sb
|
|
|
727 ;; ;;;###autoload(defun auto-compression-mode (&optional arg)
|
|
|
728 ;; ;;;###autoload "\
|
|
|
729 ;; ;;;###autoloadToggle automatic file compression and uncompression.
|
|
|
730 ;; ;;;###autoloadWith prefix argument ARG, turn auto compression on if positive, else off.
|
|
|
731 ;; ;;;###autoloadReturns the new status of auto compression (non-nil means on)."
|
|
|
732 ;; ;;;###autoload (interactive "P")
|
|
|
733 ;; ;;;###autoload (if (not (fboundp 'jka-compr-installed-p))
|
|
|
734 ;; ;;;###autoload (progn
|
|
|
735 ;; ;;;###autoload (require 'jka-compr)
|
|
|
736 ;; ;;;###autoload ;; That turned the mode on, so make it initially off.
|
|
|
737 ;; ;;;###autoload (toggle-auto-compression)))
|
|
|
738 ;; ;;;###autoload (toggle-auto-compression arg t))
|
|
|
739
|
|
|
740 ;; XEmacs: autoload this function
|
|
0
|
741 ;;;###autoload
|
|
2
|
742 (defun toggle-auto-compression (&optional arg message)
|
|
|
743 "Toggle automatic file compression and uncompression.
|
|
0
|
744 With prefix argument ARG, turn auto compression on if positive, else off.
|
|
2
|
745 Returns the new status of auto compression (non-nil means on).
|
|
|
746 If the argument MESSAGE is non-nil, it means to print a message
|
|
|
747 saying whether the mode is now on or off."
|
|
|
748 (interactive "P\np")
|
|
0
|
749 (let* ((installed (jka-compr-installed-p))
|
|
|
750 (flag (if (null arg)
|
|
|
751 (not installed)
|
|
|
752 (or (eq arg t) (listp arg) (and (integerp arg) (> arg 0))))))
|
|
|
753
|
|
|
754 (cond
|
|
|
755 ((and flag installed) t) ; already installed
|
|
|
756
|
|
|
757 ((and (not flag) (not installed)) nil) ; already not installed
|
|
|
758
|
|
|
759 (flag
|
|
|
760 (jka-compr-install))
|
|
|
761
|
|
|
762 (t
|
|
|
763 (jka-compr-uninstall)))
|
|
|
764
|
|
|
765
|
|
2
|
766 (and message
|
|
0
|
767 (if flag
|
|
|
768 (message "Automatic file (de)compression is now ON.")
|
|
|
769 (message "Automatic file (de)compression is now OFF.")))
|
|
|
770
|
|
|
771 flag))
|
|
|
772
|
|
|
773
|
|
|
774 (defun jka-compr-build-file-regexp ()
|
|
|
775 (concat
|
|
|
776 "\\("
|
|
|
777 (mapconcat
|
|
|
778 'jka-compr-info-regexp
|
|
|
779 jka-compr-compression-info-list
|
|
|
780 "\\)\\|\\(")
|
|
|
781 "\\)"))
|
|
|
782
|
|
|
783 ;;;###autoload
|
|
|
784 (defun jka-compr-install ()
|
|
|
785 "Install jka-compr.
|
|
|
786 This adds entries to `file-name-handler-alist' and `auto-mode-alist'
|
|
|
787 and `inhibit-first-line-modes-suffixes'."
|
|
|
788
|
|
|
789 (setq jka-compr-file-name-handler-entry
|
|
|
790 (cons (jka-compr-build-file-regexp) 'jka-compr-handler))
|
|
|
791
|
|
|
792 (setq file-name-handler-alist (cons jka-compr-file-name-handler-entry
|
|
|
793 file-name-handler-alist))
|
|
|
794
|
|
|
795 (mapcar
|
|
|
796 (function (lambda (x)
|
|
|
797 (and (jka-compr-info-strip-extension x)
|
|
|
798 ;; Make entries in auto-mode-alist so that modes
|
|
|
799 ;; are chosen right according to the file names
|
|
|
800 ;; sans `.gz'.
|
|
|
801 (setq auto-mode-alist
|
|
|
802 (cons (list (jka-compr-info-regexp x)
|
|
|
803 nil 'jka-compr)
|
|
|
804 auto-mode-alist))
|
|
|
805 ;; Also add these regexps to
|
|
|
806 ;; inhibit-first-line-modes-suffixes, so that a
|
|
|
807 ;; -*- line in the first file of a compressed tar
|
|
|
808 ;; file doesn't override tar-mode.
|
|
2
|
809 ;; XEmacs: the (now)superfluous conditional doesn't hurt
|
|
0
|
810 (and (boundp 'inhibit-first-line-modes-suffixes)
|
|
|
811 (setq inhibit-first-line-modes-suffixes
|
|
|
812 (cons (jka-compr-info-regexp x)
|
|
|
813 inhibit-first-line-modes-suffixes))))))
|
|
|
814 jka-compr-compression-info-list)
|
|
|
815 (setq auto-mode-alist
|
|
|
816 (append auto-mode-alist jka-compr-mode-alist-additions)))
|
|
|
817
|
|
|
818
|
|
|
819 (defun jka-compr-uninstall ()
|
|
|
820 "Uninstall jka-compr.
|
|
|
821 This removes the entries in `file-name-handler-alist' and `auto-mode-alist'
|
|
|
822 and `inhibit-first-line-modes-suffixes' that were added
|
|
|
823 by `jka-compr-installed'."
|
|
|
824 ;; Delete from inhibit-first-line-modes-suffixes
|
|
|
825 ;; what jka-compr-install added.
|
|
|
826 (mapcar
|
|
|
827 (function (lambda (x)
|
|
|
828 (and (jka-compr-info-strip-extension x)
|
|
2
|
829 ;; XEmacs: the (now)superfluous conditional doesn't hurt
|
|
0
|
830 (and (boundp 'inhibit-first-line-modes-suffixes)
|
|
|
831 (setq inhibit-first-line-modes-suffixes
|
|
|
832 (delete (jka-compr-info-regexp x)
|
|
|
833 inhibit-first-line-modes-suffixes)))))
|
|
|
834 )
|
|
|
835 jka-compr-compression-info-list)
|
|
|
836
|
|
|
837 (let* ((fnha (cons nil file-name-handler-alist))
|
|
|
838 (last fnha))
|
|
|
839
|
|
|
840 (while (cdr last)
|
|
|
841 (if (eq (cdr (car (cdr last))) 'jka-compr-handler)
|
|
|
842 (setcdr last (cdr (cdr last)))
|
|
|
843 (setq last (cdr last))))
|
|
|
844
|
|
|
845 (setq file-name-handler-alist (cdr fnha)))
|
|
|
846
|
|
|
847 (let* ((ama (cons nil auto-mode-alist))
|
|
|
848 (last ama)
|
|
|
849 entry)
|
|
|
850
|
|
|
851 (while (cdr last)
|
|
|
852 (setq entry (car (cdr last)))
|
|
|
853 (if (or (member entry jka-compr-mode-alist-additions)
|
|
|
854 (and (consp (cdr entry))
|
|
|
855 (eq (nth 2 entry) 'jka-compr)))
|
|
|
856 (setcdr last (cdr (cdr last)))
|
|
|
857 (setq last (cdr last))))
|
|
|
858
|
|
|
859 (setq auto-mode-alist (cdr ama))))
|
|
|
860
|
|
|
861
|
|
|
862 (defun jka-compr-installed-p ()
|
|
|
863 "Return non-nil if jka-compr is installed.
|
|
|
864 The return value is the entry in `file-name-handler-alist' for jka-compr."
|
|
110
|
865 (rassq 'jka-compr-handler file-name-handler-alist))
|
|
0
|
866
|
|
|
867
|
|
189
|
868 ;; No no no no!
|
|
|
869 ;(jka-compr-install)
|
|
0
|
870
|
|
|
871
|
|
|
872 (provide 'jka-compr)
|
|
|
873
|
|
|
874 ;; jka-compr.el ends here.
|
