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