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