scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

- fix handling of multi-line replies 

- redo FTP-MODIFICATION-TIME and FTP-PWD without regexps
This commit is contained in:
sperber 2003-01-16 10:01:28 +00:00
parent 1a0099230c
commit 697ed851b8
1 changed files with 28 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
scheme/lib/ftp.scm
View File

@ -164,9 +164,13 @@
;;: on success return the new directory as a string
(define (ftp-pwd connection)
(let* ((reply (ftp-send-command connection "PWD")) ; 257
(match (string-match "[0-9][0-9][0-9] \"(.*)\" " (or reply ""))))
(match:substring match 1)))
(let ((reply (ftp-send-command connection "PWD" (exactly-code "257"))))
(cond
((regexp-search (rx (seq bos (= 3 digit) #\space
(* (~ #\")) #\" (submatch (* (~ #\"))) #\"))
reply)
=> (lambda (match)
(match:substring match 1))))))
;;: connection x string -> status
(define (ftp-rmdir connection dir)
@ -183,9 +187,7 @@
(define (ftp-modification-time connection file)
(let* ((reply (ftp-send-command connection
(format #f "MDTM ~a" file)))
(match (string-match "[0-9][0-9][0-9] ([0-9]+)" (or reply "")))
(timestr (and match (match:substring match 1))))
(and timestr
(timestr (substring reply 4 (string-length reply))))
(let ((year (substring timestr 0 4))
(month (substring timestr 4 6))
(mday (substring timestr 6 8))
@ -197,7 +199,7 @@
(string->number hour)
(string->number mday)
(string->number month)
(- (string->number year) 1900))))))
(- (string->number year) 1900)))))
;; On success return the size of the file in bytes.
;;: connection x string -> integer
@ -431,13 +433,14 @@
(signal 'ftp-error reply))
;; handle multi-line replies
(if (char=? (string-ref reply 3) #\-)
(let ((end-prefix (string-append code " ")))
(let loop ()
(let* ((line (read-crlf-line IN))
(reply (string-join (list reply line "\n"))))
(ftp-log connection (format #f "-> ~a" line))
(if (string-prefix? code line)
(if (string-prefix? end-prefix line)
reply
(loop code reply))))
(loop)))))
reply))))
(define (ftp-build-command-string str . opt-args)