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

53
scheme/lib/ftp.scm
View File

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