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 / fileio.scm < prev    next >
Text File  |  2001-03-15  |  8KB  |  246 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: fileio.scm,v 1.19 2001/03/15 21:12:47 cph Exp $
  4.  
  5. Copyright (c) 1991-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
  20. 02111-1307, USA.
  21. |#
  22.  
  23. ;;;; File I/O Ports
  24. ;;; package: (runtime file-i/o-port)
  25.  
  26. (declare (usual-integrations))
  27.  
  28. (define (initialize-package!)
  29.   (let ((input-operations
  30.      `((LENGTH ,operation/length)
  31.        (REST->STRING ,operation/rest->string)))
  32.     (other-operations
  33.      `((WRITE-SELF ,operation/write-self)
  34.        (PATHNAME ,operation/pathname)
  35.        (TRUENAME ,operation/truename))))
  36.     (set! input-file-type
  37.       (make-port-type (append input-operations other-operations)
  38.               generic-input-type))
  39.     (set! output-file-type
  40.       (make-port-type other-operations
  41.               generic-output-type))
  42.     (set! i/o-file-type
  43.       (make-port-type (append input-operations other-operations)
  44.               generic-i/o-type)))
  45.   unspecific)
  46.  
  47. (define input-file-type)
  48. (define output-file-type)
  49. (define i/o-file-type)
  50.  
  51. (define input-buffer-size 512)
  52. (define output-buffer-size 512)
  53.  
  54. (define (open-input-file filename)
  55.   (let* ((pathname (merge-pathnames filename))
  56.      (channel (file-open-input-channel (->namestring pathname)))
  57.      (port
  58.       (make-port
  59.        input-file-type
  60.        (make-file-state
  61.         (make-input-buffer channel
  62.                    input-buffer-size
  63.                    (pathname-newline-translation pathname))
  64.         #f
  65.         pathname))))
  66.     (set-channel-port! channel port)
  67.     port))
  68.  
  69. (define (open-output-file filename #!optional append?)
  70.   (let* ((pathname (merge-pathnames filename))
  71.      (channel
  72.       (let ((filename (->namestring pathname)))
  73.         (if (and (not (default-object? append?)) append?)
  74.         (file-open-append-channel filename)
  75.         (file-open-output-channel filename))))
  76.      (port
  77.       (make-port
  78.        output-file-type
  79.        (make-file-state
  80.         #f
  81.         (make-output-buffer channel
  82.                 output-buffer-size
  83.                 (pathname-newline-translation pathname))
  84.         pathname))))
  85.     (set-channel-port! channel port)
  86.     port))
  87.  
  88. (define (open-i/o-file filename)
  89.   (let* ((pathname (merge-pathnames filename))
  90.      (channel (file-open-io-channel (->namestring pathname)))
  91.      (translation (pathname-newline-translation pathname))
  92.      (port
  93.       (make-port
  94.        i/o-file-type
  95.        (make-file-state
  96.         (make-input-buffer channel input-buffer-size translation)
  97.         (make-output-buffer channel output-buffer-size translation)
  98.         pathname))))
  99.     (set-channel-port! channel port)
  100.     port))
  101.  
  102. (define (pathname-newline-translation pathname)
  103.   (let ((end-of-line (pathname-end-of-line-string pathname)))
  104.     (and (not (string=? "\n" end-of-line))
  105.      end-of-line)))
  106.  
  107. (define (open-binary-input-file filename)
  108.   (let* ((pathname (merge-pathnames filename))
  109.      (channel (file-open-input-channel (->namestring pathname)))
  110.      (port
  111.       (make-port input-file-type
  112.              (make-file-state (make-input-buffer channel
  113.                              input-buffer-size
  114.                              #f)
  115.                       #f
  116.                       pathname))))
  117.     (set-channel-port! channel port)
  118.     port))
  119.  
  120. (define (open-binary-output-file filename #!optional append?)
  121.   (let* ((pathname (merge-pathnames filename))
  122.      (channel
  123.       (let ((filename (->namestring pathname)))
  124.         (if (and (not (default-object? append?)) append?)
  125.         (file-open-append-channel filename)
  126.         (file-open-output-channel filename))))
  127.      (port
  128.       (make-port output-file-type
  129.              (make-file-state #f
  130.                       (make-output-buffer channel
  131.                               output-buffer-size
  132.                               #f)
  133.                       pathname))))
  134.     (set-channel-port! channel port)
  135.     port))
  136.  
  137. (define (open-binary-i/o-file filename)
  138.   (let* ((pathname (merge-pathnames filename))
  139.      (channel (file-open-io-channel (->namestring pathname)))
  140.      (port
  141.       (make-port i/o-file-type
  142.              (make-file-state (make-input-buffer channel
  143.                              input-buffer-size
  144.                              #f)
  145.                       (make-output-buffer channel
  146.                               output-buffer-size
  147.                               #f)
  148.                       pathname))))
  149.     (set-channel-port! channel port)
  150.     port))
  151.  
  152. (define ((make-call-with-file open) input-specifier receiver)
  153.   (let ((port (open input-specifier)))
  154.     (let ((value (receiver port)))
  155.       (close-port port)
  156.       value)))
  157.  
  158. (define call-with-input-file 
  159.   (make-call-with-file open-input-file))
  160.  
  161. (define call-with-binary-input-file
  162.   (make-call-with-file open-binary-input-file))
  163.  
  164. (define call-with-output-file
  165.   (make-call-with-file open-output-file))
  166.  
  167. (define call-with-binary-output-file
  168.   (make-call-with-file open-binary-output-file))
  169.  
  170. (define call-with-append-file
  171.   (make-call-with-file (lambda (filename) (open-output-file filename #t))))
  172.  
  173. (define call-with-binary-append-file
  174.   (make-call-with-file
  175.    (lambda (filename) (open-binary-output-file filename #t))))
  176.  
  177. (define ((make-with-input-from-file call) input-specifier thunk)
  178.   (call input-specifier
  179.     (lambda (port)
  180.       (with-input-from-port port thunk))))
  181.  
  182. (define with-input-from-file
  183.   (make-with-input-from-file call-with-input-file))
  184.  
  185. (define with-input-from-binary-file
  186.   (make-with-input-from-file call-with-binary-input-file))
  187.  
  188. (define ((make-with-output-to-file call) output-specifier thunk)
  189.   (call output-specifier
  190.     (lambda (port)
  191.       (with-output-to-port port thunk))))
  192.  
  193. (define with-output-to-file
  194.   (make-with-output-to-file call-with-output-file))
  195.  
  196. (define with-output-to-binary-file
  197.   (make-with-output-to-file call-with-binary-output-file))
  198.  
  199. (define-structure (file-state (type vector)
  200.                   (conc-name file-state/))
  201.   ;; First two elements of this vector are required by the generic
  202.   ;; I/O port operations.
  203.   (input-buffer #f read-only #t)
  204.   (output-buffer #f read-only #t)
  205.   (pathname #f read-only #t))
  206.  
  207. (define (operation/length port)
  208.   (channel-file-length (port/input-channel port)))
  209.  
  210. (define (operation/pathname port)
  211.   (file-state/pathname (port/state port)))
  212.  
  213. (define operation/truename
  214.   ;; This works for unix because truename and pathname are the same.
  215.   ;; On operating system where they differ, there must be support to
  216.   ;; determine the truename.
  217.   operation/pathname)
  218.  
  219. (define (operation/write-self port output-port)
  220.   (write-string " for file: " output-port)
  221.   (write (operation/truename port) output-port))
  222.  
  223. (define (operation/rest->string port)
  224.   ;; This operation's intended purpose is to snarf an entire file in
  225.   ;; a single gulp, exactly what a text editor would need.
  226.   (let ((buffer (file-state/input-buffer (port/state port))))
  227.     (let ((remaining (input-buffer/chars-remaining buffer))
  228.       (fill-buffer
  229.        (lambda (string)
  230.          (let ((length (string-length string)))
  231.            (let loop ()
  232.          (or (input-buffer/read-substring buffer string 0 length)
  233.              (loop)))))))
  234.       (if remaining
  235.       (let ((result (make-string remaining)))
  236.         (let ((n (fill-buffer result)))
  237.           (if (fix:< n remaining)
  238.           (substring result 0 n)
  239.           result)))
  240.       (let loop ((strings '()))
  241.         (let ((string (make-string input-buffer-size)))
  242.           (let ((n (fill-buffer string)))
  243.         (if (fix:< n input-buffer-size)
  244.             (apply string-append
  245.                (reverse! (cons (substring string 0 n) strings)))
  246.             (loop (cons string strings))))))))))