~ chicken-core (chicken-5) 002ea4128f8b04c7e6d63b6b7a2bdbcd957b785b
commit 002ea4128f8b04c7e6d63b6b7a2bdbcd957b785b
Author: Peter Bex <peter.bex@xs4all.nl>
AuthorDate: Sun Feb 3 18:51:26 2013 +0100
Commit: Christian Kellermann <ckeen@pestilenz.org>
CommitDate: Thu Feb 14 16:17:26 2013 +0100
Implement fix for #568 by making ##sys#scan-buffer-line aware of the edge case. Invert data fetching logic to prevent having to put all this complicated stuff in the read-line handler of each port type.
The hacky workaround for chicken-install introduced by 2a2656cacadd3791c11d24b57742c1b37370a24c is reverted.
Signed-off-by: Christian Kellermann <ckeen@pestilenz.org>
diff --git a/NEWS b/NEWS
index 3397b2e3..226cc735 100644
--- a/NEWS
+++ b/NEWS
@@ -4,6 +4,8 @@
- csc: added "-oi"/"-ot" options as alternatives to "-emit-inline-file"
and "-emit-type-file", respectively; "-n" has been deprecated.
+- Core libraries
+ - read-line no longer returns trailing CRs in rare cases on TCP ports (#568)
4.8.1
diff --git a/library.scm b/library.scm
index 3cabd3d1..c53c884b 100644
--- a/library.scm
+++ b/library.scm
@@ -3545,17 +3545,13 @@ EOF
(end (if limit (fx+ pos limit) size)))
(if (fx>= pos size)
#!eof
- (##sys#scan-buffer-line
- buf
- (if (fx> end size) size end)
- pos
- (lambda (pos2 next)
- (when (not (eq? pos2 next))
- (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1)) )
- (let ((dest (##sys#make-string (fx- pos2 pos))))
- (##core#inline "C_substring_copy" buf dest pos pos2 0)
- (##sys#setislot p 10 next)
- dest) ) ) ) ) )
+ (receive (next line)
+ (##sys#scan-buffer-line
+ buf (if (fx> end size) size end) pos
+ (lambda (pos) (values #f pos #f) ) )
+ (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1)) ; lineno
+ (##sys#setislot p 10 next)
+ line) ) ) )
(lambda (p) ; read-buffered
(let ((pos (##sys#slot p 10))
(string (##sys#slot p 12))
@@ -3567,18 +3563,47 @@ EOF
buffered))))
)))
-; Invokes the eol handler when EOL or EOS is reached.
-(define (##sys#scan-buffer-line buf limit pos k)
- (let loop ((pos2 pos))
- (if (fx>= pos2 limit)
- (k pos2 pos2)
- (let ((c (##core#inline "C_subchar" buf pos2)))
- (cond ((eq? c #\newline) (k pos2 (fx+ pos2 1)))
- ((and (eq? c #\return)
- (fx> limit (fx+ pos2 1))
- (eq? (##core#inline "C_subchar" buf (fx+ pos2 1)) #\newline) )
- (k pos2 (fx+ pos2 2)) )
- (else (loop (fx+ pos2 1))) ) ) ) ) )
+;; Invokes the eos handler when EOS is reached to get more data.
+;; The eos-handler is responsible for stopping, either when EOF is hit or
+;; a user-supplied limit is reached (ie, it's indistinguishable from EOF)
+(define (##sys#scan-buffer-line buf limit start-pos eos-handler)
+ (define (copy&append buf offset pos old-line)
+ (let* ((old-line-len (##sys#size old-line))
+ (new-line (##sys#make-string (fx+ old-line-len (fx- pos offset)))))
+ (##core#inline "C_substring_copy" old-line new-line 0 old-line-len 0)
+ (##core#inline "C_substring_copy" buf new-line offset pos old-line-len)
+ new-line))
+ (let loop ((buf buf)
+ (offset start-pos)
+ (pos start-pos)
+ (limit limit)
+ (line ""))
+ (if (fx= pos limit)
+ (let ((line (copy&append buf offset pos line)))
+ (receive (buf offset limit) (eos-handler pos)
+ (if buf
+ (loop buf offset offset limit line)
+ (values offset line))))
+ (let ((c (##core#inline "C_subchar" buf pos)))
+ (cond ((eq? c #\newline)
+ (values (fx+ pos 1) (copy&append buf offset pos line)))
+ ((and (eq? c #\return) ; \r\n -> drop \r from string
+ (fx> limit (fx+ pos 1))
+ (eq? (##core#inline "C_subchar" buf (fx+ pos 1)) #\newline))
+ (values (fx+ pos 2) (copy&append buf offset pos line)))
+ ((and (eq? c #\return) ; Edge case (#568): \r{read}[\n|xyz]
+ (fx= limit (fx+ pos 1)))
+ (let ((line (copy&append buf offset pos line)))
+ (receive (buf offset limit) (eos-handler pos)
+ (if buf
+ (if (eq? (##core#inline "C_subchar" buf offset) #\newline)
+ (values (fx+ offset 1) line)
+ ;; "Restore" \r we didn't copy, loop w/ new string
+ (loop buf offset offset limit
+ (##sys#string-append line "\r")))
+ ;; Restore \r here, too (when we reached EOF)
+ (values offset (##sys#string-append line "\r"))))))
+ (else (loop buf offset (fx+ pos 1) limit line)) ) ) ) ) )
(define (open-input-string string)
(##sys#check-string string 'open-input-string)
diff --git a/posixunix.scm b/posixunix.scm
index 9de549fb..251c400d 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -1384,40 +1384,31 @@ EOF
m
(loop n m start) ) ] ) ) )
(lambda (port limit) ; read-line
- (let loop ([str #f])
- (let ([bumper
- (lambda (cur ptr)
- (let* ([cnt (fx- cur bufpos)]
- [dest
- (if (eq? 0 cnt)
- (or str "")
- (let ([dest (##sys#make-string cnt)])
- (##core#inline "C_substring_copy"
- buf dest bufpos cur 0)
- (##sys#setislot port 5
- (fx+ (##sys#slot port 5) cnt))
- (if str
- (##sys#string-append str dest)
- dest ) ) ) ] )
- (set! bufpos ptr)
- (cond [(eq? cur ptr) ; no EOL encountered
- (fetch)
- (values dest (fx< bufpos buflen)) ]
- [else ; at EOL
- (##sys#setislot port 4 (fx+ (##sys#slot port 4) 1))
- (##sys#setislot port 5 0)
- (values dest #f) ] ) ) ) ] )
- (cond [(fx< bufpos buflen)
- (let-values ([(dest cont?)
- (##sys#scan-buffer-line buf buflen bufpos bumper)])
- (if cont?
- (loop dest)
- dest ) ) ]
- [else
- (fetch)
- (if (fx< bufpos buflen)
- (loop str)
- #!eof) ] ) ) ) )
+ (when (fx>= bufpos buflen)
+ (fetch))
+ (if (fx>= bufpos buflen)
+ #!eof
+ (let ((limit (or limit (##sys#fudge 21))))
+ (receive (next line)
+ (##sys#scan-buffer-line
+ buf
+ (fxmin buflen (fx+ bufpos limit))
+ bufpos
+ (lambda (pos)
+ (let ((nbytes (fx- pos bufpos)))
+ (cond ((fx>= nbytes limit)
+ (values #f pos #f))
+ (else
+ (set! limit (fx- limit nbytes))
+ (fetch)
+ (if (fx< bufpos buflen)
+ (values buf bufpos
+ (fxmin buflen
+ (fx+ bufpos limit)))
+ (values #f bufpos #f)))))))
+ (##sys#setislot port 4 (fx+ (##sys#slot port 4) 1))
+ (set! bufpos next)
+ line)) ) )
(lambda (port) ; read-buffered
(if (fx>= bufpos buflen)
""
diff --git a/setup-download.scm b/setup-download.scm
index 449de815..5267b22a 100644
--- a/setup-download.scm
+++ b/setup-download.scm
@@ -402,10 +402,7 @@
(define (read-chunks in)
(let get-chunks ([data '()])
- (let* ((szln (read-line in))
- ;;XXX workaround for "read-line" dropping the "\n" in certain situations
- ;; (#568)
- (size (string->number (string-chomp szln "\r") 16)))
+ (let ((size (string->number (read-line in) 16)))
(cond ((not size)
(error "invalid response from server - please try again"))
((zero? size)
diff --git a/tcp.scm b/tcp.scm
index 5072adff..d0657a4b 100644
--- a/tcp.scm
+++ b/tcp.scm
@@ -429,34 +429,30 @@ EOF
m
(loop n m start) ) ) ) ) )
(lambda (p limit) ; read-line
- (let loop ((str #f)
- (limit (or limit (##sys#fudge 21))))
- (cond ((fx< bufindex buflen)
- (##sys#scan-buffer-line
- buf
- (fxmin buflen limit)
- bufindex
- (lambda (pos2 next)
- (let* ((len (fx- pos2 bufindex))
- (dest (##sys#make-string len)))
- (##core#inline "C_substring_copy" buf dest bufindex pos2 0)
- (set! bufindex next)
- (cond ((eq? pos2 limit) ; no line-terminator, hit limit
- (if str (##sys#string-append str dest) dest))
- ((eq? pos2 next) ; no line-terminator, hit buflen
- (read-input)
- (if (fx>= bufindex buflen)
- (or str "")
- (loop (if str (##sys#string-append str dest) dest)
- (fx- limit len)) ) )
- (else
- (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))
- (if str (##sys#string-append str dest) dest)) ) ) ) ) )
- (else
- (read-input)
- (if (fx< bufindex buflen)
- (loop str limit)
- #!eof) ) ) ) )
+ (when (fx>= bufindex buflen)
+ (read-input))
+ (if (fx>= bufindex buflen)
+ #!eof
+ (let ((limit (or limit (##sys#fudge 21))))
+ (receive (next line)
+ (##sys#scan-buffer-line
+ buf
+ (fxmin buflen (fx+ bufindex limit))
+ bufindex
+ (lambda (pos)
+ (let ((nbytes (fx- pos bufindex)))
+ (cond ((fx>= nbytes limit)
+ (values #f pos #f))
+ (else (read-input)
+ (set! limit (fx- limit nbytes))
+ (if (fx< bufindex buflen)
+ (values buf bufindex
+ (fxmin buflen
+ (fx+ bufindex limit)))
+ (values #f bufindex #f))))) ) )
+ (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1)) ; lineno
+ (set! bufindex next)
+ line) )) )
(lambda (p) ; read-buffered
(if (fx>= bufindex buflen)
""
Trap