Rewrite reply code testing with predicates instead of regexps.

scheme/lib/ftp.scm

@@ -108,7 +108,7 @@
 	       (format #f "~%-- ~a: opened ftp connection to ~a"
 		       (date->string (date))
 		       hostname))
-      (ftp-read-reply connection "220") ; the initial welcome banner
+      (ftp-read-reply connection (exactly-code "220")) ; the initial welcome banner
       connection)))
 
 ;; Send user information to the remote host. Args are optional login
@@ -127,8 +127,8 @@
 					     (ftp-connection-host-name connection))))
     (set-ftp-connection-login! connection login)
     (set-ftp-connection-password! connection password)
-    (ftp-send-command connection (format #f "USER ~a" login) "...")  ; "331"
+    (ftp-send-command connection (format #f "USER ~a" login) any-code)  ; "331"
-    (ftp-send-command connection (format #f "PASS ~a" password) "2..")))) ; "230"
+    (ftp-send-command connection (format #f "PASS ~a" password))))) ; "230"
 
 ;; Type must be one of 'binary or 'text or 'ascii, or a string which will be
 ;; sent verbatim
@@ -146,12 +146,12 @@
 
 ;;: connection x string x string -> status
 (define (ftp-rename connection oldname newname)
-  (ftp-send-command connection (format #f "RNFR ~a" oldname) "35.")
+  (ftp-send-command connection (format #f "RNFR ~a" oldname) (code-with-prefix "35"))
-  (ftp-send-command connection (format #f "RNTO ~a" newname) "25."))
+  (ftp-send-command connection (format #f "RNTO ~a" newname) (code-with-prefix "25")))
 
 ;;: connection x string -> status
 (define (ftp-delete connection file)
-  (ftp-send-command connection (format #f "DELE ~a" file) "25."))
+  (ftp-send-command connection (format #f "DELE ~a" file) (code-with-prefix "25")))
 
 ;;: connection x string -> status
 (define (ftp-cd connection dir)
@@ -159,12 +159,12 @@
 
 ;;: connection -> status
 (define (ftp-cdup connection)
-  (ftp-send-command connection "CDUP" "250"))
+  (ftp-send-command connection "CDUP" (exactly-code "250")))
 
 
 ;;: on success return the new directory as a string
 (define (ftp-pwd connection)
-  (let* ((reply (ftp-send-command connection "PWD" "2..")) ;  257
+  (let* ((reply (ftp-send-command connection "PWD")) ;  257
          (match (string-match "[0-9][0-9][0-9] \"(.*)\" " (or reply ""))))
     (match:substring match 1)))
 
@@ -203,8 +203,7 @@
 ;;: connection x string -> integer
 (define (ftp-size connection file)
   (let* ((reply (ftp-send-command connection
-				  (format #f "SIZE ~a" file)
+				  (format #f "SIZE ~a" file))))
-				  "2..")))
     (and (string? reply)
          (string->number (substring reply
                                     4 (- (string-length reply) 1))))))
@@ -217,7 +216,7 @@
 
 ;;: connection -> status
 (define (ftp-quit connection)
-  (ftp-send-command connection "QUIT" "221")
+  (ftp-send-command connection "QUIT" (exactly-code "221"))
   (close-socket (ftp-connection-command-socket connection)))
 
 
@@ -242,26 +241,26 @@
   (let* ((sock (ftp-open-data-connection connection)))
     (ftp-send-command connection
                       (ftp-build-command-string "NLST" maybe-dir)
-                      "1..")
+                      (code-with-prefix "1"))
     (receive (newsock newsockaddr)
 	(accept-connection sock)
       (dump (socket:inport newsock))
       (close-socket newsock)
       (close-socket sock)
-      (ftp-read-reply connection "2.."))))
+      (ftp-read-reply connection))))
 
 ;;: connection [ x string ] -> status
 (define (ftp-dir connection . maybe-dir)
   (let* ((sock (ftp-open-data-connection connection)))
     (ftp-send-command connection
                       (ftp-build-command-string "LIST" maybe-dir)
-                      "1..")
+                      (code-with-prefix "1"))
     (receive (newsock newsockaddr)
 	(accept-connection sock)
       (dump (socket:inport newsock))
       (close-socket newsock)
       (close-socket sock)
-      (ftp-read-reply connection "2.."))))
+      (ftp-read-reply connection))))
 
 
 ;; maybe-local may be a filename to which the data should be written,
@@ -282,14 +281,14 @@
                      (open-output-file remote-file)))))
     (ftp-send-command connection
                       (format #f "RETR ~a" remote-file)
-                      "150")
+                      (exactly-code "150"))
     (receive (newsock newsockaddr)
 	(accept-connection sock)
       (with-current-output-port OUT
 				(dump (socket:inport newsock)))
       (close-socket newsock)
       (close-socket sock)
-      (let ((status (ftp-read-reply connection "2..")))
+      (let ((status (ftp-read-reply connection)))
 	(if (string? local) (close OUT))
 	(if (eq? local #f)
 	    (string-output-port-output OUT)
@@ -311,13 +310,13 @@
     (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 "150")
+      (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 "2..")))
+	(let ((status (ftp-read-reply connection)))
 	  (close IN)
 	  (close-socket sock)
 	  status)))))
@@ -328,14 +327,14 @@
     (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 "150")
+      (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 "2..")))
+	(let ((status (ftp-read-reply connection)))
 	  (close IN)
 	  (close-socket sock)
 	  status)))))
@@ -400,44 +399,46 @@
 		     (format-port srvc-port)))))
 
 (define (ftp-send-command connection command . maybe-expected)
-  (let-optionals* maybe-expected ((expected "2.."))
   (let* ((sock (ftp-connection-command-socket connection))
 	 (OUT (socket:outport sock)))
     (write-string command OUT)
     (write-crlf OUT)
     (ftp-log connection (format #f "<- ~a" command))
-      (ftp-read-reply connection expected))))
+    (apply ftp-read-reply connection maybe-expected)))
 
+(define any-code (lambda (code) #t))
+(define (code-with-prefix prefix)
+  (lambda (code)
+    (string-prefix? prefix code)))
+(define (exactly-code the-code)
+  (lambda (code)
+    (string=? code the-code)))
 
 ;; This is where we check that the server's 3 digit status code
-;; corresponds to what we expected. EXPECTED is a string of the form
+;; corresponds to what we expected.
-;; "250", which indicates we are expecting a 250 code from the server,
+
-;; or "2.." which means that we only require the first digit to be 2
+;; EXPECTED? is a predicate on reply codes.  If the server's reply
-;; and don't care about the rest. If the server's reply doesn't
+;; doesn't satisfy EXPECTED?, we raise an FTP-ERROR.
-;; match EXPECTED, we raise an ftp-error (which is catchable; look at
+
-;; pop3.scm to see how). Since this is implemented as a regexp, you
-;; can also specify more complicated acceptable replies of the form
-;; "2[4-6][0-9]". The code permits you to match the server's verbose
-;; message too, but beware that the messages change from server to
-;; server.
 (define (ftp-read-reply connection . maybe-expected)
-  (let-optionals* maybe-expected ((expected "2.."))
+  (let-optionals* maybe-expected ((expected? (code-with-prefix "2")))
     (let* ((sock (ftp-connection-command-socket connection))
 	   (IN (socket:inport sock))
-	   (reply (read-crlf-line IN)))
+	   (reply (read-crlf-line IN))
+	   (code (substring reply 0 3)))
       (ftp-log connection (format #f "-> ~a" reply))
-      (or (string-match expected reply)
+      (if (not (expected? code))
 	  (signal 'ftp-error reply))
       ;; handle multi-line replies
-      (if (equal? (string-ref reply 3) #\-)
+      (if (char=? (string-ref reply 3) #\-)
-	  (let loop ((code (string-append (substring reply 0 3) " "))
+	  (let loop ()
-		     (line (read-crlf-line IN)))
+	    (let* ((line (read-crlf-line IN))
+		  (reply (string-join (list reply line "\n"))))
 	      (ftp-log connection (format #f "-> ~a" line))
-	    (set! reply (string-join (list reply line "\n")))
+	      (if (string-prefix? code line)
-	    (or (string-match code line)
+		  reply
-		(loop code (read-crlf-line IN)))))
+		  (loop code reply))))
-      reply)))
+	  reply))))
-
 
 (define (ftp-build-command-string str . opt-args)
   (if (string? opt-args)

scheme/packages.scm

@@ -409,7 +409,7 @@
         handle
         conditions
         signals
-	(subset srfi-13 (string-join))
+	(subset srfi-13 (string-join string-prefix?))
 	let-opt
 	sunet-utilities
 	format-net