Line data Source code
1 : ;;; jka-compr.el --- reading/writing/loading compressed files
2 :
3 : ;; Copyright (C) 1993-1995, 1997, 1999-2017 Free Software Foundation,
4 : ;; Inc.
5 :
6 : ;; Author: Jay K. Adams <jka@ece.cmu.edu>
7 : ;; Maintainer: emacs-devel@gnu.org
8 : ;; Keywords: data
9 :
10 : ;; This file is part of GNU Emacs.
11 :
12 : ;; GNU Emacs is free software: you can redistribute it and/or modify
13 : ;; it under the terms of the GNU General Public License as published by
14 : ;; the Free Software Foundation, either version 3 of the License, or
15 : ;; (at your option) any later version.
16 :
17 : ;; GNU Emacs is distributed in the hope that it will be useful,
18 : ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 : ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 : ;; GNU General Public License for more details.
21 :
22 : ;; You should have received a copy of the GNU General Public License
23 : ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
24 :
25 : ;;; Commentary:
26 :
27 : ;; This package implements low-level support for reading, writing,
28 : ;; and loading compressed files. It hooks into the low-level file
29 : ;; I/O functions (including write-region and insert-file-contents) so
30 : ;; that they automatically compress or uncompress a file if the file
31 : ;; appears to need it (based on the extension of the file name).
32 : ;; Packages like Rmail, VM, GNUS, and Info should be able to work
33 : ;; with compressed files without modification.
34 :
35 :
36 : ;; INSTRUCTIONS:
37 : ;;
38 : ;; To use jka-compr, invoke the command `auto-compression-mode' (which
39 : ;; see), or customize the variable of the same name. Its operation
40 : ;; should be transparent to the user (except for messages appearing when
41 : ;; a file is being compressed or uncompressed).
42 : ;;
43 : ;; The variable, jka-compr-compression-info-list can be used to
44 : ;; customize jka-compr to work with other compression programs.
45 : ;; The default value of this variable allows jka-compr to work with
46 : ;; Unix compress and gzip.
47 : ;;
48 : ;; If you don't want messages about compressing and decompressing
49 : ;; to show up in the echo area, you can set the compress-msg and
50 : ;; decompress-msg fields of the jka-compr-compression-info-list to
51 : ;; nil.
52 :
53 :
54 : ;; APPLICATION NOTES:
55 : ;;
56 : ;; crypt++
57 : ;; jka-compr can coexist with crypt++ if you take all the decompression
58 : ;; entries out of the crypt-encoding-list. Clearly problems will arise if
59 : ;; you have two programs trying to compress/decompress files. jka-compr
60 : ;; will not "work with" crypt++ in the following sense: you won't be able to
61 : ;; decode encrypted compressed files--that is, files that have been
62 : ;; compressed then encrypted (in that order). Theoretically, crypt++ and
63 : ;; jka-compr could properly handle a file that has been encrypted then
64 : ;; compressed, but there is little point in trying to compress an encrypted
65 : ;; file.
66 : ;;
67 :
68 :
69 : ;; ACKNOWLEDGMENTS
70 : ;;
71 : ;; jka-compr is a V19 adaptation of jka-compr for V18 of Emacs. Many people
72 : ;; have made helpful suggestions, reported bugs, and even fixed bugs in
73 : ;; jka-compr. I recall the following people as being particularly helpful.
74 : ;;
75 : ;; Jean-loup Gailly
76 : ;; David Hughes
77 : ;; Richard Pieri
78 : ;; Daniel Quinlan
79 : ;; Chris P. Ross
80 : ;; Rick Sladkey
81 : ;;
82 : ;; Andy Norman's ange-ftp was the inspiration for the original jka-compr for
83 : ;; Version 18 of Emacs.
84 : ;;
85 : ;; After I had made progress on the original jka-compr for V18, I learned of a
86 : ;; package written by Kazushi Jam Marukawa, called jam-zcat, that did exactly
87 : ;; what I was trying to do. I looked over the jam-zcat source code and
88 : ;; probably got some ideas from it.
89 : ;;
90 :
91 : ;;; Code:
92 :
93 : (require 'jka-cmpr-hook)
94 :
95 : (defcustom jka-compr-shell "sh"
96 : "Shell to be used for calling compression programs.
97 : NOTE: Not used in MS-DOS and Windows systems."
98 : :type 'string
99 : :group 'jka-compr)
100 :
101 : (defvar jka-compr-use-shell
102 : (not (memq system-type '(ms-dos windows-nt))))
103 :
104 : (defvar jka-compr-really-do-compress nil
105 : "Non-nil in a buffer whose visited file was uncompressed on visiting it.
106 : This means compress the data on writing the file, even if the
107 : data appears to be compressed already.")
108 : (make-variable-buffer-local 'jka-compr-really-do-compress)
109 : (put 'jka-compr-really-do-compress 'permanent-local t)
110 :
111 :
112 : (define-error 'compression-error nil 'file-error)
113 :
114 : (defvar jka-compr-acceptable-retval-list '(0 2 141))
115 :
116 :
117 : (defun jka-compr-error (prog args infile message &optional errfile)
118 :
119 0 : (let ((errbuf (get-buffer-create " *jka-compr-error*")))
120 0 : (with-current-buffer errbuf
121 0 : (widen) (erase-buffer)
122 0 : (insert (format "Error while executing \"%s %s < %s\"\n\n"
123 0 : prog
124 0 : (mapconcat 'identity args " ")
125 0 : infile))
126 :
127 0 : (and errfile
128 0 : (insert-file-contents errfile)))
129 0 : (display-buffer errbuf))
130 :
131 0 : (signal 'compression-error
132 0 : (list "Opening input file" (format "error %s" message) infile)))
133 :
134 :
135 : (defcustom jka-compr-dd-program "/bin/dd"
136 : "How to invoke `dd'."
137 : :type 'string
138 : :group 'jka-compr)
139 :
140 :
141 : (defvar jka-compr-dd-blocksize 256)
142 :
143 :
144 : (defun jka-compr-partial-uncompress (prog message args infile beg len)
145 : "Call program PROG with ARGS args taking input from INFILE.
146 : Fourth and fifth args, BEG and LEN, specify which part of the output
147 : to keep: LEN chars starting BEG chars from the beginning."
148 0 : (let ((start (point))
149 0 : (prefix beg))
150 0 : (if (and jka-compr-use-shell jka-compr-dd-program)
151 : ;; Put the uncompression output through dd
152 : ;; to discard the part we don't want.
153 0 : (let ((skip (/ beg jka-compr-dd-blocksize))
154 0 : (err-file (jka-compr-make-temp-name))
155 : ;; call-process barfs if default-directory is inaccessible.
156 : (default-directory
157 0 : (if (and default-directory
158 0 : (file-accessible-directory-p default-directory))
159 0 : default-directory
160 0 : (file-name-directory infile)))
161 : count)
162 : ;; Update PREFIX based on the text that we won't read in.
163 0 : (setq prefix (- beg (* skip jka-compr-dd-blocksize))
164 0 : count (and len (1+ (/ (+ len prefix) jka-compr-dd-blocksize))))
165 0 : (unwind-protect
166 0 : (or (memq (call-process
167 0 : jka-compr-shell infile t nil "-c"
168 : ;; Windows shells need the program file name
169 : ;; after the pipe symbol be quoted if they use
170 : ;; forward slashes as directory separators.
171 0 : (format
172 : "%s %s 2> %s | \"%s\" bs=%d skip=%d %s 2> %s"
173 0 : prog
174 0 : (mapconcat 'identity args " ")
175 0 : err-file
176 0 : jka-compr-dd-program
177 0 : jka-compr-dd-blocksize
178 0 : skip
179 : ;; dd seems to be unreliable about
180 : ;; providing the last block. So, always
181 : ;; read one more than you think you need.
182 0 : (if count (format "count=%d" (1+ count)) "")
183 0 : null-device))
184 0 : jka-compr-acceptable-retval-list)
185 0 : (jka-compr-error prog args infile message err-file))
186 0 : (delete-file err-file)))
187 :
188 : ;; Run the uncompression program directly.
189 : ;; We get the whole file and must delete what we don't want.
190 0 : (jka-compr-call-process prog message infile t nil args))
191 :
192 : ;; Delete the stuff after what we want, if there is any.
193 0 : (and
194 0 : len
195 0 : (< (+ start prefix len) (point))
196 0 : (delete-region (+ start prefix len) (point)))
197 :
198 : ;; Delete the stuff before what we want.
199 0 : (delete-region start (+ start prefix))))
200 :
201 :
202 : (defun jka-compr-call-process (prog message infile output temp args)
203 : ;; call-process barfs if default-directory is inaccessible.
204 0 : (let ((default-directory
205 0 : (if (and default-directory
206 0 : (not (file-remote-p default-directory))
207 0 : (file-accessible-directory-p default-directory))
208 0 : default-directory
209 0 : (file-name-directory infile))))
210 0 : (if jka-compr-use-shell
211 0 : (let ((err-file (jka-compr-make-temp-name))
212 0 : (coding-system-for-read (or coding-system-for-read 'undecided))
213 : (coding-system-for-write 'no-conversion))
214 0 : (unwind-protect
215 0 : (or (memq
216 0 : (call-process jka-compr-shell infile
217 0 : (if (stringp output) nil output)
218 : nil
219 : "-c"
220 0 : (format "%s %s 2> %s %s"
221 0 : prog
222 0 : (mapconcat 'identity args " ")
223 0 : err-file
224 0 : (if (stringp output)
225 0 : (concat "> " output)
226 0 : "")))
227 0 : jka-compr-acceptable-retval-list)
228 0 : (jka-compr-error prog args infile message err-file))
229 0 : (delete-file err-file)))
230 0 : (or (eq 0
231 0 : (apply 'call-process
232 0 : prog infile (if (stringp output) temp output)
233 0 : nil args))
234 0 : (jka-compr-error prog args infile message))
235 0 : (and (stringp output)
236 0 : (with-current-buffer temp
237 0 : (write-region (point-min) (point-max) output)
238 0 : (erase-buffer))))))
239 :
240 :
241 : ;; Support for temp files. Much of this was inspired if not lifted
242 : ;; from ange-ftp.
243 :
244 : (defcustom jka-compr-temp-name-template
245 : (expand-file-name "jka-com" temporary-file-directory)
246 : "Prefix added to all temp files created by jka-compr.
247 : There should be no more than seven characters after the final `/'."
248 : :type 'string
249 : :group 'jka-compr)
250 :
251 : (defun jka-compr-make-temp-name (&optional _local-copy)
252 : "This routine will return the name of a new file."
253 0 : (make-temp-file jka-compr-temp-name-template))
254 :
255 : (defun jka-compr-write-region (start end file &optional
256 : append visit lockname mustbenew)
257 0 : (let* ((filename (expand-file-name file))
258 0 : (visit-file (if (stringp visit) (expand-file-name visit) filename))
259 0 : (info (jka-compr-get-compression-info visit-file))
260 0 : (magic (and info (jka-compr-info-file-magic-bytes info))))
261 :
262 : ;; If we uncompressed this file when visiting it,
263 : ;; then recompress it when writing it
264 : ;; even if the contents look compressed already.
265 0 : (if (and jka-compr-really-do-compress
266 0 : (or (null start)
267 0 : (= (- end start) (buffer-size))))
268 0 : (setq magic nil))
269 :
270 0 : (if (and info
271 : ;; If the contents to be written out
272 : ;; are properly compressed already,
273 : ;; don't try to compress them over again.
274 0 : (not (and magic
275 0 : (equal (if (stringp start)
276 0 : (substring start 0 (min (length start)
277 0 : (length magic)))
278 0 : (let* ((from (or start (point-min)))
279 0 : (to (min (or end (point-max))
280 0 : (+ from (length magic)))))
281 0 : (buffer-substring from to)))
282 0 : magic))))
283 0 : (let ((can-append (jka-compr-info-can-append info))
284 0 : (compress-program (jka-compr-info-compress-program info))
285 0 : (compress-message (jka-compr-info-compress-message info))
286 0 : (compress-args (jka-compr-info-compress-args info))
287 0 : (base-name (file-name-nondirectory visit-file))
288 : temp-file temp-buffer
289 : ;; we need to leave `last-coding-system-used' set to its
290 : ;; value after calling write-region the first time, so
291 : ;; that `basic-save-buffer' sees the right value.
292 0 : (coding-system-used last-coding-system-used))
293 :
294 0 : (or compress-program
295 0 : (error "No compression program defined"))
296 :
297 0 : (setq temp-buffer (get-buffer-create " *jka-compr-wr-temp*"))
298 0 : (with-current-buffer temp-buffer
299 0 : (widen) (erase-buffer))
300 :
301 0 : (if (and append
302 0 : (not can-append)
303 0 : (file-exists-p filename))
304 :
305 0 : (let* ((local-copy (file-local-copy filename))
306 0 : (local-file (or local-copy filename)))
307 :
308 0 : (setq temp-file local-file))
309 :
310 0 : (setq temp-file (jka-compr-make-temp-name)))
311 :
312 0 : (and
313 0 : compress-message
314 0 : jka-compr-verbose
315 0 : (message "%s %s..." compress-message base-name))
316 :
317 0 : (jka-compr-run-real-handler 'write-region
318 0 : (list start end temp-file t 'dont))
319 : ;; save value used by the real write-region
320 0 : (setq coding-system-used last-coding-system-used)
321 :
322 : ;; Here we must read the output of compress program as is
323 : ;; without any code conversion.
324 0 : (let ((coding-system-for-read 'no-conversion))
325 0 : (jka-compr-call-process compress-program
326 0 : (concat compress-message
327 0 : " " base-name)
328 0 : temp-file
329 0 : temp-buffer
330 : nil
331 0 : compress-args))
332 :
333 0 : (with-current-buffer temp-buffer
334 0 : (let ((coding-system-for-write 'no-conversion))
335 0 : (jka-compr-run-real-handler 'write-region
336 0 : (list (point-min) (point-max)
337 0 : filename
338 0 : (and append can-append) 'dont
339 0 : lockname mustbenew))
340 0 : (erase-buffer)) )
341 :
342 0 : (delete-file temp-file)
343 :
344 0 : (and
345 0 : compress-message
346 0 : jka-compr-verbose
347 0 : (message "%s %s...done" compress-message base-name))
348 :
349 0 : (cond
350 0 : ((eq visit t)
351 0 : (setq buffer-file-name filename)
352 0 : (setq jka-compr-really-do-compress t)
353 0 : (set-visited-file-modtime))
354 0 : ((stringp visit)
355 0 : (setq buffer-file-name visit)
356 0 : (let ((buffer-file-name filename))
357 0 : (set-visited-file-modtime))))
358 :
359 0 : (and (or (eq visit t)
360 0 : (eq visit nil)
361 0 : (stringp visit))
362 0 : (message "Wrote %s" visit-file))
363 :
364 : ;; ensure `last-coding-system-used' has an appropriate value
365 0 : (setq last-coding-system-used coding-system-used)
366 :
367 0 : nil)
368 :
369 0 : (jka-compr-run-real-handler 'write-region
370 0 : (list start end filename append visit
371 0 : lockname mustbenew)))))
372 :
373 :
374 : (defun jka-compr-insert-file-contents (file &optional visit beg end replace)
375 0 : (barf-if-buffer-read-only)
376 :
377 0 : (and (or beg end)
378 0 : visit
379 0 : (error "Attempt to visit less than an entire file"))
380 :
381 0 : (let* ((filename (expand-file-name file))
382 0 : (info (jka-compr-get-compression-info filename)))
383 :
384 0 : (if (not info)
385 :
386 0 : (jka-compr-run-real-handler 'insert-file-contents
387 0 : (list file visit beg end replace))
388 :
389 0 : (let ((uncompress-message (jka-compr-info-uncompress-message info))
390 0 : (uncompress-program (jka-compr-info-uncompress-program info))
391 0 : (uncompress-args (jka-compr-info-uncompress-args info))
392 0 : (base-name (file-name-nondirectory filename))
393 : (notfound nil)
394 : (local-copy
395 0 : (jka-compr-run-real-handler 'file-local-copy (list filename)))
396 : local-file
397 : size start)
398 :
399 0 : (setq local-file (or local-copy filename))
400 :
401 0 : (and
402 0 : visit
403 0 : (setq buffer-file-name filename))
404 :
405 0 : (unwind-protect ; to make sure local-copy gets deleted
406 :
407 0 : (progn
408 :
409 0 : (and
410 0 : uncompress-message
411 0 : jka-compr-verbose
412 0 : (message "%s %s..." uncompress-message base-name))
413 :
414 0 : (condition-case error-code
415 :
416 0 : (let ((coding-system-for-read 'no-conversion))
417 0 : (if replace
418 0 : (goto-char (point-min)))
419 0 : (setq start (point))
420 0 : (if (or beg end)
421 0 : (jka-compr-partial-uncompress uncompress-program
422 0 : (concat uncompress-message
423 0 : " " base-name)
424 0 : uncompress-args
425 0 : local-file
426 0 : (or beg 0)
427 0 : (if (and beg end)
428 0 : (- end beg)
429 0 : end))
430 : ;; If visiting, bind off buffer-file-name so that
431 : ;; file-locking will not ask whether we should
432 : ;; really edit the buffer.
433 0 : (let ((buffer-file-name
434 0 : (if visit nil buffer-file-name)))
435 0 : (jka-compr-call-process uncompress-program
436 0 : (concat uncompress-message
437 0 : " " base-name)
438 0 : local-file
439 : t
440 : nil
441 0 : uncompress-args)))
442 0 : (setq size (- (point) start))
443 0 : (if replace
444 0 : (delete-region (point) (point-max)))
445 0 : (goto-char start))
446 : (error
447 : ;; If the file we wanted to uncompress does not exist,
448 : ;; handle that according to VISIT as `insert-file-contents'
449 : ;; would, maybe signaling the same error it normally would.
450 0 : (if (and (eq (car error-code) 'file-missing)
451 0 : (eq (nth 3 error-code) local-file))
452 0 : (if visit
453 0 : (setq notfound error-code)
454 0 : (signal 'file-missing
455 0 : (cons "Opening input file"
456 0 : (nthcdr 2 error-code))))
457 : ;; If the uncompression program can't be found,
458 : ;; signal that as a non-file error
459 : ;; so that find-file-noselect-1 won't handle it.
460 0 : (if (and (memq 'file-error (get (car error-code)
461 0 : 'error-conditions))
462 0 : (equal (cadr error-code) "Searching for program"))
463 0 : (error "Uncompression program `%s' not found"
464 0 : (nth 3 error-code)))
465 0 : (signal (car error-code) (cdr error-code))))))
466 :
467 0 : (and
468 0 : local-copy
469 0 : (file-exists-p local-copy)
470 0 : (delete-file local-copy)))
471 :
472 0 : (unless notfound
473 0 : (decode-coding-inserted-region
474 0 : (point) (+ (point) size)
475 0 : (jka-compr-byte-compiler-base-file-name file)
476 0 : visit beg end replace))
477 :
478 0 : (and
479 0 : visit
480 0 : (progn
481 0 : (unlock-buffer)
482 0 : (setq buffer-file-name filename)
483 0 : (setq jka-compr-really-do-compress t)
484 0 : (set-visited-file-modtime)))
485 :
486 0 : (and
487 0 : uncompress-message
488 0 : jka-compr-verbose
489 0 : (message "%s %s...done" uncompress-message base-name))
490 :
491 0 : (and
492 0 : visit
493 0 : notfound
494 0 : (signal 'file-missing
495 0 : (cons "Opening input file" (nth 2 notfound))))
496 :
497 : ;; This is done in insert-file-contents after we return.
498 : ;; That is a little weird, but better to go along with it now
499 : ;; than to change it now.
500 :
501 : ;; ;; Run the functions that insert-file-contents would.
502 : ;; (let ((p after-insert-file-functions)
503 : ;; (insval size))
504 : ;; (while p
505 : ;; (setq insval (funcall (car p) size))
506 : ;; (if insval
507 : ;; (progn
508 : ;; (or (integerp insval)
509 : ;; (signal 'wrong-type-argument
510 : ;; (list 'integerp insval)))
511 : ;; (setq size insval)))
512 : ;; (setq p (cdr p))))
513 :
514 0 : (or (jka-compr-info-compress-program info)
515 0 : (message "You can't save this buffer because compression program is not defined"))
516 :
517 0 : (list filename size)))))
518 :
519 :
520 : (defun jka-compr-file-local-copy (file)
521 0 : (let* ((filename (expand-file-name file))
522 0 : (info (jka-compr-get-compression-info filename)))
523 :
524 0 : (if info
525 :
526 0 : (let ((uncompress-message (jka-compr-info-uncompress-message info))
527 0 : (uncompress-program (jka-compr-info-uncompress-program info))
528 0 : (uncompress-args (jka-compr-info-uncompress-args info))
529 0 : (base-name (file-name-nondirectory filename))
530 : (local-copy
531 0 : (jka-compr-run-real-handler 'file-local-copy (list filename)))
532 0 : (temp-file (jka-compr-make-temp-name t))
533 0 : (temp-buffer (get-buffer-create " *jka-compr-flc-temp*"))
534 : local-file)
535 :
536 0 : (setq local-file (or local-copy filename))
537 :
538 0 : (unwind-protect
539 :
540 0 : (with-current-buffer temp-buffer
541 :
542 0 : (and
543 0 : uncompress-message
544 0 : jka-compr-verbose
545 0 : (message "%s %s..." uncompress-message base-name))
546 :
547 : ;; Here we must read the output of uncompress program
548 : ;; and write it to TEMP-FILE without any code
549 : ;; conversion. An appropriate code conversion (if
550 : ;; necessary) is done by the later I/O operation
551 : ;; (e.g. load).
552 0 : (let ((coding-system-for-read 'no-conversion)
553 : (coding-system-for-write 'no-conversion))
554 :
555 0 : (jka-compr-call-process uncompress-program
556 0 : (concat uncompress-message
557 0 : " " base-name)
558 0 : local-file
559 : t
560 : nil
561 0 : uncompress-args)
562 :
563 0 : (and
564 0 : uncompress-message
565 0 : jka-compr-verbose
566 0 : (message "%s %s...done" uncompress-message base-name))
567 :
568 0 : (write-region
569 0 : (point-min) (point-max) temp-file nil 'dont)))
570 :
571 0 : (and
572 0 : local-copy
573 0 : (file-exists-p local-copy)
574 0 : (delete-file local-copy))
575 :
576 0 : (kill-buffer temp-buffer))
577 :
578 0 : temp-file)
579 :
580 0 : (jka-compr-run-real-handler 'file-local-copy (list filename)))))
581 :
582 :
583 : ;; Support for loading compressed files.
584 : (defun jka-compr-load (file &optional noerror nomessage _nosuffix)
585 : "Documented as original."
586 :
587 0 : (let* ((local-copy (jka-compr-file-local-copy file))
588 0 : (load-file (or local-copy file)))
589 :
590 0 : (unwind-protect
591 :
592 0 : (let (inhibit-file-name-operation
593 : inhibit-file-name-handlers)
594 0 : (or nomessage
595 0 : (message "Loading %s..." file))
596 :
597 0 : (let ((load-force-doc-strings t))
598 0 : (load load-file noerror t t))
599 0 : (or nomessage
600 0 : (message "Loading %s...done." file))
601 : ;; Fix up the load history to point at the right library.
602 0 : (let ((l (or (assoc load-file load-history)
603 : ;; On MS-Windows, if load-file is in
604 : ;; temporary-file-directory, it will look like
605 : ;; "c:/DOCUME~1/USER/LOCALS~1/foo", whereas
606 : ;; readevalloop will record its truename in
607 : ;; load-history. Therefore try truename if the
608 : ;; original name is not in load-history.
609 0 : (assoc (file-truename load-file) load-history))))
610 : ;; Remove .gz and .elc?.
611 0 : (while (file-name-extension file)
612 0 : (setq file (file-name-sans-extension file)))
613 0 : (setcar l file)))
614 :
615 0 : (delete-file local-copy))
616 :
617 0 : t))
618 :
619 : (defun jka-compr-byte-compiler-base-file-name (file)
620 0 : (let ((info (jka-compr-get-compression-info file)))
621 0 : (if (and info (jka-compr-info-strip-extension info))
622 0 : (save-match-data
623 0 : (substring file 0 (string-match (jka-compr-info-regexp info) file)))
624 0 : file)))
625 :
626 : (put 'write-region 'jka-compr 'jka-compr-write-region)
627 : (put 'insert-file-contents 'jka-compr 'jka-compr-insert-file-contents)
628 : (put 'file-local-copy 'jka-compr 'jka-compr-file-local-copy)
629 : (put 'load 'jka-compr 'jka-compr-load)
630 : (put 'byte-compiler-base-file-name 'jka-compr
631 : 'jka-compr-byte-compiler-base-file-name)
632 :
633 : ;;;###autoload
634 : (defvar jka-compr-inhibit nil
635 : "Non-nil means inhibit automatic uncompression temporarily.
636 : Lisp programs can bind this to t to do that.
637 : It is not recommended to set this variable permanently to anything but nil.")
638 :
639 : ;;;###autoload
640 : (defun jka-compr-handler (operation &rest args)
641 0 : (save-match-data
642 0 : (let ((jka-op (get operation 'jka-compr)))
643 0 : (if (and jka-op (not jka-compr-inhibit))
644 0 : (apply jka-op args)
645 0 : (jka-compr-run-real-handler operation args)))))
646 :
647 : ;; If we are given an operation that we don't handle,
648 : ;; call the Emacs primitive for that operation,
649 : ;; and manipulate the inhibit variables
650 : ;; to prevent the primitive from calling our handler again.
651 : (defun jka-compr-run-real-handler (operation args)
652 0 : (let ((inhibit-file-name-handlers
653 0 : (cons 'jka-compr-handler
654 0 : (and (eq inhibit-file-name-operation operation)
655 0 : inhibit-file-name-handlers)))
656 0 : (inhibit-file-name-operation operation))
657 0 : (apply operation args)))
658 :
659 : ;;;###autoload
660 : (defun jka-compr-uninstall ()
661 : "Uninstall jka-compr.
662 : This removes the entries in `file-name-handler-alist' and `auto-mode-alist'
663 : and `inhibit-local-variables-suffixes' that were added
664 : by `jka-compr-installed'."
665 : ;; Delete from inhibit-local-variables-suffixes what jka-compr-install added.
666 0 : (mapc
667 0 : (function (lambda (x)
668 0 : (and (jka-compr-info-strip-extension x)
669 0 : (setq inhibit-local-variables-suffixes
670 0 : (delete (jka-compr-info-regexp x)
671 0 : inhibit-local-variables-suffixes)))))
672 0 : jka-compr-compression-info-list--internal)
673 :
674 0 : (let* ((fnha (cons nil file-name-handler-alist))
675 0 : (last fnha))
676 :
677 0 : (while (cdr last)
678 0 : (if (eq (cdr (car (cdr last))) 'jka-compr-handler)
679 0 : (setcdr last (cdr (cdr last)))
680 0 : (setq last (cdr last))))
681 :
682 0 : (setq file-name-handler-alist (cdr fnha)))
683 :
684 0 : (let* ((ama (cons nil auto-mode-alist))
685 0 : (last ama)
686 : entry)
687 :
688 0 : (while (cdr last)
689 0 : (setq entry (car (cdr last)))
690 0 : (if (or (member entry jka-compr-mode-alist-additions--internal)
691 0 : (and (consp (cdr entry))
692 0 : (eq (nth 2 entry) 'jka-compr)))
693 0 : (setcdr last (cdr (cdr last)))
694 0 : (setq last (cdr last))))
695 :
696 0 : (setq auto-mode-alist (cdr ama)))
697 :
698 0 : (while jka-compr-added-to-file-coding-system-alist
699 0 : (setq file-coding-system-alist
700 0 : (delq (car (member (pop jka-compr-added-to-file-coding-system-alist)
701 0 : file-coding-system-alist))
702 0 : file-coding-system-alist)))
703 :
704 : ;; Remove the suffixes that were added by jka-compr.
705 0 : (dolist (suff jka-compr-load-suffixes--internal)
706 0 : (setq load-file-rep-suffixes (delete suff load-file-rep-suffixes)))
707 :
708 0 : (setq jka-compr-compression-info-list--internal nil
709 : jka-compr-mode-alist-additions--internal nil
710 0 : jka-compr-load-suffixes--internal nil))
711 :
712 : (provide 'jka-compr)
713 :
714 : ;;; jka-compr.el ends here
|