From d07bf7beae6a8fc4e6be6bebc7fc73a34e7c5b31 Mon Sep 17 00:00:00 2001
From: sperber <sperber>
Date: Thu, 16 Jan 2003 10:51:40 +0000
Subject: [PATCH] Revamp FTP-GET, FTP-PUT, and FTP-APPEND: always take remote
 file name as argument and an ACT procedure which acts on the data
 input/output port.

---
 scheme/lib/ftp.scm | 91 +++++++++++++---------------------------------
 1 file changed, 25 insertions(+), 66 deletions(-)

diff --git a/scheme/lib/ftp.scm b/scheme/lib/ftp.scm
index 928db66..fdff509 100644
--- a/scheme/lib/ftp.scm
+++ b/scheme/lib/ftp.scm
@@ -267,43 +267,22 @@
 
 (define (port->lines port)
   (let loop ((reverse-lines '()))
-    (let ((line (rread-crlf-line port)))
+    (let ((line (read-crlf-line port)))
       (if (eof-object? line)
 	  (reverse reverse-lines)
 	  (loop (cons line reverse-lines))))))
 
-
-;; maybe-local may be a filename to which the data should be written,
-;; or #t to write data to stdout (to current-output-port to be more
-;; precise), or #f to stuff the data in a string (which is returned),
-;; or nothing to output to a local file with the same name as the
-;; remote file.
-;;: connection x string [x string | #t | #f] -> status | string
-(define (ftp-get connection remote-file . maybe-local)
-  (let* ((sock (ftp-open-data-connection connection))
-         (local (if (pair? maybe-local)
-                    (car maybe-local)
-                    'empty))
-         (out (cond ((string? local) (open-output-file local))
-                    ((eq? local #t) (current-output-port))
-                    ((eq? local #f) (make-string-output-port))
-                    (else
-                     (open-output-file remote-file)))))
+(define (ftp-get connection remote-file act)
+  (let* ((sock (ftp-open-data-connection connection)))
     (ftp-send-command connection
-                      (format #f "RETR ~a" remote-file)
+		      (ftp-build-command-string "RETR" remote-file)
                       (exactly-code "150"))
     (receive (newsock newsockaddr)
 	(accept-connection sock)
-      (with-current-output-port out
-				(dump (socket:inport newsock)))
+      (act (socket:inport newsock))
       (close-socket newsock)
       (close-socket sock)
-      (let ((status (ftp-read-reply connection)))
-	(if (string? local) (close out))
-	(if (eq? local #f)
-	    (string-output-port-output out)
-	    status)))))
-
+      (ftp-read-reply connection))))
 
 ;; FIXME: should have an optional argument :rename which defaults to
 ;; false, which would make us upload to a temporary name and rename at
@@ -311,43 +290,25 @@
 ;; servers which are serving a load, and to avoid problems with "no
 ;; space on device".
 
-;; optional argument maybe-remote-file is the name under which we wish
-;; the file to appear on the remote machine. If omitted the file takes
-;; the same name on the FTP server as on the local host.
-;;: connection x string [ x string ] -> status
-(define (ftp-put connection local-file . maybe-remote-file)
-  (let-optionals* maybe-remote-file ((remote-file #f))
-    (let* ((sock (ftp-open-data-connection connection))
-	   (IN (open-input-file local-file))
-	   (cmd (format #f "STOR ~a" (or remote-file local-file))))
-      (ftp-send-command connection cmd (exactly-code "150"))
-      (receive (newsock newsockaddr)
-	  (accept-connection sock)
-	(with-current-output-port (socket:outport newsock) (dump IN))
-	(close (socket:outport newsock)) ; send the server EOF
-	(close-socket newsock)
-	(let ((status (ftp-read-reply connection)))
-	  (close IN)
-	  (close-socket sock)
-	  status)))))
+(define (ftp-put connection remote-file act)
+  (let ((sock (ftp-open-data-connection connection)))
+    (ftp-send-command connection (ftp-build-command-string "STOR" remote-file)
+		      (exactly-code "150"))
+    (receive (newsock newsockaddr)
+	(accept-connection sock)
+      (act (socket:outport newsock))
+      (close-socket newsock)
+      (close-socket sock))))
 
-;;: connection x string [x string] -> status
-(define (ftp-append connection local-file . maybe-remote-file)
-  (let-optionals* maybe-remote-file ((remote-file #f))
-    (let* ((sock (ftp-open-data-connection connection))
-	   (IN (open-input-file local-file))
-	   (cmd (format #f "APPE ~a" (or remote-file local-file))))
-      (ftp-send-command connection cmd (exactly-code "150"))
-      (receive (newsock newsockaddr)
-	  (accept-connection sock)
-	(with-current-output-port (socket:outport newsock)
-				  (dump IN))
-	(close (socket:outport newsock)) ; send the server EOF
-	(close-socket newsock)
-	(let ((status (ftp-read-reply connection)))
-	  (close IN)
-	  (close-socket sock)
-	  status)))))
+(define (ftp-append connection remote-file act)
+  (let ((sock (ftp-open-data-connection connection)))
+    (ftp-send-command connection (ftp-build-command-string "APPE" remote-file)
+		      (exactly-code "150"))
+    (receive (newsock newsockaddr)
+	(accept-connection sock)
+      (act (socket:outport newsock))
+      (close-socket newsock)
+      (close-socket sock))))
 
 ;; send a command verbatim to the remote server and wait for a
 ;; reply.
@@ -452,9 +413,7 @@
 	  reply))))
 
 (define (ftp-build-command-string str . opt-args)
-  (if (string? opt-args)
-      (string-join (list str arg))
-      str))
+  (string-join (cons str opt-args)))
 
 (define (ftp-log connection line)
   (let ((LOG (ftp-connection-logfd connection)))