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