From 230eed2745ea2b57de3c9073e8596892b1da2d8c Mon Sep 17 00:00:00 2001
From: Moritz Heidkamp <address@hidden>
Date: Sun, 14 Dec 2014 23:33:52 +0100
Subject: [PATCH] Fix buffer overrun in substring-index[-ci]

When passing a start index greater than 0, substring-index[-ci] would
scan past the end of the subject string, leading to bogus results in
case the substring is accidentally run into beyond the end of the
subject. This patch fixes the issue and also adds a range check for the
start index.
---
 data-structures.scm             | 22 ++++++++++++++--------
 tests/data-structures-tests.scm | 11 ++++++++++-
 2 files changed, 24 insertions(+), 9 deletions(-)

diff --git a/data-structures.scm b/data-structures.scm
index a94c163..511a3c1 100644
--- a/data-structures.scm
+++ b/data-structures.scm
@@ -307,15 +307,21 @@
   (define (traverse which where start test loc)
     (##sys#check-string which loc)
     (##sys#check-string where loc)
-    (let ([wherelen (##sys#size where)]
-	  [whichlen (##sys#size which)] )
+    (let* ((wherelen (##sys#size where))
+	   (whichlen (##sys#size which))
+	   (end (fx- wherelen whichlen)))
       (##sys#check-exact start loc)
-      (let loop ([istart start] [iend whichlen])
-	(cond [(fx> iend wherelen) #f]
-	      [(test istart whichlen) istart]
-	      [else 
-	       (loop (fx+ istart 1)
-		     (fx+ iend 1) ) ] ) ) ) )
+      (if (and (fx>= start 0)
+	       (fx> wherelen start))
+	  (let loop ((istart start))
+	    (cond ((fx> istart end) #f)
+		  ((test istart whichlen) istart)
+		  (else (loop (fx+ istart 1)))))
+	  (##sys#error-hook (foreign-value "C_OUT_OF_RANGE_ERROR" int)
+			    loc
+			    start
+			    wherelen))))
+
   (set! ##sys#substring-index 
     (lambda (which where start)
       (traverse 
diff --git a/tests/data-structures-tests.scm b/tests/data-structures-tests.scm
index 51c25a9..34ccb2f 100644
--- a/tests/data-structures-tests.scm
+++ b/tests/data-structures-tests.scm
@@ -1,6 +1,6 @@
 ;;;; data-structures-tests.scm
 
-(use data-structures)
+(use data-structures lolevel)
 
 (define-syntax assert-error
   (syntax-rules ()
@@ -57,6 +57,15 @@
 (assert (< 0 (string-compare3-ci "foo\x00b" "foo\x00a")))
 (assert (< 0 (string-compare3-ci "foo\x00b" "foo\x00A")))
 
+
+;; This used to fail because substring-index and co. used to search
+;; beyond the end of the subject string when a start index > 0 was
+;; provided. We use object-evict to ensure that the strings are placed
+;; in adjacent memory ranges so we can detect this error.
+(let* ((foo (object-evict (make-string 32 #\x)))
+       (bar (object-evict "y")))
+  (assert (not (substring-index "y" foo 30))))
+
 ;; topological-sort
 
 (assert (equal? '() (topological-sort '() eq?)))
-- 
2.1.3