Replace remaining uses of FORMAT.
This commit is contained in:
sperber
parent
1f0bd725cf
commit
2ebb8d0e0f
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue