From a6d953b6f5943579cb5f95b986647b8ea61c147f Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 11 Nov 2008 17:55:14 +0000
Subject: [PATCH] add port->string, file->string, etc.

svn: r12388
---
 collects/mzlib/port.ss                        |  21 ++--
 collects/scheme/file.ss                       | 105 +++++++++++++++++-
 collects/scheme/port.ss                       |  36 +++++-
 collects/scheme/private/portlines.ss          |  24 ++++
 .../scribblings/reference/filesystem.scrbl    |  76 +++++++++++++
 collects/scribblings/reference/port-lib.scrbl |  38 ++++++-
 collects/tests/mzscheme/filelib.ss            |  48 +++++++-
 collects/tests/mzscheme/portlib.ss            |  26 ++++-
 doc/release-notes/mzscheme/HISTORY.txt        |   5 +
 9 files changed, 363 insertions(+), 16 deletions(-)
 create mode 100644 collects/scheme/private/portlines.ss

diff --git a/collects/mzlib/port.ss b/collects/mzlib/port.ss
index 16a04f0a34..f3a165787e 100644
--- a/collects/mzlib/port.ss
+++ b/collects/mzlib/port.ss
@@ -44,20 +44,21 @@
 	(let ([c (read-bytes-avail! s src)])
 	  (cond
 	   [(number? c)
-	    (for-each
-	     (lambda (dest)
-	       (let loop ([start 0])
-		 (unless (= start c)
-		   (let ([c2 (write-bytes-avail s dest start c)])
-		     (loop (+ start c2))))))
-	     dests)
+            (let loop ([dests dests])
+              (unless (null? dests)
+                (let loop ([start 0])
+                  (unless (= start c)
+                    (let ([c2 (write-bytes-avail s (car dests) start c)])
+                      (loop (+ start c2)))))
+                (loop (cdr dests))))
 	    (loop)]
 	   [(procedure? c)
 	    (let ([v (let-values ([(l col p) (port-next-location src)])
 		       (c (object-name src) l col p))])
-	      (for-each
-	       (lambda (dest) (write-special v dest))
-	       dests))
+              (let loop ([dests dests])
+                (unless (null? dests)
+                  (write-special v (car dests))
+                  (loop (cdr dests)))))
 	    (loop)]
 	   [else
 	    ;; Must be EOF
diff --git a/collects/scheme/file.ss b/collects/scheme/file.ss
index fd4afe1283..fd670562d4 100644
--- a/collects/scheme/file.ss
+++ b/collects/scheme/file.ss
@@ -10,7 +10,18 @@
 
          fold-files
          find-files
-         pathlist-closure)
+         pathlist-closure
+
+         file->string
+         file->bytes
+         file->value
+         file->lines
+         file->bytes-lines
+         display-to-file
+         write-to-file
+         display-list-to-file)
+
+(require "private/portlines.ss")
 
 ;; utility: sorted dirlist so functions are deterministic
 (define (sorted-dirlist [dir (current-directory)])
@@ -331,3 +342,95 @@
                 (loop2 base (if (or (member base r) (member base paths))
                                 new (cons base new)))
                 (loop (cdr paths) (append (reverse new) r))))))))
+
+(define (check-path who f)
+  (unless (path-string? f)
+    (raise-type-error who "path string" f)))
+
+(define (check-file-mode who file-mode)
+  (unless (memq file-mode '(binary text))
+    (raise-type-error who "'binary or 'text" file-mode)))
+
+(define (file->x who f file-mode read-x x-append)
+  (check-path who f)
+  (check-file-mode who file-mode)
+  (let ([sz (file-size f)])
+    (call-with-input-file* 
+     f 
+     #:mode file-mode
+     (lambda (in)
+       ;; There's a good chance that `file-size' gets all the data:
+       (let ([s (read-x sz in)])
+         ;; ... but double-check:
+         (let ([more (let loop ()
+                       (let ([l (read-x 4096 in)])
+                         (if (eof-object? l)
+                             null
+                             (cons l (loop)))))])
+           (if (null? more)
+               s
+               (apply x-append (cons s more)))))))))
+
+(define (file->string f #:mode [mode 'binary])
+  (file->x 'file->string f mode read-string string-append))
+
+(define (file->bytes f #:mode [mode 'binary])
+  (file->x 'file->bytes f mode read-bytes bytes-append))
+
+(define (file->value f #:mode [file-mode 'binary])
+  (check-path 'file->value f)
+  (check-file-mode 'file->value file-mode)
+  (let ([sz (file-size f)])
+    (call-with-input-file* 
+     f 
+     #:mode file-mode
+     read)))
+
+(define (file->x-lines who f line-mode file-mode read-line)
+  (check-path who f)
+  (check-mode who line-mode)
+  (check-file-mode who file-mode)
+  (call-with-input-file* 
+   f 
+   #:mode file-mode
+   (lambda (p) (port->x-lines who p line-mode read-line))))
+
+(define (file->lines f #:line-mode [line-mode 'any] #:mode [file-mode 'binary])
+  (file->x-lines 'file->lines f line-mode file-mode read-line))
+
+(define (file->bytes-lines f #:line-mode [line-mode 'any] #:mode [file-mode 'binary])
+  (file->x-lines 'file->bytes-lines f line-mode file-mode read-bytes-line))
+
+(define (->file who f mode exists write)
+  (unless (path-string? f)
+    (raise-type-error who "path string" f))
+  (unless (memq mode '(binary text))
+    (raise-type-error who "'binary or 'text" mode))
+  (unless (memq exists '(error append update replace truncate truncate/replace))
+    (raise-type-error who "'error, 'append, 'update, 'replace, 'truncate, or 'truncate/replace" exists))
+  (call-with-output-file* 
+   f
+   #:mode mode
+   #:exists exists
+   write))
+
+(define (display-to-file s f 
+                         #:mode [mode 'binary]
+                         #:exists [exists 'error])
+  (->file 'display-to-file f mode exists (lambda (p) (display s p))))
+
+(define (write-to-file s f 
+                      #:mode [mode 'binary]
+                      #:exists [exists 'error])
+  (->file 'write-to-file f mode exists (lambda (p) (write s p))))
+
+(define (display-list-to-file l f 
+                    #:mode [mode 'binary]
+                    #:exists [exists 'error]
+                    #:separator [newline #"\n"])
+  (unless (list? l)
+    (raise-type-error 'display-list-to-file "list" l))
+  (->file 'display-list-to-file f mode exists
+          (lambda (p)
+            (do-lines->port l p newline))))
+
diff --git a/collects/scheme/port.ss b/collects/scheme/port.ss
index 375a262f0d..30a4f85e8b 100644
--- a/collects/scheme/port.ss
+++ b/collects/scheme/port.ss
@@ -1,5 +1,37 @@
 
 (module port scheme/base
-  (require mzlib/port)
+  (require mzlib/port
+           "private/portlines.ss")
   (provide (except-out (all-from-out mzlib/port)
-                       strip-shell-command-start)))
+                       strip-shell-command-start)
+           port->string
+           port->bytes
+           port->lines
+           port->bytes-lines
+           display-list)
+
+  (define (port->string-port who p)
+    (unless (input-port? p)
+      (raise-type-error who "input-port" p))
+    (let ([s (open-output-string)])
+      (copy-port p s)
+      s))
+
+  (define (port->string [p (current-input-port)])
+    (get-output-string (port->string-port 'port->string p)))
+
+  (define (port->bytes [p (current-input-port)])
+    (get-output-bytes (port->string-port 'port->bytes p) #t))
+
+  (define (port->lines [p (current-input-port)] #:line-mode [mode 'any])
+    (port->x-lines 'port->lines p mode read-line))
+  
+  (define (port->bytes-lines [p (current-input-port)] #:line-mode [mode 'any])
+    (port->x-lines 'port->bytes-lines p mode read-bytes-line))
+
+  (define (display-list l [p (current-output-port)] #:separator [newline #"\n"])
+    (unless (list? l)
+      (raise-type-error 'display-list "list" l))
+    (unless (output-port? p)
+      (raise-type-error 'display-list "output-port" p))
+    (do-lines->port l p newline)))
diff --git a/collects/scheme/private/portlines.ss b/collects/scheme/private/portlines.ss
new file mode 100644
index 0000000000..9c5fcde121
--- /dev/null
+++ b/collects/scheme/private/portlines.ss
@@ -0,0 +1,24 @@
+#lang scheme/base
+
+(provide port->x-lines
+         check-mode
+         do-lines->port)
+
+(define (check-mode who mode)
+  (unless (memq mode '(linefeed return return-linefeed any any-one))
+    (raise-type-error who "'linefeed, 'return, 'return-linefeed, 'any, or 'any-one" mode)))
+
+(define (port->x-lines who p mode read-line)
+  (unless (input-port? p)
+    (raise-type-error who "input-port" p))
+  (check-mode who mode)
+  (let loop ([l null])
+    (let ([line (read-line p mode)])
+      (if (eof-object? line)
+          (reverse l)
+          (loop (cons line l))))))
+
+(define (do-lines->port l p newline)
+  (for ([i (in-list l)])
+    (display i p)
+    (display newline p)))
diff --git a/collects/scribblings/reference/filesystem.scrbl b/collects/scribblings/reference/filesystem.scrbl
index cdfa08e679..8c2583f1b6 100644
--- a/collects/scribblings/reference/filesystem.scrbl
+++ b/collects/scribblings/reference/filesystem.scrbl
@@ -536,6 +536,82 @@ module path.}
 
 @note-lib[scheme/file]
 
+@defproc[(file->string [path path-string?]
+                       [#:mode mode-flag (or/c 'binary 'text) 'binary])
+         string?]{
+
+Reads all characters from @scheme[path] and returns them as a string.
+The @scheme[mode-flag] argument is the same as for
+@scheme[open-input-file].}
+ 
+@defproc[(file->bytes [path path-string?]
+                      [#:mode mode-flag (or/c 'binary 'text) 'binary])
+         bytes?]{
+
+Reads all characters from @scheme[path] and returns them as a
+@tech{byte string}.  The @scheme[mode-flag] argument is the same as
+for @scheme[open-input-file].}
+
+@defproc[(file->lines [path path-string?]
+                      [#:mode mode-flag (or/c 'binary 'text) 'binary]
+                      [#:line-mode line-mode (or/c 'linefeed 'return 'return-linefeed 'any 'any-one) 'any])
+         bytes?]{
+
+Read all characters from @scheme[path], breaking them into lines. The
+@scheme[line-mode] argument is the same as the second argument to
+@scheme[read-line], but the default is @scheme['any] instead of
+@scheme['linefeed]. The @scheme[mode-flag] argument is the same as for
+@scheme[open-input-file].}
+
+@defproc[(file->value [path path-string?]
+                      [#:mode mode-flag (or/c 'binary 'text) 'binary])
+         bytes?]{
+
+Reads a single S-expression from @scheme[path] using @scheme[read].
+The @scheme[mode-flag] argument is the same as for
+@scheme[open-input-file].}
+
+@defproc[(file->bytes-lines [path path-string?]
+                      [#:mode mode-flag (or/c 'binary 'text) 'binary]
+                      [#:line-mode line-mode (or/c 'linefeed 'return 'return-linefeed 'any 'any-one) 'any])
+         bytes?]{
+
+Like @scheme[file->lines], but reading bytes and collecting them into
+lines like @scheme[read-bytes-line].}
+
+@defproc[(display-to-file [v any/c]
+                          [path path-string?]
+                      [#:mode mode-flag (or/c 'binary 'text) 'binary]
+                      [#:exists exists-flag (or/c 'error 'append 'update
+                                                  'replace 'truncate 'truncate/replace) 'error])
+         void?]{
+
+Uses @scheme[display] to print each @scheme[v] to @scheme[path]. The @scheme[mode-flag] and
+@scheme[exists-flag] arguments are the same as for
+@scheme[open-output-file].}
+
+@defproc[(write-to-file [v any/c]
+                        [path path-string?]
+                      [#:mode mode-flag (or/c 'binary 'text) 'binary]
+                      [#:exists exists-flag (or/c 'error 'append 'update
+                                                  'replace 'truncate 'truncate/replace) 'error])
+         void?]{
+
+Like @scheme[display-to-file], but using @scheme[write] instead of @scheme[display].}
+
+@defproc[(display-list-to-file [lst list?]
+                       [path path-string?]
+                       [#:separator separator any/c #"\n"]
+                       [#:mode mode-flag (or/c 'binary 'text) 'binary]
+                       [#:exists exists-flag (or/c 'error 'append 'update
+                                                   'replace 'truncate 'truncate/replace) 'error])
+         void?]{
+
+Displays each element of @scheme[lst] to @scheme[path], adding
+@scheme[separator] after each element. The @scheme[mode-flag] and
+@scheme[exists-flag] arguments are the same as for
+@scheme[open-output-file].}
+
 @defproc[(copy-directory/files [src path-string?][dest path-string?]) 
          void?]{
 
diff --git a/collects/scribblings/reference/port-lib.scrbl b/collects/scribblings/reference/port-lib.scrbl
index f3afc7d61d..104b9792c0 100644
--- a/collects/scribblings/reference/port-lib.scrbl
+++ b/collects/scribblings/reference/port-lib.scrbl
@@ -2,12 +2,48 @@
 @(require "mz.ss"
           (for-label scheme/port))
 
-@title{More Port Constructors and Events}
+@title[#:tag "port-lib"]{More Port Constructors, Procedures, and Events}
 
 @note-lib-only[scheme/port]
 
 @; ----------------------------------------------------------------------
 
+@section{Port String and List Conversions}
+
+@defproc[(port->string [in input-port? (current-input-port)]) string?]{
+
+Reads all characters from @scheme[in] and returns them as a string.}
+
+@defproc[(port->bytes [in input-port? (current-input-port)]) bytes?]{
+
+Reads all bytes from @scheme[in] and returns them as a @tech{byte string}.}
+
+@defproc[(port->lines [in input-port? (current-input-port)]
+                      [#:line-mode line-mode (or/c 'linefeed 'return 'return-linefeed 'any 'any-one) 'any])
+         (listof string?)]{
+
+Read all characters from @scheme[in], breaking them into lines. The
+@scheme[line-mode] argument is the same as the second argument to
+@scheme[read-line], but the default is @scheme['any] instead of
+@scheme['linefeed].}
+
+@defproc[(port->bytes-lines [in input-port? (current-input-port)]
+                            [#:line-mode line-mode (or/c 'linefeed 'return 'return-linefeed 'any 'any-one) 'any])
+         (listof bytes?)]{
+
+Like @scheme[port->lines], but reading bytes and collecting them into
+lines like @scheme[read-bytes-line].}
+
+@defproc[(display-list [lst list?]
+                       [out output-port? (current-output-port)]
+                       [#:separator separator any/c #"\n"])
+         void?]{
+
+Use @scheme[display] to each each element of @scheme[lst] to @scheme[out], adding
+@scheme[separator] after each element.}
+
+@; ----------------------------------------------------------------------
+
 @section{Creating Ports}
 
 @defproc[(input-port-append [close-at-eof? any/c][in input-port?] ...) input-port?]{
diff --git a/collects/tests/mzscheme/filelib.ss b/collects/tests/mzscheme/filelib.ss
index b3c35102ff..1fcb9f456b 100644
--- a/collects/tests/mzscheme/filelib.ss
+++ b/collects/tests/mzscheme/filelib.ss
@@ -3,10 +3,56 @@
 
 (Section 'file)
 
-(require mzlib/file
+(require scheme/file
 	 mzlib/process
 	 mzlib/list)
 
+(define tmp-name "tmp0-filelib")
+(when (file-exists? tmp-name) (delete-file tmp-name))
+(display-list-to-file '("a" "b" "c") tmp-name #:separator #"\r\n" #:mode 'binary)
+(test "a\r\nb\r\nc\r\n" file->string tmp-name #:mode 'binary)
+(test #"a\r\nb\r\nc\r\n" file->bytes tmp-name)
+(test '("a" "b" "c") file->lines tmp-name)
+(test '(#"a" #"b" #"c") file->bytes-lines tmp-name)
+(test '("a" "b" "c") file->lines tmp-name #:line-mode 'any #:mode 'binary)
+(test '(#"a" #"b" #"c") file->bytes-lines tmp-name #:line-mode 'any #:mode 'text)
+(err/rt-test (display-to-file #"a\nb" tmp-name) exn:fail:filesystem:exists?)
+(display-to-file #"a\nb" tmp-name #:exists 'truncate)
+(test #"a\nb" file->bytes tmp-name)
+(display-to-file "\u03BB" tmp-name #:exists 'truncate)
+(test #"\316\273" file->bytes tmp-name)
+(write-to-file "\u03BB" tmp-name #:exists 'truncate)
+(test #"\"\316\273\"" file->bytes tmp-name)
+(test "\u03BB" file->value tmp-name)
+(define tmp-name "tmp0-filelib")
+
+(define-syntax-rule (err/rt-chk-test (op arg ...))
+  (err/rt-test (op arg ...) (check-msg 'op)))
+(define (check-msg op)
+  (lambda (exn)
+    (regexp-match (format "^~a: " op) (exn-message exn))))
+(err/rt-chk-test (file->string 'x))
+(err/rt-chk-test (file->bytes 'x))
+(err/rt-chk-test (file->string "x" #:mode 'other))
+(err/rt-chk-test (file->bytes "x" #:mode 'other))
+(err/rt-chk-test (file->value "x" #:mode 'other))
+(err/rt-chk-test (display-list-to-file 10 "x"))
+(err/rt-chk-test (display-list-to-file '(10) "x" #:mode 'other))
+(err/rt-chk-test (display-list-to-file '(10) "x" #:exists 'other))
+(err/rt-chk-test (file->lines "x" #:line-mode 'junk))
+(err/rt-chk-test (file->lines "x" #:mode 'other))
+(err/rt-chk-test (file->bytes-lines "x" #:line-mode 'junk))
+(err/rt-chk-test (file->bytes-lines "x" #:mode 'other))
+(err/rt-chk-test (display-to-file "y" "x" #:exists 'other))
+(err/rt-chk-test (display-to-file "y" "x" #:mode 'other))
+(err/rt-chk-test (write-to-file #"y" "x" #:exists 'other))
+(err/rt-chk-test (write-to-file #"y" "x" #:mode 'other))
+(err/rt-chk-test (display-list-to-file 'y "x"))
+(err/rt-chk-test (display-list-to-file '(y) "x" #:exists 'other))
+(err/rt-chk-test (display-list-to-file '(y) "x" #:mode 'other))
+
+;; ----------------------------------------
+
 (parameterize ([current-directory (current-load-relative-directory)])
   (let ([rel (find-files values)]
 	[abs (find-files values (current-directory))])
diff --git a/collects/tests/mzscheme/portlib.ss b/collects/tests/mzscheme/portlib.ss
index fcb099c29d..5e7fcf2113 100644
--- a/collects/tests/mzscheme/portlib.ss
+++ b/collects/tests/mzscheme/portlib.ss
@@ -5,7 +5,31 @@
 
 (define SLEEP-TIME 0.1)
 
-(require mzlib/port)
+(require scheme/port)
+
+;; ----------------------------------------
+
+(let* ([p (lambda () (open-input-string "hello\r\nthere"))])
+  (test "hello\r\nthere" port->string (p))
+  (test #"hello\r\nthere" port->bytes (p))
+  (test '("hello" "there") port->lines (p))
+  (test '(#"hello" #"there") port->bytes-lines (p))
+  (test '("hello\r" "there") port->lines (p) #:line-mode 'linefeed)
+  (test '(#"hello\r" #"there") port->bytes-lines (p) #:line-mode 'linefeed)
+  (test '("hello" "" "there") port->lines (p) #:line-mode 'any-one)
+  (test '(#"hello" #"" #"there") port->bytes-lines (p) #:line-mode 'any-one))
+
+(let* ([x (make-string 50000 #\x)]
+       [p (lambda () (open-input-string x))])
+  (test (string-length x) 'long-string (string-length (port->string (p))))
+  (test (string-length x) 'long-string (bytes-length (port->bytes (p)))))
+
+(let ([p (open-output-bytes)])
+  (display-list '(1 2 3) p)
+  (test "1\n2\n3\n" get-output-string p))
+(let ([p (open-output-bytes)])
+  (display-list '(1 2 3) p #:separator #"!!")
+  (test "1!!2!!3!!" get-output-string p))
 
 ;; ----------------------------------------
 
diff --git a/doc/release-notes/mzscheme/HISTORY.txt b/doc/release-notes/mzscheme/HISTORY.txt
index 2418a038b8..e09618f5a5 100644
--- a/doc/release-notes/mzscheme/HISTORY.txt
+++ b/doc/release-notes/mzscheme/HISTORY.txt
@@ -1,5 +1,10 @@
 Version 4.1.2.4
 Added call-with-immediate-continuation-mark
+In scheme/port: added port->string, port->bytes, port->lines
+   port->bytes-lines, and display-list
+In scheme/file: added file->string, file->bytes, file->lines,
+   file->bytes-lines, write-to-file, display-to-file, 
+   and display-list-to-file
 
 Version 4.1.2.3
 Added variable-reference? and empty #%variable-reference form