Add memory leak/refcount tests for lists, spans and lseq

1 files changed, 68 insertions, 0 deletions

diff --git a/tests/listObj.test b/tests/listObj.test
index 0b64635..0f43648 100644
--- a/tests/listObj.test
+++ b/tests/listObj.test
@@ -20,6 +20,7 @@ if {"::tcltest" ni [namespace children]} {
 catch [list package require -exact tcl::test [info patchlevel]]
 
 testConstraint testobj [llength [info commands testobj]]
+testConstraint memory [llength [info commands memory]]
 
 catch {unset x}
 test listobj-1.1 {Tcl_GetListObjType} emptyTest {
@@ -210,6 +211,73 @@ test listobj-11.1 {Bug 3598580: Tcl_ListObjReplace refcount management} testobj
     testobj bug3598580
 } 123
 
+# Stolen from dict.test
+proc listobjmemcheck script {
+    set end [lindex [split [memory info] \n] 3 3]
+    for {set i 0} {$i < 5} {incr i} {
+        uplevel 1 $script
+        set tmp $end
+        set end [lindex [split [memory info] \n] 3 3]
+    }
+    expr {$end - $tmp}
+}
+
+test listobj-12.1 {Tcl_ListObjIndex memory leaks for native lists} -constraints {
+    testobj memory
+} -body {
+    list [listobjmemcheck {
+        testobj set 1 [lrepeat 1000 x]
+        set errorMessage [testlistobj indexmemcheck 1]
+        testobj freeallvars
+    }] $errorMessage
+} -result {0 {}}
+test listobj-12.2 {Tcl_ListObjIndex memory leaks for native lists with spans} -constraints {
+    testobj memory
+} -body {
+    list [listobjmemcheck {
+        testobj set 1 [testlistrep new 1000 100 100]
+        set errorMessage [testlistobj indexmemcheck 1]
+        testobj freeallvars
+    }] $errorMessage
+} -result {0 {}}
+test listobj-12.3 {Tcl_ListObjIndex memory leaks for lseq} -constraints {
+    testobj memory
+} -body {
+    list [listobjmemcheck {
+        testobj set 1 [lseq 1000]
+        set errorMessage [testlistobj indexmemcheck 1]
+        testobj freeallvars
+    }] $errorMessage
+} -result {0 {}}
+
+test listobj-13.1 {Tcl_ListObjGetElements memory leaks for native lists} -constraints {
+    testobj memory
+} -body {
+    list [listobjmemcheck {
+        testobj set 1 [lrepeat 1000 x]
+        set errorMessage [testlistobj getelementsmemcheck 1]
+        testobj freeallvars
+    }] $errorMessage
+} -result {0 {}}
+test listobj-13.2 {Tcl_ListObjElements memory leaks for native lists with spans} -constraints {
+    testobj memory
+} -body {
+    list [listobjmemcheck {
+        testobj set 1 [testlistrep new 1000 100 100]
+        set errorMessage [testlistobj getelementsmemcheck 1]
+        testobj freeallvars
+    }] $errorMessage
+} -result {0 {}}
+test listobj-13.3 {Tcl_ListObjElements memory leaks for lseq} -constraints {
+    testobj memory
+} -body {
+    list [listobjmemcheck {
+        testobj set 1 [lseq 1000]
+        set errorMessage [testlistobj getelementsmemcheck 1]
+        testobj freeallvars
+    }] $errorMessage
+} -result {0 {}}
+
 # cleanup
 ::tcltest::cleanupTests
 return