From a0cee2b6812330e4c021473ceb4eaf11ac87ba80 Mon Sep 17 00:00:00 2001
From: apnadkarni <apnmbx-wits@yahoo.com>
Date: Sat, 29 Jul 2023 05:56:10 +0000
Subject: Add tests for out of bounds Tcl_ListObjIndex

---
 generic/tclTestObj.c | 22 ++++++++++++++++++++++
 tests/listObj.test   | 33 +++++++++++++++++++++++++++++++++
 2 files changed, 55 insertions(+)

diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c
index 3b21eaf..0080938 100644
--- a/generic/tclTestObj.c
+++ b/generic/tclTestObj.c
@@ -893,6 +893,7 @@ TestlistobjCmd(
 	"replace",
 	"indexmemcheck",
 	"getelementsmemcheck",
+	"index",
 	NULL
     };
     enum listobjCmdIndex {
@@ -901,6 +902,7 @@ TestlistobjCmd(
 	LISTOBJ_REPLACE,
 	LISTOBJ_INDEXMEMCHECK,
 	LISTOBJ_GETELEMENTSMEMCHECK,
+	LISTOBJ_INDEX,
     } cmdIndex;
 
     Tcl_Size varIndex;		/* Variable number converted to binary */
@@ -1008,6 +1010,26 @@ TestlistobjCmd(
 	    }
 	}
 	break;
+    case LISTOBJ_INDEX:
+	/*
+	 * Tcl_ListObjIndex semantics differ from lindex for out of bounds.
+	 * Hence this explicit test.
+	 */
+	if (objc != 4) {
+	    Tcl_WrongNumArgs(interp, 2, objv,
+			     "varIndex listIndex");
+	    return TCL_ERROR;
+	}
+	if (Tcl_GetIntForIndex(interp, objv[3], TCL_INDEX_NONE, &first) != TCL_OK) {
+	    return TCL_ERROR;
+	} else {
+	    Tcl_Obj *objP;
+	    if (Tcl_ListObjIndex(interp, varPtr[varIndex], first, &objP) != TCL_OK) {
+		return TCL_ERROR;
+	    }
+	    Tcl_SetObjResult(interp, objP ? objP : Tcl_NewStringObj("null", -1));
+	}
+	break;
     }
     return TCL_OK;
 }
diff --git a/tests/listObj.test b/tests/listObj.test
index 0f43648..55fc089 100644
--- a/tests/listObj.test
+++ b/tests/listObj.test
@@ -278,6 +278,39 @@ test listobj-13.3 {Tcl_ListObjElements memory leaks for lseq} -constraints {
     }] $errorMessage
 } -result {0 {}}
 
+# Tests for Tcl_ListObjIndex as sematics are different from lindex for
+# out of bounds indices. Out of bounds should return a null pointer and
+# not empty string.
+test listobj-14.1 {Tcl_ListObjIndex out-of-bounds index for native lists} -constraints {
+    testobj
+} -setup {
+    testobj set 1 [list a b c]
+} -cleanup {
+    testobj freeallvars
+} -body {
+    list [testlistobj index 1 -1] [testlistobj index 1 3]
+} -result {null null}
+
+test listobj-14.2 {Tcl_ListObjIndex out-of-bounds index for native lists with spans} -constraints {
+    testobj
+} -setup {
+    testobj set 1 [testlistrep new 1000 100 100]
+} -cleanup {
+    testobj freeallvars
+} -body {
+    list [testlistobj index 1 -1] [testlistobj index 1 1000]
+} -result {null null}
+
+test listobj-14.3 {Tcl_ListObjIndex out-of-bounds index for lseq} -constraints {
+    testobj
+} -setup {
+    testobj set 1 [lseq 3]
+} -cleanup {
+    testobj freeallvars
+} -body {
+    list [testlistobj index 1 -1] [testlistobj index 1 3]
+} -result {null null}
+
 # cleanup
 ::tcltest::cleanupTests
 return
-- 
cgit v0.12