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