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