diff --git a/scheme/lib/ftp.scm b/scheme/lib/ftp.scm index c05c8d7..ea19f4a 100644 --- a/scheme/lib/ftp.scm +++ b/scheme/lib/ftp.scm @@ -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,21 +187,19 @@ (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 - (let ((year (substring timestr 0 4)) - (month (substring timestr 4 6)) - (mday (substring timestr 6 8)) - (hour (substring timestr 8 10)) - (min (substring timestr 10 12)) - (sec (substring timestr 12 14))) - (make-date (string->number sec) - (string->number min) - (string->number hour) - (string->number mday) - (string->number month) - (- (string->number year) 1900)))))) + (timestr (substring reply 4 (string-length reply)))) + (let ((year (substring timestr 0 4)) + (month (substring timestr 4 6)) + (mday (substring timestr 6 8)) + (hour (substring timestr 8 10)) + (min (substring timestr 10 12)) + (sec (substring timestr 12 14))) + (make-date (string->number sec) + (string->number min) + (string->number hour) + (string->number mday) + (string->number month) + (- (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 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) - reply - (loop code reply)))) + (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? end-prefix line) + reply + (loop))))) reply)))) (define (ftp-build-command-string str . opt-args)