~ chicken-core (chicken-5) d2982b0d4b75d1f9406e1d198aaf3c1539b5a318

commit d2982b0d4b75d1f9406e1d198aaf3c1539b5a318
Author:     Peter Bex <peter@more-magic.net>
AuthorDate: Sun Jun 14 19:52:26 2015 +0200
Commit:     Evan Hanson <evhan@foldling.org>
CommitDate: Mon Jun 15 09:32:23 2015 +1200

    Fix potential buffer overrun error in string-translate*
    
    string-translate* would scan from every position in the target string
    for each source string in the map, even if that would mean scanning
    past the end.  The out-of-bounds read would be limited to the size of
    the overlapping prefix in the trailing garbage beyond the string,
    because memcmp will stop scanning as soon as there is a different
    byte in either of the memory areas.
    
    This also adds a few basic tests for string-translate*
    
    Signed-off-by: Evan Hanson <evhan@foldling.org>

diff --git a/NEWS b/NEWS
index a3393ba7..bd6df083 100644
--- a/NEWS
+++ b/NEWS
@@ -5,6 +5,7 @@
     potential select() buffer overrun.
   - CVE-2014-9651: substring-index[-ci] no longer scans beyond string
     boundaries.
+  - string-translate* no longer scans beyond string boundaries.
 
 - Core libraries
   - alist-ref from unit data-structures now gives an error when passed
diff --git a/data-structures.scm b/data-structures.scm
index b67065ee..5664d087 100644
--- a/data-structures.scm
+++ b/data-structures.scm
@@ -514,7 +514,7 @@
 (define (string-translate* str smap)
   (##sys#check-string str 'string-translate*)
   (##sys#check-list smap 'string-translate*)
-  (let ([len (##sys#size str)])
+  (let ((len (##sys#size str)))
     (define (collect i from total fs)
       (if (fx>= i len)
 	  (##sys#fragments->string
@@ -523,15 +523,16 @@
 	    (if (fx> i from) 
 		(cons (##sys#substring str from i) fs)
 		fs) ) )
-	  (let loop ([smap smap])
+	  (let loop ((smap smap))
 	    (if (null? smap) 
 		(collect (fx+ i 1) from (fx+ total 1) fs)
-		(let* ([p (car smap)]
-		       [sm (car p)]
-		       [smlen (string-length sm)]
-		       [st (cdr p)] )
-		  (if (##core#inline "C_substring_compare" str sm i 0 smlen)
-		      (let ([i2 (fx+ i smlen)])
+		(let* ((p (car smap))
+		       (sm (car p))
+		       (smlen (string-length sm))
+		       (st (cdr p)) )
+		  (if (and (fx<= (fx+ i smlen) len)
+			   (##core#inline "C_substring_compare" str sm i 0 smlen))
+		      (let ((i2 (fx+ i smlen)))
 			(when (fx> i from)
 			  (set! fs (cons (##sys#substring str from i) fs)) )
 			(collect 
diff --git a/tests/data-structures-tests.scm b/tests/data-structures-tests.scm
index 51c25a9e..b5768074 100644
--- a/tests/data-structures-tests.scm
+++ b/tests/data-structures-tests.scm
@@ -57,6 +57,17 @@
 (assert (< 0 (string-compare3-ci "foo\x00b" "foo\x00a")))
 (assert (< 0 (string-compare3-ci "foo\x00b" "foo\x00A")))
 
+(assert (string=? "bde" (string-translate* "abcd"
+					   '(("a" . "b")
+					     ("b" . "")
+					     ("c" . "d")
+					     ("d" . "e")))))
+(assert (string=? "bc" (string-translate* "abc"
+					  '(("ab" . "b")
+					    ("bc" . "WRONG")))))
+(assert (string=? "x" (string-translate* "ab" '(("ab" . "x")))))
+(assert (string=? "xy" (string-translate* "xyz" '(("z" . "")))))
+
 ;; topological-sort
 
 (assert (equal? '() (topological-sort '() eq?)))