home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / misc / jka-compr.el < prev    next >
Encoding:
Text File  |  1993-05-28  |  28.7 KB  |  851 lines
  1. ;;; jka-compr.el - low level support for reading/writing compressed files
  2. ;;; bugs/comments to jka@ece.cmu.edu
  3. ;;; Version: 0.2
  4. ;;; Last modified: 5/25/93
  5.  
  6.  
  7. ;;; Copyright (C) 1993  Jay K. Adams
  8. ;;;
  9. ;;; This program is free software; you can redistribute it and/or modify
  10. ;;; it under the terms of the GNU General Public License as published by
  11. ;;; the Free Software Foundation; either version 2 of the License, or
  12. ;;; (at your option) any later version.
  13. ;;;
  14. ;;; This program is distributed in the hope that it will be useful,
  15. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17. ;;; GNU General Public License for more details.
  18. ;;;
  19. ;;; You should have received a copy of the GNU General Public License
  20. ;;; along with this program; if not, write to the Free Software
  21. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  22.  
  23.  
  24. ;;; LCD Archive Entry:
  25. ;;; jka-compr|Jay Adams|jka@ece.cmu.edu|
  26. ;;; Low level support for reading/writing compressed files|
  27. ;;; 25-May-1993|0.2|~/misc/jka-compr.el.Z|
  28.  
  29.  
  30. ;;; This package implements low-level support for reading and writing
  31. ;;; compressed files.  It overwrites several low-level file I/O
  32. ;;; functions (including write-region and insert-file-contents) so
  33. ;;; that they automatically compress or uncompress a file if the file
  34. ;;; appears to need it (based on the extension of the file name).
  35. ;;; Although its a little presumptious of a low-level function to make
  36. ;;; a decision about whether a file should be compressed or
  37. ;;; uncompressed, doing so offers the benefit of allowing packages
  38. ;;; like Rmail, Vm, Gnus, and Info to work with compressed files
  39. ;;; without modification.
  40.  
  41.  
  42. ;;; INSTRUCTIONS:
  43. ;;;
  44. ;;; To use jka-compr, simply load this package, and edit as usual.
  45. ;;; Its operation should be transparent to the user (except for
  46. ;;; messages appearing when a file is being compressed or
  47. ;;; uncompressed).
  48. ;;;
  49. ;;; *** THIS PACKAGE SHOULD BE LOADED BEFORE ANGE-FTP ***
  50. ;;;
  51. ;;; The variable, jka-compr-compression-info-list can be used to
  52. ;;; customize jka-compr to work with other compression programs.  The
  53. ;;; default value of this variable allows jka-compr to work with Unix
  54. ;;; compress and gzip.
  55. ;;; 
  56. ;;; If you are concerned about the stderr output of gzip and other
  57. ;;; compression/decompression programs showing up in your buffers you
  58. ;;; should set the discard-error flag in the compression-info-list.
  59. ;;; This will cause the stderr of all programs to be discarded.
  60. ;;; However, it also causes emacs to call compression/uncompression
  61. ;;; programs through a shell (which is specified by jka-compr-shell).
  62. ;;; This may be a drag if, on your system, starting up a shell is
  63. ;;; slow.
  64. ;;;
  65. ;;; If you don't want messages about compressing and decompressing
  66. ;;; to show up in the echo area, you can set the compress-name and
  67. ;;; decompress-name fields of the jka-compr-compression-info-list to
  68. ;;; nil.
  69.  
  70.  
  71. ;;; APPLICATION NOTES:
  72. ;;; 
  73. ;;; loading compressed elisp files
  74. ;;;   The jka-load package gives you the ability to load, autoload,
  75. ;;;   and require compressed elisp files when jka-compr is installed.
  76. ;;;   jka-load is probably available wherever you got jka-compr.
  77. ;;;
  78. ;;; dired
  79. ;;;   Normally jka-compr works fine with dired.  However, one case
  80. ;;;   where it doesn't work so well is when you use the dired 'B'
  81. ;;;   command (byte compile file).  The .z on the file name makes
  82. ;;;   dired think the file is not compilable.  Changing the
  83. ;;;   dired-byte-recompile function to the one shown below will get
  84. ;;;   around this problem.  It makes dired recognize a file as being
  85. ;;;   an emacs lisp file even if it has a .z or .Z extension after the
  86. ;;;   .el. 
  87. ;;;
  88. ;;;   (defun dired-byte-recompile ()
  89. ;;;     "Byte recompile this file."
  90. ;;;     (interactive)
  91. ;;;     (let* ((buffer-read-only nil)
  92. ;;;            (from-file (dired-get-filename))
  93. ;;;            (to-file (substring from-file 0 -3)))
  94. ;;;       (if (string-match "\\.el\\(\\.[zZ]\\)?$" from-file) nil
  95. ;;;           (error "%s is uncompilable!" from-file))
  96. ;;;       (byte-compile-file from-file)))
  97. ;;;
  98. ;;;   The dired supplied with Lucid Emacs 19.6 is a little different
  99. ;;;   and requires the following version of dired-byte-compile (from
  100. ;;;   David Hughes, Apr 20, 1993).
  101. ;;;       
  102. ;;;   (defun dired-byte-compile ()
  103. ;;;     ;; Return nil for success, offending file name else.
  104. ;;;     (let* ((filename (dired-get-filename))
  105. ;;;            (elc-file
  106. ;;;             (if (eq system-type 'vax-vms)
  107. ;;;                 (concat (substring filename 0
  108. ;;;                                    (string-match ";" filename)) "c")
  109. ;;;               (if (string-match "\\.el\\(\\.[zZ]\\)?$" filename)
  110. ;;;                   (concat (substring filename 0
  111. ;;;                                      (match-beginning 0)) ".elc")
  112. ;;;                 (error "%s is uncompilable!" filename))))
  113. ;;;            buffer-read-only failure)
  114. ;;;       (condition-case err
  115. ;;;           (save-excursion (byte-compile-file filename))
  116. ;;;         (error
  117. ;;;          (setq failure err)))
  118. ;;;       (if failure
  119. ;;;           (progn
  120. ;;;             (dired-log "Byte compile error for %s:\n%s\n"
  121. ;;;                        filename failure)
  122. ;;;             (dired-make-relative filename))
  123. ;;;         (dired-remove-file elc-file)
  124. ;;;         (forward-line)                    ; insert .elc after its .el file
  125. ;;;         (dired-add-file elc-file)
  126. ;;;         nil)))
  127. ;;;
  128. ;;;
  129. ;;; rmail, vm, gnus, etc.
  130. ;;;   To use compressed mail folders, .newsrc files, etc., you need
  131. ;;;   only compress the file.  Since jka-compr searches for .z
  132. ;;;   versions of the files it's finding, you need not change
  133. ;;;   variables within rmail, gnus, etc.  
  134. ;;;
  135. ;;; crypt++
  136. ;;;   jka-compr can coexist with crpyt++ if you take all the decryption
  137. ;;;   entries out of the crypt-encoding-list.  Clearly problems will
  138. ;;;   arise if you have two programs trying to compress/decompress
  139. ;;;   files.  jka-compr will not "work with" crypt++: you won't be
  140. ;;;   able to decode encrypted compressed files--that is, files that
  141. ;;;   have been compressed then encrypted (in that order).
  142. ;;;   Theoretically, crypt++ and jka-compr could properly handle a
  143. ;;;   file that has been encrypted then compressed, but there is little
  144. ;;;   point in trying to compress an encrypted file.
  145.  
  146.  
  147.  
  148. ;;; TO DO
  149. ;;;
  150. ;;; Note:  as far as I'm concerned, the whole idea of dealing with
  151. ;;; compressed files in this way is still experimental.  Still, I and
  152. ;;; others have been using this code for some time and have found it
  153. ;;; useful.
  154. ;;;
  155. ;;; Also, I consider this code to be in beta-test.  The bug rate has
  156. ;;; been pretty low, however, so after the few remaining issues
  157. ;;; (listed below) are addressed, I'll release Version 1.0 (maybe
  158. ;;; sometime this summer).
  159. ;;;
  160. ;;; To do list:
  161. ;;;
  162. ;;; 1. Make jka-compr work whether or not ange-ftp is loaded first.
  163. ;;;    I'm not sure if this is practical.  Forcing jka-compr to be
  164. ;;;    loaded first seems like a good compromise for now.
  165. ;;;
  166. ;;; 2. Fix it so that the compression extension (.Z or .z) does not
  167. ;;;    appear in the buffer name.
  168. ;;;
  169. ;;; 3. Add the ability to configure translations on the file name to
  170. ;;;    be applied before mode-specification.  For instance, .taz files
  171. ;;;    should be recognized as being compressed but should be treated
  172. ;;;    as .tar files for mode-specification.
  173. ;;;
  174. ;;; 4. Consider making file name completion less concerned with .Z suffixes.
  175. ;;; 
  176. ;;; 5. Figure out how to do error checking and handling.
  177. ;;;    Unfortunately, there doesn't seem to be any way to check the
  178. ;;;    error status of programs called by emacs through call-process.
  179. ;;;
  180. ;;; 6. Encrypted files.  It would be nice to be able to handle
  181. ;;;    encrypted compressed files.
  182.  
  183.  
  184. ;;; History:
  185. ;;;
  186. ;;;   Apr 20, 1993    Started keeping a history of changes.
  187. ;;;
  188. ;;;   Apr 20, 1993    Fixed problems caused by expand-file-name
  189. ;;;                   mysteriously returning nil.
  190. ;;;
  191. ;;;                   0.1 released
  192. ;;;
  193. ;;;   Apr 30, 1993    Added error handler to jka-compr-insert-file-contents
  194. ;;;                   to catch and properly handle errors caused by the 
  195. ;;;                   file not being readable.
  196. ;;;
  197. ;;;   May 25, 1993    Fixed jka-compr-file-name-sans-versions to comply
  198. ;;;                   with Version 19.
  199. ;;;
  200. ;;;                   0.2 released
  201.  
  202.  
  203. (defvar jka-compr-enabled t
  204.   "*Non-nil means that the jka-compr package is enabled.")
  205.  
  206.  
  207. (defvar jka-compr-verify-append-file-change t
  208.   "Non-nil means ask the user before changing the name of an append file.")
  209.  
  210.  
  211. (defvar jka-compr-verify-overwrite-file-change t
  212.   "Non-nil means ask the user before changing the name of a file being written.")
  213.  
  214.  
  215. (defvar jka-compr-verify-visited-file-change t
  216.   "Non-nil means ask the user before changing the visited file name of a buffer.")
  217.  
  218.  
  219. (defvar jka-compr-verify-delete-file-change t
  220.   "Non-nil means ask the user before changing the name of a file being deleted.")
  221.  
  222.  
  223. (defvar jka-compr-shell "sh"
  224.   "*Shell to be used for calling compression programs.
  225. The value of this variable only matters if you want to discard the
  226. stderr of a compression/decompression program (see the documentation
  227. for jka-compr-compression-info-list).")
  228.  
  229.  
  230. ;;; I have this defined so that .Z files are assumed to be in unix
  231. ;;; compress format; and .z files, in gzip format.
  232. (defvar jka-compr-compression-info-list
  233.   ;;[regexp  magic 
  234.   ;; compr-name  compr-prog  compr-discard  compr-args
  235.   ;; uncomp-name uncomp-prog uncomp-discard uncomp-args
  236.   ;; can-append extension]
  237.   '(["\\.Z~?$"     "\037\235"
  238.      "compress"    "compress"     nil  nil
  239.      "uncompress"  "uncompress"   nil  nil
  240.      nil           ".Z"]
  241.     ["\\.z~?$"     "\037\213"
  242.      "zip"         "gzip"         nil  nil
  243.      "unzip"       "gzip"         nil  ("-d")
  244.      t             ".z"])
  245.  
  246.   "List of vectors that describe available compression techniques.
  247. Each element, which describes a compression technique, is a vector of
  248. the form [regexp magic compress-name compress-program compress-discard-err
  249. compress-args uncompress-name uncompress-program uncompress-discard-err
  250. uncompress-args append-flag extension] where:
  251.  
  252.    regexp                is a regexp that matches filenames that are
  253.                          compressed with this format
  254.  
  255.    magic                 is a two-byte magic number that identifies
  256.                          files that are compressed with this format
  257.  
  258.    compress-name         is an English name of the compression (nil
  259.                          means don't show message when compressing)
  260.  
  261.    compress-program      is a program that performs this compression
  262.  
  263.    compress-discard-err  is non-nil if the stderr output of the compress
  264.                          program should be discarded.  Setting this flag to 
  265.                          non-nil also causes jka-compr to call compression
  266.                          programs using a shell rather than directly.
  267.  
  268.    compress-args         is a list of args to pass to the compress program
  269.  
  270.    uncompress-name       is an English name of the uncompression (nil
  271.                          means don't show message when decompressing)
  272.  
  273.    uncompress-program    is a program that performs this compression
  274.  
  275.    uncompress-discard-err  is non-nil if the stderr output of the uncompress
  276.                          program should be discarded.  Setting this flag to 
  277.                          non-nil also causes jka-compr to call decompression
  278.                          programs using a shell rather than directly.
  279.  
  280.    uncompress-args       is a list of args to pass to the uncompress program
  281.  
  282.    append-flag           is non-nil if this compression technique can be
  283.                          appended
  284.  
  285.    extension             string to add to end of filename when looking for
  286.                          files compressed with this technique.
  287.  
  288. Because of the way call-process is defined, discarding the stderr output of
  289. a program adds the overhead of starting a shell each time the program is
  290. invoked.")
  291.  
  292.  
  293. ;;; Functions for accessing the return value of jka-get-compression-info
  294. (defun jka-compr-info-fname-match-beg      (info)  (car (car info)))
  295. (defun jka-compr-info-fname-match-end      (info)  (cdr (car info)))
  296. (defun jka-compr-info-fname-regexp         (info)  (aref (cdr info) 0))
  297. (defun jka-compr-info-magic                (info)  (aref (cdr info) 1))
  298. (defun jka-compr-info-compress-message     (info)  (aref (cdr info) 2))
  299. (defun jka-compr-info-compress-program     (info)  (aref (cdr info) 3))
  300. (defun jka-compr-info-compress-discard-err (info)  (aref (cdr info) 4))
  301. (defun jka-compr-info-compress-args        (info)  (aref (cdr info) 5))
  302. (defun jka-compr-info-uncompress-message   (info)  (aref (cdr info) 6))
  303. (defun jka-compr-info-uncompress-program   (info)  (aref (cdr info) 7))
  304. (defun jka-compr-info-uncompress-discard-err (info)  (aref (cdr info) 8))
  305. (defun jka-compr-info-uncompress-args      (info)  (aref (cdr info) 9))
  306. (defun jka-compr-info-can-append           (info)  (aref (cdr info) 10))
  307.  
  308.  
  309. (defun jka-compr-get-compression-info-mapper (x)
  310.   "Function used by jka-compr-get-compression-info
  311. to map across the jka-compr-compression-info-list."
  312.   (let ((case-fold-search nil))
  313.     (if (string-match (aref x 0) filename)
  314.     (throw 'compression-info
  315.            (cons (cons (match-beginning 0) (match-end 0))
  316.              x)))))
  317.  
  318.  
  319. (defvar jka-compr-mktemp-regexp 
  320.   "[A-Za-z0-9][A-Za-z0-9][A-Za-z0-9][A-Za-z0-9][A-Za-z0-9][A-Za-z0-9]"
  321.   "A regexp that matches the return value of mktemp(3).")
  322.  
  323.  
  324. (defun jka-compr-get-compression-info (filename)
  325.   "Return information about the compression scheme of FILENAME.
  326. The determination as to which compression scheme, if any, to use is
  327. based on the filename itself and jka-compr-compression-info-list."
  328.   (and
  329.    (boundp 'ange-ftp-tmp-name-template)
  330.    (boundp 'path)
  331.    (or
  332.     ;; See if it looks like an ange-ftp temp file.
  333.     (string-match (concat "^" (regexp-quote ange-ftp-tmp-name-template)
  334.               jka-compr-mktemp-regexp "$")
  335.           filename)
  336.     (string-match (concat "^" (regexp-quote ange-ftp-gateway-tmp-name-template)
  337.               jka-compr-mktemp-regexp "$")
  338.           filename))
  339.    ;; If so, use the path variable (dynamically bound by
  340.    ;; ange-ftp-insert-file-contents and ange-ftp-write-region) as the file
  341.    ;; name.
  342.    (setq filename path))
  343.  
  344.   (catch 'compression-info
  345.     (mapcar 'jka-compr-get-compression-info-mapper
  346.         jka-compr-compression-info-list)
  347.     nil))
  348.  
  349.  
  350.  
  351. (defvar jka-compr-temp-name-template
  352.   "/usr/tmp/jka-compr")
  353.  
  354.  
  355. (defun jka-compr-write-region (start end filename &optional append visit)
  356.   "Documented as original."
  357.   (interactive "r\nFWrite region to file: ")
  358.   (cond
  359.    (jka-compr-enabled
  360.     (let (zfile)
  361.       (setq filename (expand-file-name filename))
  362.       (setq zfile (or (jka-compr-find-compressed-version filename)
  363.               filename))
  364.       (or
  365.        (string= zfile filename)
  366.        (if append
  367.  
  368.        (and
  369.         (or (not jka-compr-verify-append-file-change)
  370.         (yes-or-no-p (format "Append to file %s? " zfile)))
  371.         (setq filename zfile))
  372.  
  373.      (and
  374.       (or (not jka-compr-verify-overwrite-file-change)
  375.           (yes-or-no-p (format "Overwrite file %s? " zfile)))
  376.       (setq filename zfile)))))
  377.  
  378.     (let ((info (jka-compr-get-compression-info filename)))
  379.  
  380.       (if info
  381.  
  382.       (let ((can-append (jka-compr-info-can-append info))
  383.         (compress-program (jka-compr-info-compress-program info))
  384.         (compress-message (jka-compr-info-compress-message info))
  385.         (uncompress-program (jka-compr-info-uncompress-program info))
  386.         (uncompress-message (jka-compr-info-uncompress-message info))
  387.         (compress-args (jka-compr-info-compress-args info))
  388.         (uncompress-args (jka-compr-info-uncompress-args info))
  389.         (discard-err (jka-compr-info-compress-discard-err info))
  390.         (temp-file (make-temp-name jka-compr-temp-name-template))
  391.         cbuf temp-buffer)
  392.  
  393.         (or
  394.          discard-err
  395.          (progn
  396.            (setq cbuf (current-buffer)
  397.              temp-buffer (get-buffer-create " *jka-compr-temp*"))
  398.            (set-buffer temp-buffer)
  399.            (widen) (erase-buffer)
  400.            (set-buffer cbuf)))
  401.  
  402.         (and append
  403.          (not can-append)
  404.          (jka-compr-real-file-exists-p filename)
  405.          (progn
  406.               
  407.            (and
  408.             uncompress-message
  409.             (message "%sing %s..." uncompress-message
  410.                  (file-name-nondirectory filename)))
  411.  
  412.            (if discard-err
  413.  
  414.                (call-process
  415.             jka-compr-shell filename nil nil
  416.             "-c" (format "%s -c %s 2> /dev/null > %s"
  417.                      uncompress-program
  418.                      (mapconcat (function (lambda (x) x))
  419.                         uncompress-args
  420.                         " ")
  421.                      temp-file))
  422.                
  423.              (apply 'call-process
  424.                 uncompress-program filename temp-buffer nil
  425.                 uncompress-args)
  426.              (set-buffer temp-buffer)
  427.              (jka-compr-real-write-region (point-min) (point-max)
  428.                           temp-file)
  429.              (erase-buffer)
  430.              (set-buffer cbuf))
  431.  
  432.            (and
  433.             uncompress-message
  434.             (message "%sing %s...done" uncompress-message
  435.                  (file-name-nondirectory filename)))))
  436.  
  437.         (and 
  438.          compress-message
  439.          (message "%sing %s..." compress-message
  440.               (file-name-nondirectory filename)))
  441.  
  442.         (jka-compr-real-write-region start end temp-file t 'dont)
  443.  
  444.         (if discard-err
  445.  
  446.         ;; this seems a little dangerous
  447.         (call-process
  448.          jka-compr-shell temp-file nil nil
  449.          "-c" (format "%s -c %s 2> /dev/null %s %s"
  450.                   compress-program
  451.                   (mapconcat (function (lambda (x) x))
  452.                      compress-args " ")
  453.                   (if (and append can-append) ">>" ">")
  454.                   filename))
  455.  
  456.           (apply 'call-process
  457.              compress-program temp-file temp-buffer nil
  458.              compress-args)
  459.           (set-buffer temp-buffer)
  460.           (jka-compr-real-write-region (point-min) (point-max)
  461.                        filename (and append can-append))
  462.           (erase-buffer)
  463.           (set-buffer cbuf))
  464.  
  465.         (jka-compr-real-delete-file temp-file)
  466.  
  467.         (and
  468.          compress-message
  469.          (message "%sing %s...done" compress-message
  470.               (file-name-nondirectory filename)))
  471.  
  472.         (and
  473.          (eq visit t)
  474.          (progn
  475.            ;; set visited file name and buffer file modtime
  476.            (clear-visited-file-modtime)
  477.            (jka-compr-real-write-region start start filename t t)))
  478.  
  479.         (if (and visit (not (eq visit t)))
  480.         nil
  481.           (message "Wrote %s" filename)
  482.           nil))
  483.           
  484.     (jka-compr-real-write-region start end filename append visit))))
  485.    (t
  486.     (jka-compr-real-write-region start end filename append visit))))
  487.     
  488.  
  489.  
  490. (defun jka-compr-insert-file-contents (filename &optional visit)
  491.   "Documented as original."
  492.  
  493.   (cond
  494.    (jka-compr-enabled
  495.  
  496.     (barf-if-buffer-read-only)
  497.  
  498.     (setq filename (or (jka-compr-find-compressed-version filename)
  499.                filename))
  500.  
  501.     (let ((info (jka-compr-get-compression-info filename)))
  502.  
  503.       (if info
  504.  
  505.       (let ((magic (jka-compr-info-magic info))
  506.         (uncompress-message (jka-compr-info-uncompress-message info))
  507.         (uncompress-program (jka-compr-info-uncompress-program info))
  508.         (discard-err (jka-compr-info-uncompress-discard-err info))
  509.         (uncompress-args (jka-compr-info-uncompress-args info))
  510.         (temp-file (make-temp-name jka-compr-temp-name-template))
  511.         (notfound nil)
  512.         size start)
  513.  
  514.         (and
  515.          uncompress-message
  516.          (message "%sing %s..." uncompress-message
  517.               (file-name-nondirectory filename)))
  518.  
  519.         (condition-case error-code
  520.  
  521.         (if discard-err
  522.  
  523.             (progn
  524.               (call-process
  525.                jka-compr-shell filename nil nil 
  526.                "-c" (format "%s -c %s 2> /dev/null > %s"
  527.                     uncompress-program
  528.                     (mapconcat (function (lambda (x) x))
  529.                            uncompress-args
  530.                            " ")
  531.                     temp-file))
  532.               (setq size (nth 1 (jka-compr-real-insert-file-contents
  533.                      temp-file visit)))
  534.               (jka-compr-real-delete-file temp-file))
  535.  
  536.           (setq start (point))
  537.           (apply 'call-process
  538.              uncompress-program filename t nil
  539.              uncompress-args)
  540.           (setq size (- (point) start))
  541.           (goto-char start))
  542.  
  543.           (error
  544.            (if (and (eq (car error-code) 'file-error)
  545.             (eq (nth 3 error-code) filename))
  546.            (if visit
  547.                (setq notfound error-code)
  548.                (signal 'file-error 
  549.                    (cons "Openning input file"
  550.                      (nthcdr 2 error-code))))
  551.          (signal (car error-code) (cdr error-code)))))
  552.            
  553.  
  554.         (and
  555.          visit
  556.          (setq buffer-file-name filename)
  557.          ;; this sets the save_modified field of the buffer
  558.          (set-buffer-modified-p nil)
  559.          ;; this sets the auto_save_modified and save_length of the buffer
  560.          (set-buffer-auto-saved)
  561.          ;; attempt to set the modtime of the buffer by doing a
  562.          ;; dummy write to the file.
  563.          (jka-compr-real-write-region (point) (point) filename t t))
  564.         
  565.         (and
  566.          uncompress-message
  567.          (message "%sing %s...done" uncompress-message
  568.               (file-name-nondirectory filename)))
  569.  
  570.         (and
  571.          visit
  572.          notfound
  573.          (signal 'file-error
  574.              (cons "Openning input file" (nth 2 notfound))))
  575.  
  576.         (list filename size))
  577.  
  578.     (jka-compr-real-insert-file-contents filename visit))))
  579.    (t
  580.     (jka-compr-real-insert-file-contents filename visit))))
  581.     
  582.  
  583.  
  584. ;;; This originally came from uncompress.el
  585. (defun jka-compr-find-compressed-version (filename)
  586.   "If FILENAME does not exist, try to find a compressed version.
  587. Return the version (extended filename) that is found.  If the file
  588. does not exist and no compressed versions are found, return nil."
  589.   (if (jka-compr-real-file-exists-p filename)
  590.       filename
  591.     (catch 'found-compressed-version
  592.       (mapcar
  593.        (function (lambda (cinfo)
  594.            (let ((extended-fname (concat filename (aref cinfo 11))))
  595.              (if (jka-compr-real-file-exists-p extended-fname)
  596.              (throw 'found-compressed-version extended-fname)))))
  597.        jka-compr-compression-info-list)
  598.       nil)))
  599.  
  600.  
  601.  
  602. ;;; There are probably many little functions like this that need to
  603. ;;; be defined.  These seem to to the job for info and rmail.
  604.  
  605.  
  606. ;;; expand-file-name will be overwritten when/if ange-ftp is loaded.
  607. ;;; This step makes sure we get a virgin copy of the expand file-name
  608. ;;; routine (without actually assuming that ange-ftp will be loaded).
  609. (fset 'jka-compr-real-expand-file-name
  610.       (symbol-function 'expand-file-name))
  611.  
  612.  
  613. (defun jka-compr-file-readable-p (file)
  614.   "Documented as original."
  615.   (if jka-compr-enabled
  616.       (and 
  617.        (setq file (jka-compr-real-expand-file-name file))
  618.        (setq file (jka-compr-find-compressed-version file))
  619.        (jka-compr-real-file-readable-p file))
  620.     (jka-compr-real-file-readable-p file)))
  621.  
  622.  
  623. (defun jka-compr-file-writable-p (file)
  624.   "Documented as original."
  625.   (if jka-compr-enabled 
  626.       (let* ((efile (jka-compr-real-expand-file-name file))
  627.          (zfile (and efile (jka-compr-find-compressed-version efile))))
  628.     (if zfile
  629.         (jka-compr-real-file-writable-p zfile)
  630.       (file-directory-p (file-name-directory file))))
  631.     (jka-compr-real-file-writable-p file)))
  632.  
  633.  
  634. (defun jka-compr-verify-visited-file-modtime (buf)
  635.   "Documented as original."
  636.   (and
  637.    jka-compr-enabled
  638.    (not (jka-compr-real-file-exists-p (buffer-file-name buf)))
  639.    (let* ((bfile (buffer-file-name buf))
  640.       (efile (jka-compr-real-expand-file-name bfile))
  641.       (file  (and efile (jka-compr-find-compressed-version efile)))
  642.       (cbuf (current-buffer)))
  643.      
  644.      (and
  645.       (stringp file)
  646.       (not (string= file bfile))
  647.       (or (not jka-compr-verify-visited-file-change)
  648.       (yes-or-no-p
  649.        (format "Change visited file of buffer %s to %s? "
  650.            (buffer-name buf) file)))
  651.       (set-buffer buf)
  652.       (set-visited-file-name file)
  653.       (set-buffer cbuf))))
  654.   (jka-compr-real-verify-visited-file-modtime buf))
  655.  
  656.  
  657. (defun jka-compr-file-symlink-p (file)
  658.   "Documented as original."
  659.   (if jka-compr-enabled
  660.       (and
  661.        (setq file (jka-compr-real-expand-file-name file))
  662.        (setq file (jka-compr-find-compressed-version file))
  663.        (jka-compr-real-file-symlink-p file))
  664.     (jka-compr-real-file-symlink-p file)))
  665.  
  666.  
  667. (defun jka-compr-file-attributes (file)
  668.   "Documented as original."
  669.   (if jka-compr-enabled
  670.       (and
  671.        (setq file (jka-compr-real-expand-file-name file))
  672.        (setq file (jka-compr-find-compressed-version file))
  673.        (jka-compr-real-file-attributes file))
  674.     (jka-compr-real-file-attributes file)))
  675.  
  676.  
  677. (defun jka-compr-file-exists-p (file)
  678.   "Documented as original."
  679.   (if jka-compr-enabled
  680.       (and
  681.        (setq file (jka-compr-real-expand-file-name file))
  682.        (jka-compr-find-compressed-version file)
  683.        t)
  684.     (jka-compr-real-file-exists-p file)))
  685.  
  686.  
  687. (defun jka-compr-delete-file (file)
  688.   "Documented as original."
  689.   (if jka-compr-enabled
  690.       (let (zfile)
  691.     (setq file  (jka-compr-real-expand-file-name file)
  692.           zfile (or (and file (jka-compr-find-compressed-version file))
  693.             file))
  694.     (and
  695.      (or (string= zfile file)
  696.          (not jka-compr-verify-delete-file-change)
  697.          (yes-or-no-p (format "Delete file %s? "zfile)))
  698.      (jka-compr-real-delete-file zfile)))
  699.  
  700.     (jka-compr-real-delete-file file)))
  701.  
  702.  
  703. ;;; Ange-ftp doesn't overwrite get-file-buffer so it should call the
  704. ;;; ange-ftp version of expand-file-name (in case the file is on a
  705. ;;; remote system).
  706. (defun jka-compr-get-file-buffer (file)
  707.   "Documented as original."
  708.   (if jka-compr-enabled
  709.       (or
  710.        (jka-compr-real-get-file-buffer file)
  711.        (and
  712.     (setq file (expand-file-name file))
  713.     (setq file (jka-compr-find-compressed-version file))
  714.     (jka-compr-real-get-file-buffer file)))
  715.     (jka-compr-real-get-file-buffer file)))
  716.  
  717.  
  718. (if (= 19 (string-to-int emacs-version))
  719. ;;; For emacs version 19.
  720. (defun jka-compr-file-name-sans-versions (name &optional keep-backup-version)
  721.   "Documented as original."
  722.   ;; this function assumes that the regexps in jka-compr-compression-info-list
  723.   ;; will find .z extensions even if there are backup flags or version numbers
  724.   ;; attached.
  725.   (if jka-compr-enabled
  726.       (jka-compr-real-file-name-sans-versions
  727.        (catch 'name-sans-compress-extension
  728.      (mapcar
  729.       (function (lambda (x)
  730.               (if (string-match (aref x 0) name)
  731.               (throw 'name-sans-compress-extension 
  732.                  (substring name 0 (match-beginning 0))))))
  733.       jka-compr-compression-info-list)
  734.      name)
  735.        keep-backup-version)
  736.     (jka-compr-real-file-name-sans-versions name keep-backup-version)))
  737.  
  738. ;;; for non-19 versions of emacs
  739. (defun jka-compr-file-name-sans-versions (name)
  740.   "Documented as original."
  741.   ;; this function assumes that the regexps in jka-compr-compression-info-list
  742.   ;; will find .z extensions even if there are backup flags or version numbers
  743.   ;; attached.
  744.   (if jka-compr-enabled
  745.       (jka-compr-real-file-name-sans-versions
  746.        (catch 'name-sans-compress-extension
  747.      (mapcar
  748.       (function (lambda (x)
  749.               (if (string-match (aref x 0) name)
  750.               (throw 'name-sans-compress-extension 
  751.                  (substring name 0 (match-beginning 0))))))
  752.       jka-compr-compression-info-list)
  753.      name))
  754.     (jka-compr-real-file-name-sans-versions name)))
  755.  
  756. ;;; if version = 19
  757. )
  758.  
  759.  
  760. ;;; This function was lifted from ange-ftp.  I added some args to make
  761. ;;; it a little more general. - jka
  762. (defun jka-compr-overwrite-fn (fun saved-prefix new-prefix overwrite-msg)
  763.   "Replace FUN's function definition with NEW-PREFIX-FUN's, saving the
  764. original definition as SAVED-PREFIX-FUN.  The original documentation is
  765. placed on the new definition suitably augmented.  Third arg, OVERWRITE-MSG,
  766. is tacked on to the doc string of the new fun."
  767.  
  768.   (let* ((name (symbol-name fun))
  769.      (saved (intern (concat saved-prefix name)))
  770.      (new (intern (concat new-prefix name)))
  771.      (nfun (symbol-function new))
  772.      (exec-directory (if (or (equal (nth 3 command-line-args) "dump")
  773.                  (equal (nth 4 command-line-args) "dump"))
  774.                  "../etc/"
  775.                exec-directory)))             
  776.     
  777.     (while (symbolp nfun)
  778.       (setq nfun (symbol-function nfun)))
  779.     
  780.     (or (fboundp saved)
  781.     (progn
  782.       (fset saved (symbol-function fun))
  783.       (fset fun new)))
  784.     
  785.     (let* ((doc-str (jka-compr-safe-documentation saved))
  786.        (ndoc-str (concat doc-str (and doc-str "\n")
  787.                  overwrite-msg)))
  788.       
  789.       (cond ((listp nfun)
  790.          ;; Probe to test whether function is in preloaded read-only
  791.          ;; memory, and if so make writable copy:
  792.          (condition-case nil
  793.          (setcar nfun (car nfun))
  794.            (error
  795.         (setq nfun (copy-sequence nfun)) ; shallow copy only
  796.         (fset new nfun)))
  797.          (let ((ndoc-cdr (nthcdr 2 nfun)))
  798.            (if (stringp (car ndoc-cdr))
  799.            ;; Replace the existing docstring.
  800.            (setcar ndoc-cdr ndoc-str)
  801.          ;; There is no docstring.  Insert the overwrite msg.
  802.          (setcdr ndoc-cdr (cons (car ndoc-cdr) (cdr ndoc-cdr)))
  803.          (setcar ndoc-cdr overwrite-msg))))
  804.         (t
  805.          ;; it's an emacs19 compiled-code object
  806.          (let ((new-code (append nfun nil))) ; turn it into a list
  807.            (if (nthcdr 4 new-code)
  808.            (setcar (nthcdr 4 new-code) ndoc-str)
  809.          (setcdr (nthcdr 3 new-code) (cons ndoc-str nil)))
  810.            (fset new (apply 'make-byte-code new-code))))))))
  811.  
  812.  
  813. (defun jka-compr-safe-documentation (fun)
  814.   "A documentation function that isn't quite as fragile."
  815.   (condition-case ()
  816.       (documentation fun)
  817.     (error nil)))
  818.  
  819.  
  820. (defvar jka-compr-overwrite-list
  821.   '(
  822.     write-region
  823.     insert-file-contents
  824.     file-readable-p
  825.     file-writable-p
  826.     file-symlink-p
  827.     file-attributes
  828.     file-exists-p
  829.     delete-file
  830.     get-file-buffer
  831.     file-name-sans-versions
  832.     verify-visited-file-modtime
  833.     )
  834.   "List of functions overwritten by jka-compr-install.")
  835.  
  836.  
  837. (mapcar
  838.  (function
  839.   (lambda (fn)
  840.     (jka-compr-overwrite-fn
  841.      fn
  842.      "jka-compr-real-"
  843.      "jka-compr-"
  844.      "Note: This function has been modified to work with jka-compr.")
  845.     )
  846.   )
  847.  jka-compr-overwrite-list)
  848.  
  849.  
  850. (provide 'jka-compr)
  851.