Mercurial > hg > xemacs-beta

comparison lisp/packages/jka-compr.el @ 0:376386a54a3c r19-14

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