1# Commands covered: apply 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-1996 Sun Microsystems, Inc. 9# Copyright © 1998-1999 Scriptics Corporation. 10# Copyright © 2005-2006 Miguel Sofer 11# 12# See the file "license.terms" for information on usage and redistribution 13# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 14 15if {"::tcltest" ni [namespace children]} { 16 package require tcltest 2.5 17 namespace import -force ::tcltest::* 18} 19 20if {[info commands ::apply] eq {}} { 21 return 22} 23 24testConstraint memory [llength [info commands memory]] 25 26# Tests for wrong number of arguments 27 28test apply-1.1 {not enough arguments} -returnCodes error -body { 29 apply 30} -result {wrong # args: should be "apply lambdaExpr ?arg ...?"} 31 32# Tests for malformed lambda 33 34test apply-2.0 {malformed lambda} -returnCodes error -body { 35 set lambda a 36 apply $lambda 37} -result {can't interpret "a" as a lambda expression} 38test apply-2.1 {malformed lambda} -returnCodes error -body { 39 set lambda [list a b c d] 40 apply $lambda 41} -result {can't interpret "a b c d" as a lambda expression} 42test apply-2.2 {malformed lambda} { 43 set lambda [list {{}} boo] 44 list [catch {apply $lambda} msg] $msg $::errorInfo 45} {1 {argument with no name} {argument with no name 46 (parsing lambda expression "{{}} boo") 47 invoked from within 48"apply $lambda"}} 49test apply-2.3 {malformed lambda} { 50 set lambda [list {{a b c}} boo] 51 list [catch {apply $lambda} msg] $msg $::errorInfo 52} {1 {too many fields in argument specifier "a b c"} {too many fields in argument specifier "a b c" 53 (parsing lambda expression "{{a b c}} boo") 54 invoked from within 55"apply $lambda"}} 56test apply-2.4 {malformed lambda} { 57 set lambda [list a(1) boo] 58 list [catch {apply $lambda} msg] $msg $::errorInfo 59} {1 {formal parameter "a(1)" is an array element} {formal parameter "a(1)" is an array element 60 (parsing lambda expression "a(1) boo") 61 invoked from within 62"apply $lambda"}} 63test apply-2.5 {malformed lambda} { 64 set lambda [list a::b boo] 65 list [catch {apply $lambda} msg] $msg $::errorInfo 66} {1 {formal parameter "a::b" is not a simple name} {formal parameter "a::b" is not a simple name 67 (parsing lambda expression "a::b boo") 68 invoked from within 69"apply $lambda"}} 70 71# Tests for runtime errors in the lambda expression 72 73test apply-3.1 {non-existing namespace} -body { 74 apply [list x {set x 1} ::NONEXIST::FOR::SURE] x 75} -returnCodes error -result {namespace "::NONEXIST::FOR::SURE" not found} 76test apply-3.2 {non-existing namespace} -body { 77 namespace eval ::NONEXIST::FOR::SURE {} 78 set lambda [list x {set x 1} ::NONEXIST::FOR::SURE] 79 apply $lambda x 80 namespace delete ::NONEXIST 81 apply $lambda x 82} -returnCodes error -result {namespace "::NONEXIST::FOR::SURE" not found} 83test apply-3.3 {non-existing namespace} -body { 84 apply [list x {set x 1} NONEXIST::FOR::SURE] x 85} -returnCodes error -result {namespace "::NONEXIST::FOR::SURE" not found} 86test apply-3.4 {non-existing namespace} -body { 87 namespace eval ::NONEXIST::FOR::SURE {} 88 set lambda [list x {set x 1} NONEXIST::FOR::SURE] 89 apply $lambda x 90 namespace delete ::NONEXIST 91 apply $lambda x 92} -returnCodes error -result {namespace "::NONEXIST::FOR::SURE" not found} 93 94test apply-4.1 {error in arguments to lambda expression} -body { 95 set lambda [list x {set x 1}] 96 apply $lambda 97} -returnCodes error -result {wrong # args: should be "apply lambdaExpr x"} 98test apply-4.2 {error in arguments to lambda expression} -body { 99 set lambda [list x {set x 1}] 100 apply $lambda a b 101} -returnCodes error -result {wrong # args: should be "apply lambdaExpr x"} 102test apply-4.3 {error in arguments to lambda expression} -body { 103 interp alias {} foo {} ::apply [list x {set x 1}] 104 foo a b 105} -cleanup { 106 rename foo {} 107} -returnCodes error -result {wrong # args: should be "foo x"} 108test apply-4.4 {error in arguments to lambda expression} -body { 109 interp alias {} foo {} ::apply [list x {set x 1}] a 110 foo b 111} -cleanup { 112 rename foo {} 113} -returnCodes error -result {wrong # args: should be "foo"} 114test apply-4.5 {error in arguments to lambda expression} -body { 115 set lambda [list x {set x 1}] 116 namespace eval a { 117 namespace ensemble create -command ::bar -map {id {::a::const foo}} 118 proc const val { return $val } 119 proc alias {object slot = command args} { 120 set map [namespace ensemble configure $object -map] 121 dict set map $slot [linsert $args 0 $command] 122 namespace ensemble configure $object -map $map 123 } 124 proc method {object name params body} { 125 set params [linsert $params 0 self] 126 alias $object $name = ::apply [list $params $body] $object 127 } 128 method ::bar boo x {return "[expr {$x*$x}] - $self"} 129 } 130 bar boo 131} -cleanup { 132 namespace delete ::a 133} -returnCodes error -result {wrong # args: should be "bar boo x"} 134 135test apply-5.1 {runtime error in lambda expression} { 136 set lambda [list {} {error foo}] 137 set res [catch {apply $lambda}] 138 list $res $::errorInfo 139} {1 {foo 140 while executing 141"error foo" 142 (lambda term "{} {error foo}" line 1) 143 invoked from within 144"apply $lambda"}} 145 146# Tests for correct execution; as the implementation is the same as that for 147# procs, the general functionality is mostly tested elsewhere 148 149test apply-6.1 {info level} { 150 set lev [info level] 151 set lambda [list {} {info level}] 152 expr {[apply $lambda] - $lev} 153} 1 154test apply-6.2 {info level} { 155 set lambda [list {} {info level 0}] 156 apply $lambda 157} {apply {{} {info level 0}}} 158test apply-6.3 {info level} { 159 set lambda [list args {info level 0}] 160 apply $lambda x y 161} {apply {args {info level 0}} x y} 162 163# Tests for correct namespace scope 164 165namespace eval ::testApply { 166 proc testApply args {return testApply} 167} 168 169test apply-7.1 {namespace access} { 170 set ::testApply::x 0 171 set body {set x 1; set x} 172 list [apply [list args $body ::testApply]] $::testApply::x 173} {1 0} 174test apply-7.2 {namespace access} { 175 set ::testApply::x 0 176 set body {variable x; set x} 177 list [apply [list args $body ::testApply]] $::testApply::x 178} {0 0} 179test apply-7.3 {namespace access} { 180 set ::testApply::x 0 181 set body {variable x; set x 1} 182 list [apply [list args $body ::testApply]] $::testApply::x 183} {1 1} 184test apply-7.4 {namespace access} { 185 set ::testApply::x 0 186 set body {testApply} 187 apply [list args $body ::testApply] 188} testApply 189test apply-7.5 {namespace access} { 190 set ::testApply::x 0 191 set body {set x 1; set x} 192 list [apply [list args $body testApply]] $::testApply::x 193} {1 0} 194test apply-7.6 {namespace access} { 195 set ::testApply::x 0 196 set body {variable x; set x} 197 list [apply [list args $body testApply]] $::testApply::x 198} {0 0} 199test apply-7.7 {namespace access} { 200 set ::testApply::x 0 201 set body {variable x; set x 1} 202 list [apply [list args $body testApply]] $::testApply::x 203} {1 1} 204test apply-7.8 {namespace access} { 205 set ::testApply::x 0 206 set body {testApply} 207 apply [list args $body testApply] 208} testApply 209 210# Tests for correct argument treatment 211 212set applyBody { 213 set res {} 214 foreach v [info locals] { 215 if {$v eq "res"} continue 216 lappend res [list $v [set $v]] 217 } 218 set res 219} 220 221test apply-8.1 {args treatment} { 222 apply [list args $applyBody] 1 2 3 223} {{args {1 2 3}}} 224test apply-8.2 {args treatment} { 225 apply [list {x args} $applyBody] 1 2 226} {{x 1} {args 2}} 227test apply-8.3 {args treatment} { 228 apply [list {x args} $applyBody] 1 2 3 229} {{x 1} {args {2 3}}} 230test apply-8.4 {default values} { 231 apply [list {{x 1} {y 2}} $applyBody] 232} {{x 1} {y 2}} 233test apply-8.5 {default values} { 234 apply [list {{x 1} {y 2}} $applyBody] 3 4 235} {{x 3} {y 4}} 236test apply-8.6 {default values} { 237 apply [list {{x 1} {y 2}} $applyBody] 3 238} {{x 3} {y 2}} 239test apply-8.7 {default values} { 240 apply [list {x {y 2}} $applyBody] 1 241} {{x 1} {y 2}} 242test apply-8.8 {default values} { 243 apply [list {x {y 2}} $applyBody] 1 3 244} {{x 1} {y 3}} 245test apply-8.9 {default values} { 246 apply [list {x {y 2} args} $applyBody] 1 247} {{x 1} {y 2} {args {}}} 248test apply-8.10 {default values} { 249 apply [list {x {y 2} args} $applyBody] 1 3 250} {{x 1} {y 3} {args {}}} 251 252# Tests for leaks 253 254test apply-9.1 {leaking internal rep} -setup { 255 proc getbytes {} { 256 set lines [split [memory info] "\n"] 257 lindex $lines 3 3 258 } 259 set lam [list {} {set a 1}] 260} -constraints memory -body { 261 set end [getbytes] 262 for {set i 0} {$i < 5} {incr i} { 263 ::apply [lrange $lam 0 end] 264 set tmp $end 265 set end [getbytes] 266 } 267 set leakedBytes [expr {$end - $tmp}] 268} -cleanup { 269 rename getbytes {} 270 unset -nocomplain lam end i tmp leakedBytes 271} -result 0 272test apply-9.2 {leaking internal rep} -setup { 273 proc getbytes {} { 274 set lines [split [memory info] "\n"] 275 lindex $lines 3 3 276 } 277} -constraints memory -body { 278 set end [getbytes] 279 for {set i 0} {$i < 5} {incr i} { 280 ::apply [list {} {set a 1}] 281 set tmp $end 282 set end [getbytes] 283 } 284 set leakedBytes [expr {$end - $tmp}] 285} -cleanup { 286 rename getbytes {} 287 unset -nocomplain end i tmp leakedBytes 288} -result 0 289test apply-9.3 {leaking internal rep} -setup { 290 proc getbytes {} { 291 set lines [split [memory info] "\n"] 292 lindex $lines 3 3 293 } 294} -constraints memory -body { 295 set end [getbytes] 296 for {set i 0} {$i < 5} {incr i} { 297 set x [list {} {set a 1} ::NS::THAT::DOES::NOT::EXIST] 298 catch {::apply $x} 299 set x {} 300 set tmp $end 301 set end [getbytes] 302 } 303 set leakedBytes [expr {$end - $tmp}] 304} -cleanup { 305 rename getbytes {} 306 unset -nocomplain end i x tmp leakedBytes 307} -result 0 308 309# Tests for the avoidance of recompilation 310 311# cleanup 312 313namespace delete testApply 314 315::tcltest::cleanupTests 316return 317 318# Local Variables: 319# mode: tcl 320# fill-column: 78 321# End: 322