home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / sfile.scm < prev    next >
Text File  |  2001-07-16  |  8KB  |  232 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: sfile.scm,v 14.30 2001/07/17 02:08:50 cph Exp $
  4.  
  5. Copyright (c) 1988-2001 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
  20. USA.
  21. |#
  22.  
  23. ;;;; Simple File Operations
  24. ;;; package: ()
  25.  
  26. (declare (usual-integrations))
  27.  
  28. (define (file-exists-direct? filename)
  29.   (let ((result
  30.      ((ucode-primitive file-exists-direct? 1)
  31.       (->namestring (merge-pathnames filename)))))
  32.     (if (eq? 0 result)
  33.     #t
  34.     result)))
  35.  
  36. (define (file-exists-indirect? filename)
  37.   (let ((result
  38.      ((ucode-primitive file-exists? 1)
  39.       (->namestring (merge-pathnames filename)))))
  40.     (if (eq? 0 result)
  41.     #f
  42.     result)))
  43.  
  44. (define file-exists? file-exists-indirect?)
  45.  
  46. (define file-type-direct)
  47. (define file-type-indirect)
  48. (let ((make-file-type
  49.        (lambda (procedure)
  50.      (lambda (filename)
  51.        (let ((n (procedure (->namestring (merge-pathnames filename)))))
  52.          (and n
  53.           (let ((types
  54.              '#(REGULAR
  55.                 DIRECTORY
  56.                 UNIX-SYMBOLIC-LINK
  57.                 UNIX-CHARACTER-DEVICE
  58.                 UNIX-BLOCK-DEVICE
  59.                 UNIX-NAMED-PIPE
  60.                 UNIX-SOCKET
  61.                 OS2-NAMED-PIPE
  62.                 WIN32-NAMED-PIPE)))
  63.             (if (fix:< n (vector-length types))
  64.             (vector-ref types n)
  65.             'UNKNOWN))))))))
  66.   (set! file-type-direct
  67.     (make-file-type (ucode-primitive file-type-direct 1)))
  68.   (set! file-type-indirect
  69.     (make-file-type (ucode-primitive file-type-indirect 1))))
  70.  
  71. (define (file-regular? filename)
  72.   (eq? 'REGULAR (file-type-indirect filename)))
  73.  
  74. (define (file-directory? filename)
  75.   (eq? 'DIRECTORY (file-type-indirect filename)))
  76.  
  77. (define (file-symbolic-link? filename)
  78.   ((ucode-primitive file-symlink? 1)
  79.    (->namestring (merge-pathnames filename))))
  80. (define file-soft-link? file-symbolic-link?)
  81.  
  82. (define (file-access filename amode)
  83.   ((ucode-primitive file-access 2)
  84.    (->namestring (merge-pathnames filename))
  85.    amode))
  86.  
  87. (define (file-readable? filename)
  88.   (file-access filename 4))
  89.  
  90. (define (file-writeable? filename)
  91.   ((ucode-primitive file-access 2)
  92.    (let ((pathname (merge-pathnames filename)))
  93.      (let ((filename (->namestring pathname)))
  94.        (if ((ucode-primitive file-exists? 1) filename)
  95.        filename
  96.        (directory-namestring pathname))))
  97.    2))
  98. (define file-writable? file-writeable?) ;upwards compatability
  99.  
  100. (define (file-executable? filename)
  101.   (file-access filename 1))
  102.  
  103. (define (file-touch filename)
  104.   ((ucode-primitive file-touch 1) (->namestring (merge-pathnames filename))))
  105.  
  106. (define (make-directory name)
  107.   ((ucode-primitive directory-make 1)
  108.    (->namestring (directory-pathname-as-file (merge-pathnames name)))))
  109.  
  110. (define (delete-directory name)
  111.   ((ucode-primitive directory-delete 1)
  112.    (->namestring (directory-pathname-as-file (merge-pathnames name)))))
  113.  
  114. (define (rename-file from to)
  115.   ((ucode-primitive file-rename) (->namestring (merge-pathnames from))
  116.                  (->namestring (merge-pathnames to))))
  117.  
  118. (define (delete-file filename)
  119.   ((ucode-primitive file-remove) (->namestring (merge-pathnames filename))))
  120.  
  121. (define (hard-link-file from to)
  122.   ((ucode-primitive file-link-hard 2) (->namestring (merge-pathnames from))
  123.                       (->namestring (merge-pathnames to))))
  124.  
  125. (define (soft-link-file from to)
  126.   ((ucode-primitive file-link-soft 2) (->namestring from)
  127.                       (->namestring (merge-pathnames to))))
  128.  
  129. (define (delete-file-no-errors filename)
  130.   (call-with-current-continuation
  131.    (lambda (k)
  132.      (bind-condition-handler (list condition-type:file-error
  133.                    condition-type:port-error)
  134.      (lambda (condition)
  135.        condition
  136.        (k #f))
  137.        (lambda ()
  138.      (delete-file filename)
  139.      #t)))))
  140.  
  141. (define (file-eq? x y)
  142.   ((ucode-primitive file-eq?) (->namestring (merge-pathnames x))
  143.                   (->namestring (merge-pathnames y))))
  144.  
  145. (define (current-file-time)
  146.   (call-with-temporary-file-pathname file-modification-time))
  147.  
  148. (define (directory-file-names directory #!optional include-dots?)
  149.   (let ((channel
  150.      (directory-channel-open
  151.       (->namestring (pathname-as-directory directory))))
  152.     (include-dots?
  153.      (if (default-object? include-dots?) #f include-dots?)))
  154.     (let loop ((result '()))
  155.       (let ((name (directory-channel-read channel)))
  156.     (if name
  157.         (loop
  158.          (if (and (not include-dots?)
  159.               (or (string=? "." name)
  160.               (string=? ".." name)))
  161.          result
  162.          (cons name result)))
  163.         (begin
  164.           (directory-channel-close channel)
  165.           result))))))
  166.  
  167. (define (call-with-temporary-filename receiver)
  168.   (call-with-temporary-file-pathname
  169.    (lambda (pathname)
  170.      (receiver (->namestring pathname)))))
  171.  
  172. (define (call-with-temporary-file-pathname receiver)
  173.   (let ((pathname (temporary-file-pathname)))
  174.     (dynamic-wind
  175.      (lambda () unspecific)
  176.      (lambda () (receiver pathname))
  177.      (lambda () (deallocate-temporary-file pathname)))))
  178.  
  179. (define (allocate-temporary-file pathname)
  180.   (and (not (file-exists? pathname))
  181.        (let ((objects (get-fixed-objects-vector))
  182.          (slot (fixed-objects-vector-slot 'FILES-TO-DELETE))
  183.          (filename (->namestring pathname)))
  184.      (without-interrupts
  185.       (lambda ()
  186.         (and (file-touch pathname)
  187.          (begin
  188.            (vector-set! objects slot
  189.                 (cons filename (vector-ref objects slot)))
  190.            ((ucode-primitive set-fixed-objects-vector! 1) objects)
  191.            #t)))))))
  192.  
  193. (define (deallocate-temporary-file pathname)
  194.   (delete-file-no-errors pathname)
  195.   (let ((objects (get-fixed-objects-vector))
  196.     (slot (fixed-objects-vector-slot 'FILES-TO-DELETE))
  197.     (filename (->namestring pathname)))
  198.     (without-interrupts
  199.      (lambda ()
  200.        (vector-set! objects slot
  201.             (delete! filename (vector-ref objects slot)))
  202.        ((ucode-primitive set-fixed-objects-vector! 1) objects)))))
  203.  
  204. (define (guarantee-init-file-specifier object procedure)
  205.   (if (not (init-file-specifier? object))
  206.       (error:wrong-type-argument object "init-file specifier" procedure)))
  207.  
  208. (define (init-file-specifier? object)
  209.   (and (list? object)
  210.        (for-all? object
  211.      (lambda (object)
  212.        (and (string? object)
  213.         (not (string-null? object)))))))
  214.  
  215. (define (guarantee-init-file-directory pathname)
  216.   (let ((directory (user-homedir-pathname)))
  217.     (if (not (file-directory? directory))
  218.     (error "Home directory doesn't exist:" directory)))
  219.   (let loop ((pathname pathname))
  220.     (let ((directory (directory-pathname pathname)))
  221.       (if (not (file-directory? directory))
  222.       (begin
  223.         (loop (directory-pathname-as-file directory))
  224.         (make-directory directory))))))
  225.  
  226. (define (open-input-init-file specifier)
  227.   (open-input-file (init-file-specifier->pathname specifier)))
  228.  
  229. (define (open-output-init-file specifier #!optional append?)
  230.   (let ((pathname (init-file-specifier->pathname specifier)))
  231.     (guarantee-init-file-directory pathname)
  232.     (open-output-file pathname (if (default-object? append?) #f append?))))