1# Commands covered: lrange 2# 3# This file contains a collection of tests for one or more of the Tcl 4# built-in commands. Sourcing this file into Tcl runs the tests and 5# generates output for errors. No output means no errors were found. 6# 7# Copyright © 1991-1993 The Regents of the University of California. 8# Copyright © 1994 Sun Microsystems, Inc. 9# Copyright © 1998-1999 Scriptics Corporation. 10# 11# See the file "license.terms" for information on usage and redistribution 12# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 13 14if {"::tcltest" ni [namespace children]} { 15 package require tcltest 2.5 16 namespace import -force ::tcltest::* 17} 18 19::tcltest::loadTestedCommands 20catch [list package require -exact tcl::test [info patchlevel]] 21 22testConstraint testpurebytesobj [llength [info commands testpurebytesobj]] 23 24test lrange-1.1 {range of list elements} { 25 lrange {a b c d} 1 2 26} {b c} 27test lrange-1.2 {range of list elements} { 28 lrange {a {bcd e {f g {}}} l14 l15 d} 1 1 29} {{bcd e {f g {}}}} 30test lrange-1.3 {range of list elements} { 31 lrange {a {bcd e {f g {}}} l14 l15 d} 3 end 32} {l15 d} 33test lrange-1.4 {range of list elements} { 34 lrange {a {bcd e {f g {}}} l14 l15 d} 4 10000 35} {d} 36test lrange-1.5 {range of list elements} { 37 lrange {a {bcd e {f g {}}} l14 l15 d} 4 3 38} {} 39test lrange-1.6 {range of list elements} { 40 lrange {a {bcd e {f g {}}} l14 l15 d} 10 11 41} {} 42test lrange-1.7 {range of list elements} { 43 lrange {a b c d e} -1 2 44} {a b c} 45test lrange-1.8 {range of list elements} { 46 lrange {a b c d e} -2 -1 47} {} 48test lrange-1.9 {range of list elements} { 49 lrange {a b c d e} -2 end 50} {a b c d e} 51test lrange-1.10 {range of list elements} { 52 lrange "a b\{c d" 1 2 53} "b\\{c d" 54test lrange-1.11 {range of list elements} { 55 lrange "a b c d" end end 56} d 57test lrange-1.12 {range of list elements} { 58 lrange "a b c d" end 100000 59} d 60test lrange-1.13 {range of list elements} { 61 lrange "a b c d" end 3 62} d 63test lrange-1.14 {range of list elements} { 64 lrange "a b c d" end 2 65} {} 66test lrange-1.15 {range of list elements} { 67 concat \"[lrange {a b \{\ } 0 2]" 68} {"a b \{\ "} 69# emacs highlighting bug workaround --> " 70test lrange-1.16 {list element quoting} { 71 lrange {[append a .b]} 0 end 72} {{[append} a .b\]} 73 74test lrange-2.1 {error conditions} { 75 list [catch {lrange a b} msg] $msg 76} {1 {wrong # args: should be "lrange list first last"}} 77test lrange-2.2 {error conditions} { 78 list [catch {lrange a b 6 7} msg] $msg 79} {1 {wrong # args: should be "lrange list first last"}} 80test lrange-2.3 {error conditions} { 81 list [catch {lrange a b 6} msg] $msg 82} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}} 83test lrange-2.4 {error conditions} { 84 list [catch {lrange a 0 enigma} msg] $msg 85} {1 {bad index "enigma": must be integer?[+-]integer? or end?[+-]integer?}} 86test lrange-2.5 {error conditions} { 87 list [catch {lrange "a \{b c" 3 4} msg] $msg 88} {1 {unmatched open brace in list}} 89test lrange-2.6 {error conditions} { 90 list [catch {lrange "a b c \{ d e" 1 4} msg] $msg 91} {1 {unmatched open brace in list}} 92 93test lrange-3.1 {Bug 3588366: end-offsets before start} { 94 apply {l { 95 lrange $l 0 end-5 96 }} {1 2 3 4 5} 97} {} 98test lrange-3.2 {compiled with static indices out of range, negative} { 99 list [lrange {a b c} -1 -2] [lrange {a b c} -2 -1] [lrange {a b c} -3 -2] [lrange {a b c} -2 -3] 100} [lrepeat 4 {}] 101test lrange-3.3 {compiled with calculated indices out of range, negative constant} { 102 list [lrange {a b c} 0-1 -1-1] [lrange {a b c} -2+0 0-1] [lrange {a b c} -2-1 -2+1] [lrange {a b c} -2+1 -2-1] 103} [lrepeat 4 {}] 104test lrange-3.4 {compiled with calculated indices out of range, after end} -body { 105 list [lrange {a b c} end+1 end+2] [lrange {a b c} end+2 end+1] [lrange {a b c} end+2 end+3] [lrange {a b c} end+3 end+2] 106} -result [lrepeat 4 {}] 107 108test lrange-3.5 {compiled with calculated indices, start out of range (negative)} { 109 list [lrange {a b c} -1 1] [lrange {a b c} -1+0 end-1] [lrange {a b c} -2 1] [lrange {a b c} -2+0 0+1] 110} [lrepeat 4 {a b}] 111test lrange-3.6 {compiled with calculated indices, end out of range (after end)} { 112 list [lrange {a b c} 1 end+1] [lrange {a b c} 1+0 2+1] [lrange {a b c} 1 end+1] [lrange {a b c} end-1 3+1] 113} [lrepeat 4 {b c}] 114 115test lrange-3.7a {compiled on empty not canonical list (with static and dynamic indices), regression test, bug [cc1e91552c]} { 116 list [lrange { } 0 1] [lrange [format %c 32] 0 1] [lrange [set a { }] 0 1] \ 117 [lrange { } 0-1 end+1] [lrange [format %c 32] 0-1 end+1] [lrange $a 0-1 end+1] 118} [lrepeat 6 {}] 119test lrange-3.7b {not compiled on empty not canonical list (with static and dynamic indices), regression test, bug [cc1e91552c]} -body { 120 set cmd lrange 121 list [$cmd { } 0 1] [$cmd [format %c 32] 0 1] [$cmd [set a { }] 0 1] \ 122 [$cmd { } 0-1 end+1] [$cmd [format %c 32] 0-1 end+1] [$cmd $a 0-1 end+1] 123} -result [lrepeat 6 {}] 124# following 4 tests could cause a segfault on empty non-lists with tclEmptyStringRep 125# (as before the fix [58c46e74b931d3a1]): 126test lrange-3.7a.2 {compiled on empty not list object, 2nd regression test, bug [cc1e91552c]} { 127 list [lrange {} 0 1] [lrange [lindex a -1] 0 1] [lrange [set a {}] 0 1] \ 128 [lrange {} 0-1 end+1] [lrange [lindex a -1] 0-1 end+1] [lrange $a 0-1 end+1] 129} [lrepeat 6 {}] 130test lrange-3.7b.2 {not compiled on empty not list object, 2nd regression test, bug [cc1e91552c]} -body { 131 set cmd lrange 132 list [$cmd {} 0 1] [$cmd [lindex a -1] 0 1] [$cmd [set a {}] 0 1] \ 133 [$cmd {} 0-1 end+1] [$cmd [lindex a -1] 0-1 end+1] [$cmd $a 0-1 end+1] 134} -result [lrepeat 6 {}] 135test lrange-3.7c.2 {compiled on empty pure bytes object, 2nd regression test, bug [cc1e91552c]} -constraints { 136 testpurebytesobj 137} -body { 138 list [lrange [testpurebytesobj] 0 1] [lrange [testpurebytesobj { }] 0 1] [lrange [set a [testpurebytesobj {}]] 0 1] \ 139 [lrange [testpurebytesobj] 0-1 end+1] [lrange [testpurebytesobj { }] 0-1 end+1] [lrange $a 0-1 end+1] 140} -result [lrepeat 6 {}] 141test lrange-3.7d.2 {not compiled on empty pure bytes object, 2nd regression test, bug [cc1e91552c]} -constraints { 142 testpurebytesobj 143} -body { 144 set cmd lrange 145 list [$cmd [testpurebytesobj] 0 1] [$cmd [testpurebytesobj { }] 0 1] [$cmd [set a [testpurebytesobj {}]] 0 1] \ 146 [$cmd [testpurebytesobj] 0-1 end+1] [$cmd [testpurebytesobj { }] 0-1 end+1] [$cmd $a 0-1 end+1] 147} -result [lrepeat 6 {}] 148 149test lrange-4.1 {lrange pure promise} -body { 150 set ll1 [list $tcl_version 2 3 4] 151 # Shared 152 set ll2 $ll1 153 # With string rep 154 string length $ll1 155 set rep1 [tcl::unsupported::representation $ll1] 156 # Get new pure object 157 set x [lrange $ll1 0 end] 158 set rep2 [tcl::unsupported::representation $x] 159 regexp {object pointer at (\S+)} $rep1 -> obj1 160 regexp {object pointer at (\S+)} $rep2 -> obj2 161 list $rep1 $rep2 [string equal $obj1 $obj2] 162 # Check for a new clean object 163} -match glob -result {*value is *refcount of 3,*, string rep*value is*refcount of 2,* no string rep* 0} 164 165test lrange-4.2 {lrange pure promise} -body { 166 set ll1 [list $tcl_version 2 3 4] 167 # Shared 168 set ll2 $ll1 169 # With string rep 170 string length $ll1 171 set rep1 [tcl::unsupported::representation $ll1] 172 # Get new pure object, not compiled 173 set x [[string cat l range] $ll1 0 end] 174 set rep2 [tcl::unsupported::representation $x] 175 regexp {object pointer at (\S+)} $rep1 -> obj1 176 regexp {object pointer at (\S+)} $rep2 -> obj2 177 list $rep1 $rep2 [string equal $obj1 $obj2] 178 # Check for a new clean object 179} -match glob -result {*value is *refcount of 3,*, string rep*value is*refcount of 2,* no string rep* 0} 180 181test lrange-4.3 {lrange pure promise} -body { 182 set ll1 [list $tcl_version 2 3 4] 183 # With string rep 184 string length $ll1 185 set rep1 [tcl::unsupported::representation $ll1] 186 # Get pure object, unshared 187 set ll2 [lrange $ll1[set ll1 {}] 0 end] 188 set rep2 [tcl::unsupported::representation $ll2] 189 regexp {object pointer at (\S+)} $rep1 -> obj1 190 regexp {object pointer at (\S+)} $rep2 -> obj2 191 list $rep1 $rep2 [string equal $obj1 $obj2] 192 # Internal optimisations should keep the same object 193} -match glob -result {*value is *refcount of 2,*, string rep*value is*refcount of 2,* no string rep* 1} 194 195test lrange-4.4 {lrange pure promise} -body { 196 set ll1 [list $tcl_version 2 3 4] 197 # With string rep 198 string length $ll1 199 set rep1 [tcl::unsupported::representation $ll1] 200 # Get pure object, unshared, not compiled 201 set ll2 [[string cat l range] $ll1[set ll1 {}] 0 end] 202 set rep2 [tcl::unsupported::representation $ll2] 203 regexp {object pointer at (\S+)} $rep1 -> obj1 204 regexp {object pointer at (\S+)} $rep2 -> obj2 205 list $rep1 $rep2 [string equal $obj1 $obj2] 206 # Internal optimisations should keep the same object 207} -match glob -result {*value is *refcount of 2,*, string rep*value is*refcount of 2,* no string rep* 1} 208 209# Testing for compiled vs non-compiled behaviour, and shared vs non-shared. 210# Far too many variations to check with spelt-out tests. 211# Note that this *just* checks whether the different versions are the same 212# not whether any of them is correct. 213apply {{} { 214 set lss {{} {a} {a b c} {a b c d}} 215 set idxs {-2 -1 0 1 2 3 end-3 end-2 end-1 end end+1 end+2} 216 set lrange lrange 217 218 foreach ls $lss { 219 foreach a $idxs { 220 foreach b $idxs { 221 # Shared, uncompiled 222 set ls2 $ls 223 set expected [list [catch {$lrange $ls $a $b} m] $m] 224 # Shared, compiled 225 set tester [list lrange $ls $a $b] 226 set script [list catch $tester m] 227 set script "list \[$script\] \$m" 228 test lrange-5.[incr n].1 {lrange shared compiled} -body \ 229 [list apply [list {} $script]] -result $expected 230 # Unshared, uncompiled 231 set tester [string map [list %l [list $ls] %a $a %b $b] { 232 [string cat l range] [lrange %l 0 end] %a %b 233 }] 234 set script [list catch $tester m] 235 set script "list \[$script\] \$m" 236 test lrange-5.$n.2 {lrange unshared uncompiled} -body \ 237 [list apply [list {} $script]] -result $expected 238 # Unshared, compiled 239 set tester [string map [list %l [list $ls] %a $a %b $b] { 240 lrange [lrange %l 0 end] %a %b 241 }] 242 set script [list catch $tester m] 243 set script "list \[$script\] \$m" 244 test lrange-5.$n.3 {lrange unshared compiled} -body \ 245 [list apply [list {} $script]] -result $expected 246 } 247 } 248 } 249}} 250 251# cleanup 252::tcltest::cleanupTests 253return 254 255# Local Variables: 256# mode: tcl 257# End: 258