home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / misc / jka-compr19.el < prev    next >
Encoding:
Text File  |  1993-06-14  |  34.7 KB  |  1,117 lines
  1. ;;; jka-compr19.el - low level support for reading/writing/loading compressed
  2. ;;;                  files in GNU Emacs Version 19.
  3. ;;; bugs/comments to jka@ece.cmu.edu
  4. ;;; Version: 0.4
  5. ;;; Last modified: 6/8/93
  6.  
  7.  
  8. ;;; Copyright (C) 1993  Jay K. Adams
  9. ;;;
  10. ;;; This program is free software; you can redistribute it and/or modify
  11. ;;; it under the terms of the GNU General Public License as published by
  12. ;;; the Free Software Foundation; either version 2 of the License, or
  13. ;;; (at your option) any later version.
  14. ;;;
  15. ;;; This program is distributed in the hope that it will be useful,
  16. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18. ;;; GNU General Public License for more details.
  19. ;;;
  20. ;;; You should have received a copy of the GNU General Public License
  21. ;;; along with this program; if not, write to the Free Software
  22. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  23.  
  24.  
  25. ;;; LCD Archive Entry:
  26. ;;; jka-compr19|Jay Adams|jka@ece.cmu.edu|
  27. ;;; Low level support for reading/writing/loading compressed files in GNU Emacs V19|
  28. ;;; 08-June-1993|0.4|~/misc/jka-compr19.el.Z|
  29.  
  30.  
  31. ;;; This package implements low-level support for reading, writing,
  32. ;;; and loading compressed files.  It hooks into the low-level file I/O
  33. ;;; functions (including write-region and insert-file-contents) so
  34. ;;; that they automatically compress or uncompress a file if the file
  35. ;;; appears to need it (based on the extension of the file name).
  36. ;;; Although its a little presumptious of a low-level function to make
  37. ;;; a decision about whether a file should be compressed or
  38. ;;; uncompressed, doing so offers the benefit of allowing packages
  39. ;;; like Rmail, Vm, Gnus, and Info to work with compressed files
  40. ;;; without modification.
  41.  
  42.  
  43. ;;; INSTRUCTIONS:
  44. ;;;
  45. ;;; To use jka-compr, simply load this package, and edit as usual.
  46. ;;; Its operation should be transparent to the user (except for
  47. ;;; messages appearing when a file is being compressed or
  48. ;;; uncompressed).
  49. ;;;
  50. ;;; The variable, jka-compr-compression-info-list can be used to
  51. ;;; customize jka-compr to work with other compression programs.  The
  52. ;;; default value of this variable allows jka-compr to work with Unix
  53. ;;; compress and gzip.
  54. ;;; 
  55. ;;; If you are concerned about the stderr output of gzip and other
  56. ;;; compression/decompression programs showing up in your buffers you
  57. ;;; should set the discard-error flag in the compression-info-list.
  58. ;;; This will cause the stderr of all programs to be discarded.
  59. ;;; However, it also causes emacs to call compression/uncompression
  60. ;;; programs through a shell (which is specified by jka-compr-shell).
  61. ;;; This may be a drag if, on your system, starting up a shell is
  62. ;;; slow.
  63. ;;;
  64. ;;; If you don't want messages about compressing and decompressing
  65. ;;; to show up in the echo area, you can set the compress-name and
  66. ;;; decompress-name fields of the jka-compr-compression-info-list to
  67. ;;; nil.
  68.  
  69.  
  70. ;;; APPLICATION NOTES:
  71. ;;; 
  72. ;;; dired (note: I don't know if thie still applies in Version 19 of Emacs)
  73. ;;;   Normally jka-compr works fine with dired.  However, one case
  74. ;;;   where it doesn't work so well is when you use the dired 'B'
  75. ;;;   command (byte compile file).  The .z on the file name makes
  76. ;;;   dired think the file is not compilable.  Changing the
  77. ;;;   dired-byte-recompile function to the one shown below will get
  78. ;;;   around this problem.  It makes dired recognize a file as being
  79. ;;;   an emacs lisp file even if it has a .z or .Z extension after the
  80. ;;;   .el. 
  81. ;;;
  82. ;;;   (defun dired-byte-recompile ()
  83. ;;;     "Byte recompile this file."
  84. ;;;     (interactive)
  85. ;;;     (let* ((buffer-read-only nil)
  86. ;;;            (from-file (dired-get-filename))
  87. ;;;            (to-file (substring from-file 0 -3)))
  88. ;;;       (if (string-match "\\.el\\(\\.[zZ]\\)?$" from-file) nil
  89. ;;;           (error "%s is uncompilable!" from-file))
  90. ;;;       (byte-compile-file from-file)))
  91. ;;;
  92. ;;;   The dired supplied with Lucid Emacs 19.6 is a little different
  93. ;;;   and requires the following version of dired-byte-compile (from
  94. ;;;   David Hughes, Apr 20, 1993).
  95. ;;;       
  96. ;;;   (defun dired-byte-compile ()
  97. ;;;     ;; Return nil for success, offending file name else.
  98. ;;;     (let* ((filename (dired-get-filename))
  99. ;;;            (elc-file
  100. ;;;             (if (eq system-type 'vax-vms)
  101. ;;;                 (concat (substring filename 0
  102. ;;;                                    (string-match ";" filename)) "c")
  103. ;;;               (if (string-match "\\.el\\(\\.[zZ]\\)?$" filename)
  104. ;;;                   (concat (substring filename 0
  105. ;;;                                      (match-beginning 0)) ".elc")
  106. ;;;                 (error "%s is uncompilable!" filename))))
  107. ;;;            buffer-read-only failure)
  108. ;;;       (condition-case err
  109. ;;;           (save-excursion (byte-compile-file filename))
  110. ;;;         (error
  111. ;;;          (setq failure err)))
  112. ;;;       (if failure
  113. ;;;           (progn
  114. ;;;             (dired-log "Byte compile error for %s:\n%s\n"
  115. ;;;                        filename failure)
  116. ;;;             (dired-make-relative filename))
  117. ;;;         (dired-remove-file elc-file)
  118. ;;;         (forward-line)                    ; insert .elc after its .el file
  119. ;;;         (dired-add-file elc-file)
  120. ;;;         nil)))
  121. ;;;
  122. ;;;
  123. ;;; rmail, vm, gnus, etc.
  124. ;;;   To use compressed mail folders, .newsrc files, etc., you need
  125. ;;;   only compress the file.  Since jka-compr searches for .z
  126. ;;;   versions of the files it's finding, you need not change
  127. ;;;   variables within rmail, gnus, etc.  
  128. ;;;
  129. ;;; crypt++
  130. ;;;   jka-compr can coexist with crpyt++ if you take all the decryption
  131. ;;;   entries out of the crypt-encoding-list.  Clearly problems will
  132. ;;;   arise if you have two programs trying to compress/decompress
  133. ;;;   files.  jka-compr will not "work with" crypt++: you won't be
  134. ;;;   able to decode encrypted compressed files--that is, files that
  135. ;;;   have been compressed then encrypted (in that order).
  136. ;;;   Theoretically, crypt++ and jka-compr could properly handle a
  137. ;;;   file that has been encrypted then compressed, but there is little
  138. ;;;   point in trying to compress an encrypted file.
  139.  
  140.  
  141.  
  142. ;;; TO DO
  143. ;;;
  144. ;;; Note:  as far as I'm concerned, the whole idea of dealing with
  145. ;;; compressed files in this way is still experimental.  Still, I and
  146. ;;; others have been using this code for some time and have found it
  147. ;;; useful.
  148. ;;;
  149. ;;; Also, I consider this code to be in beta-test.  The bug rate has
  150. ;;; been pretty low, however, so after the few remaining issues
  151. ;;; (listed below) are addressed, I'll release Version 1.0 (maybe
  152. ;;; sometime this summer).
  153. ;;;
  154. ;;; To do list:
  155. ;;;
  156. ;;; 1. Fix it so that the compression extension (.Z or .z) does not
  157. ;;;    appear in the buffer name.
  158. ;;;
  159. ;;; 2. Add the ability to configure translations on the file name to
  160. ;;;    be applied before mode-specification.  For instance, .taz files
  161. ;;;    should be recognized as being compressed but should be treated
  162. ;;;    as .tar files for mode-specification.
  163. ;;;
  164. ;;; 3. Consider making file name completion less concerned with .Z suffixes.
  165. ;;;
  166.  
  167.  
  168. ;;; History:
  169. ;;;
  170. ;;;   Apr 20, 1993    Started keeping a history of changes.
  171. ;;;
  172. ;;;   Apr 20, 1993    Fixed problems caused by expand-file-name
  173. ;;;                   mysteriously returning nil.
  174. ;;;
  175. ;;;                   0.1 released
  176. ;;;
  177. ;;;   Apr 30, 1993    Added error handler to jka-compr-insert-file-contents
  178. ;;;                   to catch and properly handle errors caused by the 
  179. ;;;                   file not being readable.
  180. ;;;
  181. ;;;   May 25, 1993    Fixed jka-compr-file-name-sans-versions to comply
  182. ;;;                   with Version 19.
  183. ;;;
  184. ;;;                   0.2 released
  185. ;;;
  186. ;;;   June 6, 1993    jka-compr for Version 19 created.  
  187. ;;;                   New file name: jka-compr19.el
  188. ;;;
  189. ;;;                   Added support for the visit argument of
  190. ;;;                   write-region being a string.
  191. ;;;
  192. ;;;                   Changed dummy writes in insert-file-contents and
  193. ;;;                   write-region to calls to set-visited-file-name
  194. ;;;                   and set-visited-file-modtime.
  195. ;;;
  196. ;;;                   Modified the compression-info-list to recognize
  197. ;;;                   the .gz extension for gzip.
  198. ;;;
  199. ;;;                   Added checks for the exit status of calls to
  200. ;;;                   compression and uncompression programs.
  201. ;;;
  202. ;;;                   Changed the way the package hooks into file I/O
  203. ;;;                   functions (using the file-name-handler-alist
  204. ;;;                   instead of overwriting function definitions).
  205. ;;;
  206. ;;;                   Added a rewrite of ange-ftp-file-name-directory
  207. ;;;                   to work around a bug in set-visited-file-modtime.
  208. ;;;
  209. ;;;    June 7, 1993   Created jka-compr-call-process to cut down on
  210. ;;;                   the complexity of jka-compr-write-region and
  211. ;;;                   jka-compr-insert-file-contents.
  212. ;;;
  213. ;;;                   0.3 of jka-compr19 released.
  214. ;;;
  215. ;;;                   Added a workaround for a bug in rename-file (in 19.12).
  216. ;;;
  217. ;;;                   0.3a released.
  218. ;;;
  219. ;;;    June 8, 1993   Added jka-compr-file-local-copy.
  220. ;;;
  221. ;;;                   Added support for loading compressed files (folded
  222. ;;;                   in code from jka-load.el).
  223. ;;;
  224. ;;;                   Change default directory for
  225. ;;;                   jka-compr-temp-name-template to /tmp (was /usr/tmp).
  226. ;;;
  227. ;;;                   0.4 released.
  228.  
  229.  
  230. (defvar jka-compr-enabled t
  231.   "*Non-nil means that the jka-compr package is enabled.")
  232.  
  233.  
  234. (defvar jka-compr-verify-append-file-change t
  235.   "Non-nil means ask the user before changing the name of an append file.")
  236.  
  237.  
  238. (defvar jka-compr-verify-overwrite-file-change t
  239.   "Non-nil means ask the user before changing the name of a file being written.")
  240.  
  241.  
  242. (defvar jka-compr-verify-visited-file-change t
  243.   "Non-nil means ask the user before changing the visited file name of a buffer.")
  244.  
  245.  
  246. (defvar jka-compr-verify-delete-file-change t
  247.   "Non-nil means ask the user before changing the name of a file being deleted.")
  248.  
  249.  
  250. (defvar jka-compr-shell "sh"
  251.   "*Shell to be used for calling compression programs.
  252. The value of this variable only matters if you want to discard the
  253. stderr of a compression/decompression program (see the documentation
  254. for jka-compr-compression-info-list).")
  255.  
  256.  
  257. ;;; I have this defined so that .Z files are assumed to be in unix
  258. ;;; compress format; and .z files, in gzip format.
  259. (defvar jka-compr-compression-info-list
  260.   ;;[regexp  magic 
  261.   ;; compr-name  compr-prog  compr-discard  compr-args
  262.   ;; uncomp-name uncomp-prog uncomp-discard uncomp-args
  263.   ;; can-append extension]
  264.   '(["\\.Z~?$"     "\037\235"
  265.      "compress"    "compress"     nil  nil
  266.      "uncompress"  "uncompress"   nil  nil
  267.      nil           ".Z"]
  268.     ["\\.z~?$"     "\037\213"
  269.      "zip"         "gzip"         nil  nil
  270.      "unzip"       "gzip"         nil  ("-d")
  271.      t             ".z"]
  272.     ["\\.gz~?$"     "\037\213"
  273.      "zip"         "gzip"         nil  nil
  274.      "unzip"       "gzip"         nil  ("-d")
  275.      t             ".gz"])
  276.  
  277.   "List of vectors that describe available compression techniques.
  278. Each element, which describes a compression technique, is a vector of
  279. the form [regexp magic compress-name compress-program compress-discard-err
  280. compress-args uncompress-name uncompress-program uncompress-discard-err
  281. uncompress-args append-flag extension] where:
  282.  
  283.    regexp                is a regexp that matches filenames that are
  284.                          compressed with this format
  285.  
  286.    magic                 is a two-byte magic number that identifies
  287.                          files that are compressed with this format
  288.  
  289.    compress-name         is an English name of the compression (nil
  290.                          means don't show message when compressing)
  291.  
  292.    compress-program      is a program that performs this compression
  293.  
  294.    compress-discard-err  is non-nil if the stderr output of the compress
  295.                          program should be discarded.  Setting this flag to 
  296.                          non-nil also causes jka-compr to call compression
  297.                          programs using a shell rather than directly.
  298.  
  299.    compress-args         is a list of args to pass to the compress program
  300.  
  301.    uncompress-name       is an English name of the uncompression (nil
  302.                          means don't show message when decompressing)
  303.  
  304.    uncompress-program    is a program that performs this compression
  305.  
  306.    uncompress-discard-err  is non-nil if the stderr output of the uncompress
  307.                          program should be discarded.  Setting this flag to 
  308.                          non-nil also causes jka-compr to call decompression
  309.                          programs using a shell rather than directly.
  310.  
  311.    uncompress-args       is a list of args to pass to the uncompress program
  312.  
  313.    append-flag           is non-nil if this compression technique can be
  314.                          appended
  315.  
  316.    extension             string to add to end of filename when looking for
  317.                          files compressed with this technique.
  318.  
  319. Because of the way call-process is defined, discarding the stderr output of
  320. a program adds the overhead of starting a shell each time the program is
  321. invoked.")
  322.  
  323.  
  324. ;;; Functions for accessing the return value of jka-get-compression-info
  325. (defun jka-compr-info-fname-match-beg      (info)  (car (car info)))
  326. (defun jka-compr-info-fname-match-end      (info)  (cdr (car info)))
  327. (defun jka-compr-info-fname-regexp         (info)  (aref (cdr info) 0))
  328. (defun jka-compr-info-magic                (info)  (aref (cdr info) 1))
  329. (defun jka-compr-info-compress-message     (info)  (aref (cdr info) 2))
  330. (defun jka-compr-info-compress-program     (info)  (aref (cdr info) 3))
  331. (defun jka-compr-info-compress-discard-err (info)  (aref (cdr info) 4))
  332. (defun jka-compr-info-compress-args        (info)  (aref (cdr info) 5))
  333. (defun jka-compr-info-uncompress-message   (info)  (aref (cdr info) 6))
  334. (defun jka-compr-info-uncompress-program   (info)  (aref (cdr info) 7))
  335. (defun jka-compr-info-uncompress-discard-err (info)  (aref (cdr info) 8))
  336. (defun jka-compr-info-uncompress-args      (info)  (aref (cdr info) 9))
  337. (defun jka-compr-info-can-append           (info)  (aref (cdr info) 10))
  338.  
  339.  
  340. (defun jka-compr-get-compression-info-mapper (x)
  341.   "Function used by jka-compr-get-compression-info
  342. to map across the jka-compr-compression-info-list."
  343.   (let ((case-fold-search nil))
  344.     (if (string-match (aref x 0) filename)
  345.     (throw 'compression-info
  346.            (cons (cons (match-beginning 0) (match-end 0))
  347.              x)))))
  348.  
  349.  
  350. (defvar jka-compr-mktemp-regexp 
  351.   "[A-Za-z0-9][A-Za-z0-9][A-Za-z0-9][A-Za-z0-9][A-Za-z0-9][A-Za-z0-9]"
  352.   "A regexp that matches the return value of mktemp(3).")
  353.  
  354.  
  355. (defun jka-compr-get-compression-info (filename)
  356.   "Return information about the compression scheme of FILENAME.
  357. The determination as to which compression scheme, if any, to use is
  358. based on the filename itself and jka-compr-compression-info-list."
  359.   (catch 'compression-info
  360.     (mapcar 'jka-compr-get-compression-info-mapper
  361.         jka-compr-compression-info-list)
  362.     nil))
  363.  
  364.  
  365. (defun jka-compr-call-process (prog infile output temp discard-err args)
  366.   (if discard-err
  367.  
  368.       (or (zerop
  369.        (call-process jka-compr-shell infile
  370.              (if (stringp output) nil output)
  371.              nil
  372.              "-c"
  373.              (format "%s -c %s 2> /dev/null %s"
  374.                  prog
  375.                  (mapconcat (function (lambda (x) x))
  376.                         args
  377.                         " ")
  378.                  (if (stringp output)
  379.                      (concat "> " output)
  380.                    ""))))
  381.  
  382.       (error "Non-zero exit status for %s." prog))
  383.  
  384.     (or (zerop
  385.      (apply 'call-process
  386.         prog
  387.         infile
  388.         (if (stringp output) temp output)
  389.         nil
  390.         args))
  391.     (error "Non-zero exit status for %s." prog))
  392.  
  393.     (and (stringp output)
  394.      (let ((cbuf (current-buffer)))
  395.        (set-buffer temp)
  396.        (write-region (point-min) (point-max) output)
  397.        (erase-buffer)
  398.        (set-buffer cbuf)))))
  399.  
  400.  
  401. (defvar jka-compr-temp-name-template
  402.   "/tmp/jka-compr")
  403.  
  404.  
  405. (defun jka-compr-write-region (start end filename &optional append visit)
  406.   "Documented as original."
  407.   (interactive "r\nFWrite region to file: ")
  408.   (cond
  409.    (jka-compr-enabled
  410.     (let (zfile)
  411.       (setq filename (expand-file-name filename))
  412.       (setq zfile (or (jka-compr-find-compressed-version filename)
  413.               filename))
  414.       (or
  415.        (string= zfile filename)
  416.        (if append
  417.  
  418.        (and
  419.         (or (not jka-compr-verify-append-file-change)
  420.         (yes-or-no-p (format "Append to file %s? " zfile)))
  421.         (setq filename zfile))
  422.  
  423.      (and
  424.       (or (not jka-compr-verify-overwrite-file-change)
  425.           (yes-or-no-p (format "Overwrite file %s? " zfile)))
  426.       (setq filename zfile)))))
  427.  
  428.     (let ((info (jka-compr-get-compression-info filename)))
  429.  
  430.       (if info
  431.  
  432.       (let ((can-append (jka-compr-info-can-append info))
  433.         (compress-program (jka-compr-info-compress-program info))
  434.         (compress-message (jka-compr-info-compress-message info))
  435.         (uncompress-program (jka-compr-info-uncompress-program info))
  436.         (uncompress-message (jka-compr-info-uncompress-message info))
  437.         (compress-args (jka-compr-info-compress-args info))
  438.         (uncompress-args (jka-compr-info-uncompress-args info))
  439.         (must-discard-stderr (jka-compr-info-compress-discard-err info))
  440.         (temp-file (make-temp-name jka-compr-temp-name-template))
  441.         cbuf temp-buffer)
  442.  
  443.         (setq cbuf (current-buffer)
  444.           temp-buffer (get-buffer-create " *jka-compr-temp*"))
  445.         (set-buffer temp-buffer)
  446.         (widen) (erase-buffer)
  447.         (set-buffer cbuf)
  448.  
  449.         (and append
  450.          (not can-append)
  451.          (file-exists-p filename)
  452.          (let* ((local-copy (file-local-copy filename))
  453.             (local-file (or local-copy filename)))
  454.  
  455.            (unwind-protect
  456.  
  457.                (progn
  458.               
  459.              (and
  460.               uncompress-message
  461.               (message "%sing %s..." uncompress-message
  462.                    (file-name-nondirectory filename)))
  463.  
  464.              (jka-compr-call-process uncompress-program
  465.                          local-file
  466.                          temp-file
  467.                          temp-buffer
  468.                          must-discard-stderr
  469.                          uncompress-args)
  470.              (and
  471.               uncompress-message
  472.               (message "%sing %s...done" uncompress-message
  473.                    (file-name-nondirectory filename))))
  474.              
  475.              (and
  476.               local-copy
  477.               (file-exists-p local-copy)
  478.               (delete-file local-copy)))))
  479.  
  480.         (and 
  481.          compress-message
  482.          (message "%sing %s..." compress-message
  483.               (file-name-nondirectory filename)))
  484.  
  485.         (write-region start end temp-file t 'dont)
  486.  
  487.         (jka-compr-call-process compress-program
  488.                     temp-file
  489.                     temp-buffer
  490.                     nil
  491.                     must-discard-stderr
  492.                     compress-args)
  493.  
  494.         (set-buffer temp-buffer)
  495.         (write-region (point-min) (point-max)
  496.               filename (and append can-append))
  497.         (erase-buffer)
  498.         (set-buffer cbuf)
  499.  
  500.         (delete-file temp-file)
  501.  
  502.         (and
  503.          compress-message
  504.          (message "%sing %s...done" compress-message
  505.               (file-name-nondirectory filename)))
  506.  
  507.         (and
  508.          (eq visit t)
  509.          (set-visited-file-name filename)
  510.          (set-visited-file-modtime))
  511.  
  512.         (and (or (eq visit t)
  513.              (eq visit nil)
  514.              (stringp visit))
  515.          (message "Wrote %s" filename))
  516.  
  517.         nil)
  518.           
  519.     (write-region start end filename append visit))))
  520.    (t
  521.     (write-region start end filename append visit))))
  522.     
  523.  
  524.  
  525. (defun jka-compr-insert-file-contents (filename &optional visit)
  526.   "Documented as original."
  527.  
  528.   (cond
  529.    (jka-compr-enabled
  530.  
  531.     (barf-if-buffer-read-only)
  532.  
  533.     (setq filename (or (jka-compr-find-compressed-version filename)
  534.                filename))
  535.  
  536.     (let ((info (jka-compr-get-compression-info filename)))
  537.  
  538.       (if info
  539.  
  540.       (let ((magic (jka-compr-info-magic info))
  541.         (uncompress-message (jka-compr-info-uncompress-message info))
  542.         (uncompress-program (jka-compr-info-uncompress-program info))
  543.         (must-discard-stderr (jka-compr-info-uncompress-discard-err info))
  544.         (uncompress-args (jka-compr-info-uncompress-args info))
  545.         (temp-file (make-temp-name jka-compr-temp-name-template))
  546.         (notfound nil)
  547.         (local-copy (file-local-copy filename))
  548.         local-file
  549.         size start)
  550.  
  551.         (setq local-file (or local-copy filename))
  552.  
  553.         (unwind-protect        ; to make sure local-copy gets deleted
  554.  
  555.         (progn
  556.           
  557.           (and
  558.            uncompress-message
  559.            (message "%sing %s..." uncompress-message
  560.                 (file-name-nondirectory filename)))
  561.  
  562.           (condition-case error-code
  563.  
  564.               (progn
  565.             (setq start (point))
  566.             (jka-compr-call-process uncompress-program
  567.                         local-file
  568.                         t
  569.                         nil
  570.                         must-discard-stderr
  571.                         uncompress-args)
  572.             (setq size (- (point) start))
  573.             (goto-char start))
  574.             
  575.             (error
  576.              (if (and (eq (car error-code) 'file-error)
  577.                   (eq (nth 3 error-code) local-file))
  578.              (if visit
  579.                  (setq notfound error-code)
  580.                (signal 'file-error 
  581.                    (cons "Openning input file"
  582.                      (nthcdr 2 error-code))))
  583.                (signal (car error-code) (cdr error-code))))))
  584.  
  585.           (and
  586.            local-copy
  587.            (file-exists-p local-copy)
  588.            (delete-file local-copy))
  589.  
  590.           (and
  591.            (file-exists-p temp-file)
  592.            (delete-file temp-file)))
  593.  
  594.                   
  595.         (and
  596.          visit
  597.          (set-visited-file-name filename)
  598.          ;; this sets the save_modified field of the buffer
  599.          (set-buffer-modified-p nil)
  600.          ;; this sets the auto_save_modified and save_length of the buffer
  601.          (set-buffer-auto-saved)
  602.          ;; set the modtime of the buffer
  603.          (set-visited-file-modtime))
  604.         
  605.         (and
  606.          uncompress-message
  607.          (message "%sing %s...done" uncompress-message
  608.               (file-name-nondirectory filename)))
  609.  
  610.         (and
  611.          visit
  612.          notfound
  613.          (signal 'file-error
  614.              (cons "Openning input file" (nth 2 notfound))))
  615.  
  616.         (list filename size))
  617.  
  618.     (insert-file-contents filename visit))))
  619.    (t
  620.     (insert-file-contents filename visit))))
  621.     
  622.  
  623.  
  624. ;;; This originally came from uncompress.el
  625. (defun jka-compr-find-compressed-version (filename)
  626.   "If FILENAME does not exist, try to find a compressed version.
  627. Return the version (extended filename) that is found.  If the file
  628. does not exist and no compressed versions are found, return nil."
  629.   (if (file-exists-p filename)
  630.       filename
  631.     (catch 'found-compressed-version
  632.       (mapcar
  633.        (function (lambda (cinfo)
  634.            (let ((extended-fname (concat filename (aref cinfo 11))))
  635.              (if (file-exists-p extended-fname)
  636.              (throw 'found-compressed-version extended-fname)))))
  637.        jka-compr-compression-info-list)
  638.       nil)))
  639.  
  640.  
  641.  
  642. ;;; There are probably many little functions like this that need to
  643. ;;; be defined.  These seem to to the job for info and rmail.
  644.  
  645. (defun jka-compr-file-readable-p (file)
  646.   "Documented as original."
  647.   (if jka-compr-enabled
  648.       (and 
  649.        (setq file (expand-file-name file))
  650.        (setq file (jka-compr-find-compressed-version file))
  651.        (file-readable-p file))
  652.     (file-readable-p file)))
  653.  
  654.  
  655. (defun jka-compr-file-writable-p (file)
  656.   "Documented as original."
  657.   (if jka-compr-enabled 
  658.       (let* ((efile (expand-file-name file))
  659.          (zfile (and efile (jka-compr-find-compressed-version efile))))
  660.     (if zfile
  661.         (file-writable-p zfile)
  662.       (file-directory-p (file-name-directory file))))
  663.     (file-writable-p file)))
  664.  
  665.  
  666. (defun jka-compr-verify-visited-file-modtime (buf)
  667.   "Documented as original."
  668.   (and
  669.    jka-compr-enabled
  670.    (not (file-exists-p (buffer-file-name buf)))
  671.    (let* ((bfile (buffer-file-name buf))
  672.       (efile (expand-file-name bfile))
  673.       (file  (and efile (jka-compr-find-compressed-version efile)))
  674.       (cbuf (current-buffer)))
  675.      
  676.      (and
  677.       (stringp file)
  678.       (not (string= file bfile))
  679.       (or (not jka-compr-verify-visited-file-change)
  680.       (yes-or-no-p
  681.        (format "Change visited file of buffer %s to %s? "
  682.            (buffer-name buf) file)))
  683.       (set-buffer buf)
  684.       (set-visited-file-name file)
  685.       (set-buffer cbuf))))
  686.   (verify-visited-file-modtime buf))
  687.  
  688.  
  689. (defun jka-compr-file-symlink-p (file)
  690.   "Documented as original."
  691.   (if jka-compr-enabled
  692.       (and
  693.        (setq file (expand-file-name file))
  694.        (setq file (jka-compr-find-compressed-version file))
  695.        (file-symlink-p file))
  696.     (file-symlink-p file)))
  697.  
  698.  
  699. (defun jka-compr-file-attributes (file)
  700.   "Documented as original."
  701.   (if jka-compr-enabled
  702.       (and
  703.        (setq file (expand-file-name file))
  704.        (setq file (jka-compr-find-compressed-version file))
  705.        (file-attributes file))
  706.     (file-attributes file)))
  707.  
  708.  
  709. (defun jka-compr-file-exists-p (file)
  710.   "Documented as original."
  711.   (and jka-compr-enabled
  712.        (let ((efile (expand-file-name file)))
  713.      (or (and efile (jka-compr-find-compressed-version efile))
  714.          (file-exists-p file)))))
  715.  
  716.  
  717. (defun jka-compr-delete-file (file)
  718.   "Documented as original."
  719.   (if jka-compr-enabled
  720.       (let (zfile)
  721.     (setq file  (expand-file-name file)
  722.           zfile (or (and file (jka-compr-find-compressed-version file))
  723.             file))
  724.     (and
  725.      (or (string= zfile file)
  726.          (not jka-compr-verify-delete-file-change)
  727.          (yes-or-no-p (format "Delete file %s? "zfile)))
  728.      (delete-file zfile)))
  729.  
  730.     (delete-file file)))
  731.  
  732.  
  733. (defun jka-compr-get-file-buffer (file)
  734.   "Documented as original."
  735.   (if jka-compr-enabled
  736.       (or
  737.        (jka-compr-real-get-file-buffer file)
  738.        (and
  739.     (setq file (expand-file-name file))
  740.     (setq file (jka-compr-find-compressed-version file))
  741.     (jka-compr-real-get-file-buffer file)))
  742.     (jka-compr-real-get-file-buffer file)))
  743.  
  744.  
  745. (defun jka-compr-file-name-sans-versions (name &optional keep-backup-version)
  746.   "Documented as original."
  747.   ;; this function assumes that the regexps in jka-compr-compression-info-list
  748.   ;; will find .z extensions even if there are backup flags or version numbers
  749.   ;; attached.
  750.   (if jka-compr-enabled
  751.       (file-name-sans-versions
  752.        (catch 'name-sans-compress-extension
  753.      (mapcar
  754.       (function (lambda (x)
  755.               (if (string-match (aref x 0) name)
  756.               (throw 'name-sans-compress-extension 
  757.                  (substring name 0 (match-beginning 0))))))
  758.       jka-compr-compression-info-list)
  759.      name)
  760.        keep-backup-version)
  761.     (file-name-sans-versions name keep-backup-version)))
  762.  
  763.  
  764. (defun jka-compr-file-local-copy (filename)
  765.   "Documented as original."
  766.  
  767.   (cond
  768.    (jka-compr-enabled
  769.  
  770.     (setq filename (or (jka-compr-find-compressed-version filename)
  771.                filename))
  772.  
  773.     (let ((info (jka-compr-get-compression-info filename)))
  774.  
  775.       (if info
  776.  
  777.       (let ((magic (jka-compr-info-magic info))
  778.         (uncompress-message (jka-compr-info-uncompress-message info))
  779.         (uncompress-program (jka-compr-info-uncompress-program info))
  780.         (must-discard-stderr (jka-compr-info-uncompress-discard-err info))
  781.         (uncompress-args (jka-compr-info-uncompress-args info))
  782.         (local-copy (file-local-copy filename))
  783.         (temp-file (make-temp-name jka-compr-temp-name-template))
  784.         (temp-buffer (get-buffer-create " *jka-compr-temp*"))
  785.         (notfound nil)
  786.         (cbuf (current-buffer))
  787.         local-file)
  788.  
  789.         (setq local-file (or local-copy filename))
  790.  
  791.         (unwind-protect
  792.  
  793.         (progn
  794.           
  795.           (and
  796.            uncompress-message
  797.            (message "%sing %s..." uncompress-message
  798.                 (file-name-nondirectory filename)))
  799.  
  800.           (set-buffer temp-buffer)
  801.           
  802.           (jka-compr-call-process uncompress-program
  803.                       local-file
  804.                       t
  805.                       nil
  806.                       must-discard-stderr
  807.                       uncompress-args)
  808.  
  809.           (and
  810.            uncompress-message
  811.            (message "%sing %s...done" uncompress-message
  812.                 (file-name-nondirectory filename)))
  813.  
  814.           (write-region (point-min) (point-max) temp-file nil 'dont))
  815.  
  816.           (and
  817.            local-copy
  818.            (file-exists-p local-copy)
  819.            (delete-file local-copy))
  820.  
  821.           (set-buffer cbuf)
  822.           (kill-buffer temp-buffer))
  823.  
  824.         temp-file)
  825.         
  826.     (file-local-copy filename))))
  827.  
  828.    (t
  829.     (file-local-copy filename))))
  830.  
  831.  
  832. ;;; Support for loading compressed files.  This was originally part of
  833. ;;; jka-compr.el.
  834.  
  835. (defvar jka-compr-lisp-file-extensions '(".elc" ".el" "")
  836.   "List of extensions to try adding to emacs lisp load files.")
  837.  
  838.  
  839. ;;; This is sort of like the openp routine in lread.c except there is
  840. ;;; no exec_only arg and the suffix arg is a list instead of a string.
  841. ;;; In fact, if the lisp code looks a little strange here its because
  842. ;;; I pretty much transliterated the C version.
  843. (defun jka-compr-openp (path str suffix)
  844.   "Duplicate the function of the openp routing in lread.c."
  845.   (catch 'result
  846.     (let ((absolute (file-name-absolute-p str))
  847.       filename suf try)
  848.       (while path
  849.     (catch 'continue
  850.       (setq filename (expand-file-name str (car path)))
  851.       (if (not (file-name-absolute-p filename))
  852.           (progn
  853.         (setq filename (expand-file-name str default-directory))
  854.         (if (not (file-name-absolute-p filename))
  855.             (throw 'continue nil))))
  856.  
  857.       (setq suf suffix)
  858.       (while suf
  859.         (setq try (concat filename (car suf)))
  860.         (and (file-readable-p try)
  861.          (not (file-directory-p try))
  862.          (throw 'result try))
  863.         (setq suf (cdr suf))))
  864.  
  865.     (if absolute
  866.         (throw 'result nil)
  867.       (setq path (cdr path)))))
  868.  
  869.     nil))
  870.       
  871.    
  872. (defun jka-compr-load (file &optional noerror nomessage nosuffix)
  873.   "Documented as original."
  874.   (unwind-protect
  875.       (progn
  876.  
  877.     (setq file-name-handler-alist
  878.           (cons jka-compr-file-name-handler-entry
  879.             file-name-handler-alist))
  880.  
  881.     (let ((filename
  882.            (jka-compr-openp load-path file 
  883.                 (if nosuffix
  884.                     (cons "" nil)
  885.                   jka-compr-lisp-file-extensions))))
  886.       (if (not filename)
  887.  
  888.           (if noerror
  889.           nil
  890.         (error "Cannot open load file %s" file))
  891.  
  892.         (let ((cbuf (current-buffer))
  893.           (lbufname (concat " *jka-load-temp:" filename))
  894.           lbuf)
  895.  
  896.           (or nomessage
  897.           (message "Loading %s..." filename))
  898.  
  899.           (unwind-protect
  900.           (progn
  901.             (setq lbuf (get-buffer lbufname))
  902.             (if lbuf
  903.             (set-buffer lbuf)
  904.               (setq lbuf (get-buffer-create lbufname))
  905.               (set-buffer lbuf)
  906.               (insert-file-contents filename))
  907.             (set-buffer cbuf)
  908.             (eval-buffer lbuf)
  909.             (let ((after (assoc file after-load-alist)))
  910.               (and
  911.                after
  912.                (apply 'progn (cdr after)))))
  913.         (and
  914.          lbuf
  915.          (kill-buffer lbuf)))
  916.  
  917.           (or nomessage
  918.           (message "Loading %s...done." filename))))))
  919.  
  920.     (setq file-name-handler-alist
  921.       (delq jka-compr-file-name-handler-entry
  922.         file-name-handler-alist))))
  923.  
  924.  
  925. (defvar jka-compr-file-name-handler-entry
  926.   (cons "" 'jka-compr-handler)
  927.   "The entry in file-name-handler-alist used by the jka-compr I/O functions.")
  928.  
  929.  
  930. (defun jka-compr-handler (operation &rest args)
  931.  
  932.   (let ((jka-op (intern-soft (symbol-name operation) jka-compr-op-table)))
  933.  
  934.     (unwind-protect
  935.     (progn
  936.       (setq file-name-handler-alist
  937.         (delq jka-compr-file-name-handler-entry
  938.               file-name-handler-alist))
  939.       (if jka-op
  940.           (apply jka-op args)
  941.         (apply operation args)))
  942.  
  943.       (setq file-name-handler-alist
  944.         (cons jka-compr-file-name-handler-entry
  945.           file-name-handler-alist)))))
  946.  
  947.   
  948. (defvar jka-compr-op-table
  949.   (make-vector 127 0))
  950.  
  951.  
  952. (defun jka-compr-intern-operation (op)
  953.   (let ((opsym (intern (symbol-name op) jka-compr-op-table))
  954.     (jka-fn (intern (concat "jka-compr-" (symbol-name op)))))
  955.     (fset opsym jka-fn)))
  956.  
  957.  
  958. (defvar jka-compr-operation-list
  959.   '(
  960.     write-region
  961.     insert-file-contents
  962.     file-readable-p
  963.     file-writable-p
  964.     file-symlink-p
  965.     file-attributes
  966.     file-exists-p
  967.     delete-file
  968.     get-file-buffer
  969.     file-name-sans-versions
  970.     verify-visited-file-modtime
  971.     file-local-copy
  972.     load
  973.     )
  974.   "List of file operations implemented by jka-compr.")
  975.  
  976.  
  977. (mapcar
  978.  (function
  979.   (lambda (fn)
  980.     (jka-compr-intern-operation fn)))
  981.  jka-compr-operation-list)
  982.  
  983.  
  984. (defun jka-compr-handler-installed ()
  985.   (let ((fnha file-name-handler-alist))
  986.     (catch 'installed
  987.       (while fnha
  988.     (and (eq (cdr (car fnha)) 'jka-compr-handler)
  989.          (throw 'installed (car fnha)))
  990.     (setq fnha (cdr fnha)))
  991.       nil)))
  992.  
  993.       
  994. ;;; Add the file I/O hook if it does not already exist.
  995. ;;; Make sure that jka-compr-file-name-handler-entry is eq to the
  996. ;;; entry for jka-compr in file-name-handler-alist.
  997. (let ((alist-entry (jka-compr-handler-installed)))
  998.   (if alist-entry
  999.       (setq jka-compr-file-name-handler-entry alist-entry)
  1000.     (setq file-name-handler-alist
  1001.       (cons jka-compr-file-name-handler-entry
  1002.         file-name-handler-alist))))
  1003.  
  1004.  
  1005. ;;; This function was lifted from ange-ftp.  I added some args to make
  1006. ;;; it a little more general. - jka
  1007. (defun jka-compr-overwrite-fn (fun saved-prefix new-prefix overwrite-msg)
  1008.   "Replace FUN's function definition with NEW-PREFIX-FUN's, saving the
  1009. original definition as SAVED-PREFIX-FUN.  The original documentation is
  1010. placed on the new definition suitably augmented.  Third arg, OVERWRITE-MSG,
  1011. is tacked on to the doc string of the new fun."
  1012.  
  1013.   (let* ((name (symbol-name fun))
  1014.      (saved (intern (concat saved-prefix name)))
  1015.      (new (intern (concat new-prefix name)))
  1016.      (nfun (symbol-function new))
  1017.      (exec-directory (if (or (equal (nth 3 command-line-args) "dump")
  1018.                  (equal (nth 4 command-line-args) "dump"))
  1019.                  "../etc/"
  1020.                exec-directory)))             
  1021.     
  1022.     (while (symbolp nfun)
  1023.       (setq nfun (symbol-function nfun)))
  1024.     
  1025.     (or (fboundp saved)
  1026.     (progn
  1027.       (fset saved (symbol-function fun))
  1028.       (fset fun new)))
  1029.     
  1030.     (let* ((doc-str (jka-compr-safe-documentation saved))
  1031.        (ndoc-str (concat doc-str (and doc-str "\n")
  1032.                  overwrite-msg)))
  1033.       
  1034.       (cond ((listp nfun)
  1035.          ;; Probe to test whether function is in preloaded read-only
  1036.          ;; memory, and if so make writable copy:
  1037.          (condition-case nil
  1038.          (setcar nfun (car nfun))
  1039.            (error
  1040.         (setq nfun (copy-sequence nfun)) ; shallow copy only
  1041.         (fset new nfun)))
  1042.          (let ((ndoc-cdr (nthcdr 2 nfun)))
  1043.            (if (stringp (car ndoc-cdr))
  1044.            ;; Replace the existing docstring.
  1045.            (setcar ndoc-cdr ndoc-str)
  1046.          ;; There is no docstring.  Insert the overwrite msg.
  1047.          (setcdr ndoc-cdr (cons (car ndoc-cdr) (cdr ndoc-cdr)))
  1048.          (setcar ndoc-cdr overwrite-msg))))
  1049.         (t
  1050.          ;; it's an emacs19 compiled-code object
  1051.          (let ((new-code (append nfun nil))) ; turn it into a list
  1052.            (if (nthcdr 4 new-code)
  1053.            (setcar (nthcdr 4 new-code) ndoc-str)
  1054.          (setcdr (nthcdr 3 new-code) (cons ndoc-str nil)))
  1055.            (fset new (apply 'make-byte-code new-code))))))))
  1056.  
  1057.  
  1058. (defun jka-compr-safe-documentation (fun)
  1059.   "A documentation function that isn't quite as fragile."
  1060.   (condition-case ()
  1061.       (documentation fun)
  1062.     (error nil)))
  1063.  
  1064.  
  1065. ;;; Still have to do get-file-buffer the old way...
  1066. (jka-compr-overwrite-fn
  1067.  'get-file-buffer
  1068.  "jka-compr-real-" "jka-compr-"
  1069.  "Note: This function has been modified to work with jka-compr.")
  1070.  
  1071.  
  1072.  
  1073. ;;; Workaround for a bug in set-visited-file-modtime.
  1074.  
  1075. (defun jka-compr-workaround-bug ()
  1076.   (defun ange-ftp-file-name-directory (name &optional AFU)
  1077.     "Documented as original."
  1078.     (let ((parsed (ange-ftp-ftp-name name)))
  1079.       (if parsed
  1080.       (let ((filename (nth 2 parsed)))
  1081.         (if (ange-ftp-save-match-data
  1082.          (string-match "^~[^/]*$" filename))
  1083.         name
  1084.           (ange-ftp-replace-name-component
  1085.            name
  1086.            (ange-ftp-real-file-name-directory filename))))
  1087.     (ange-ftp-real-file-name-directory name)))))
  1088.  
  1089. (if (fboundp 'ange-ftp-file-name-directory)
  1090.     (jka-compr-workaround-bug)
  1091.   (eval-after-load "ange-ftp" '(jka-compr-workaround-bug)))
  1092.  
  1093.  
  1094. ;;; Workaround for a bug in rename-file.
  1095.  
  1096. (defun jka-compr-rename-file (&rest args)
  1097.   "Documented as original."
  1098.   (unwind-protect
  1099.       (progn
  1100.     (setq file-name-handler-alist
  1101.           (delq jka-compr-file-name-handler-entry
  1102.             file-name-handler-alist))
  1103.     (apply 'jka-compr-real-rename-file args))
  1104.     (setq file-name-handler-alist
  1105.       (cons jka-compr-file-name-handler-entry
  1106.         file-name-handler-alist))))
  1107.  
  1108.  
  1109. (jka-compr-overwrite-fn
  1110.  'rename-file
  1111.  "jka-compr-real-" "jka-compr-"
  1112.  "Note: This function has been modified by jka-compr to work around a bug.")
  1113.  
  1114.  
  1115.  
  1116. (provide 'jka-compr)
  1117.