Replace remaining uses of FORMAT.

This commit is contained in:
sperber 2003-01-16 12:45:55 +00:00
parent 1f0bd725cf
commit 2ebb8d0e0f
1 changed files with 28 additions and 28 deletions

View File

@ -49,10 +49,6 @@
;; * Unix-specific commands such as SITE UMASK, SITE CHMOD
;; * object-based interface? (like SICP message passing)
;; * improved error handling
;; * a lot of the calls to format could be replaced by calls to
;; string-join. Maybe format is easier to read?
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Communication is initiated by the client. The server responds to
@ -110,8 +106,9 @@
passive?
log)))
(ftp-log connection
(format #f "~%-- ~a: opened ftp connection to ~a"
(string-append "-- "
(date->string (date))
": opened ftp connection to "
hostname))
(ftp-read-reply connection (exactly-code "220")) ; the initial welcome banner
(ftp-login connection login password)
@ -134,14 +131,14 @@
(netrc-lookup-login (get-netrc-record)
(ftp-connection-host-name connection)))))
(let ((reply
(ftp-send-command connection (ftp-build-command-string "USER" login)
(ftp-send-command connection (build-command "USER" login)
(lambda (code)
(or (string=? code "331") ; "User name okay, need password."
(string=? code "230")))))) ; "User logged in, proceed."
(if (string-prefix? "331" reply) ; "User name okay, need password."
(ftp-send-command connection
(ftp-build-command-string
(build-command
"PASS"
(or password
(netrc-lookup-password (get-netrc-record)
@ -151,7 +148,7 @@
;; Type must be one of 'binary or 'text or 'ascii, or a string which will be
;; sent verbatim
;;: connection x symbol|string -> status
(define (ftp-type connection type)
(let ((ttype (cond
((string? type) type)
@ -161,20 +158,23 @@
(else
(call-error "type must be one of 'binary or 'text or 'ascii"
ftp-type type)))))
(ftp-send-command connection (format #f "TYPE ~a" ttype))))
(ftp-send-command connection (build-command "TYPE" ttype))))
;;: connection x string x string -> status
(define (ftp-rename connection oldname newname)
(ftp-send-command connection (format #f "RNFR ~a" oldname) (code-with-prefix "35"))
(ftp-send-command connection (format #f "RNTO ~a" newname) (code-with-prefix "25")))
(ftp-send-command connection (build-command "RNFR " oldname)
(code-with-prefix "35"))
(ftp-send-command connection (build-command "RNTO" newname)
(code-with-prefix "25")))
;;: connection x string -> status
(define (ftp-delete connection file)
(ftp-send-command connection (format #f "DELE ~a" file) (code-with-prefix "25")))
(ftp-send-command connection (build-command "DELE" file)
(code-with-prefix "25")))
;;: connection x string -> status
(define (ftp-cd connection dir)
(ftp-send-command connection (format #f "CWD ~a" dir)))
(ftp-send-command connection (build-command "CWD" dir)))
;;: connection -> status
(define (ftp-cdup connection)
@ -193,11 +193,11 @@
;;: connection x string -> status
(define (ftp-rmdir connection dir)
(ftp-send-command connection (format #f "RMD ~a" dir)))
(ftp-send-command connection (build-command "RMD " dir)))
;;: connection x string -> status
(define (ftp-mkdir connection dir)
(ftp-send-command connection (format #f "MKD ~a" dir)))
(ftp-send-command connection (build-command "MKD ~a" dir)))
;; On success return a Scsh date record. This message is not part of
;; rfc959 but seems to be supported by many ftp servers (it's useful
@ -205,7 +205,7 @@
;;: connection x string -> date
(define (ftp-modification-time connection file)
(let* ((reply (ftp-send-command connection
(format #f "MDTM ~a" file)))
(build-command "MDTM" file)))
(timestr (substring reply 4 (string-length reply))))
(let ((year (substring timestr 0 4))
(month (substring timestr 4 6))
@ -224,7 +224,7 @@
;;: connection x string -> integer
(define (ftp-size connection file)
(let* ((reply (ftp-send-command connection
(format #f "SIZE ~a" file))))
(build-command "SIZE" file))))
(string->number (substring reply
4 (string-length reply)))))
@ -260,7 +260,7 @@
(define (ftp-ls connection . maybe-dir)
(let* ((sock (ftp-open-data-connection connection)))
(ftp-send-command connection
(apply ftp-build-command-string "NLST" maybe-dir)
(apply build-command "NLST" maybe-dir)
(code-with-prefix "1"))
(receive (newsock newsockaddr)
(accept-connection sock)
@ -274,7 +274,7 @@
(define (ftp-dir connection . maybe-dir)
(let* ((sock (ftp-open-data-connection connection)))
(ftp-send-command connection
(apply ftp-build-command-string "LIST" maybe-dir)
(apply build-command "LIST" maybe-dir)
(code-with-prefix "1"))
(receive (newsock newsockaddr)
(accept-connection sock)
@ -294,7 +294,7 @@
(define (ftp-get connection remote-file act)
(let* ((sock (ftp-open-data-connection connection)))
(ftp-send-command connection
(ftp-build-command-string "RETR" remote-file)
(build-command "RETR" remote-file)
(exactly-code "150"))
(receive (newsock newsockaddr)
(accept-connection sock)
@ -311,7 +311,7 @@
(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)
(ftp-send-command connection (build-command "STOR" remote-file)
(exactly-code "150"))
(receive (newsock newsockaddr)
(accept-connection sock)
@ -321,7 +321,7 @@
(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)
(ftp-send-command connection (build-command "APPE" remote-file)
(exactly-code "150"))
(receive (newsock newsockaddr)
(accept-connection sock)
@ -392,7 +392,7 @@
(out (socket:outport sock)))
(write-string command out)
(write-crlf out)
(ftp-log connection (format #f "<- ~a" command))
(ftp-log connection (string-append "<- " command))
(apply ftp-read-reply connection maybe-expected)))
(define any-code (lambda (code) #t))
@ -415,7 +415,7 @@
(in (socket:inport sock))
(reply (read-crlf-line in))
(code (substring reply 0 3)))
(ftp-log connection (format #f "-> ~a" reply))
(ftp-log connection (string-append "-> " reply))
(if (not (expected? code))
(signal 'ftp-error reply))
;; handle multi-line replies
@ -424,13 +424,13 @@
(let loop ()
(let* ((line (read-crlf-line in))
(reply (string-join (list reply line "\n"))))
(ftp-log connection (format #f "-> ~a" line))
(ftp-log connection (string-append "-> " line))
(if (string-prefix? end-prefix line)
reply
(loop)))))
reply))))
(define (ftp-build-command-string str . opt-args)
(define (build-command str . opt-args)
(string-join (cons str opt-args)))
(define (ftp-log connection line)