os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/proc.test
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/proc.test Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,350 @@
1.4 +# This file contains tests for the tclProc.c source file. Tests appear in
1.5 +# the same order as the C code that they test. The set of tests is
1.6 +# currently incomplete since it includes only new tests, in particular
1.7 +# tests for code changed for the addition of Tcl namespaces. Other
1.8 +# procedure-related tests appear in other test files such as proc-old.test.
1.9 +#
1.10 +# Sourcing this file into Tcl runs the tests and generates output for
1.11 +# errors. No output means no errors were found.
1.12 +#
1.13 +# Copyright (c) 1997 Sun Microsystems, Inc.
1.14 +# Copyright (c) 1998-1999 by Scriptics Corporation.
1.15 +#
1.16 +# See the file "license.terms" for information on usage and redistribution
1.17 +# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.18 +#
1.19 +# RCS: @(#) $Id: proc.test,v 1.11.2.1 2004/05/02 21:07:16 msofer Exp $
1.20 +
1.21 +if {[lsearch [namespace children] ::tcltest] == -1} {
1.22 + package require tcltest
1.23 + namespace import -force ::tcltest::*
1.24 +}
1.25 +
1.26 +catch {eval namespace delete [namespace children :: test_ns_*]}
1.27 +catch {rename p ""}
1.28 +catch {rename {} ""}
1.29 +catch {unset msg}
1.30 +
1.31 +test proc-1.1 {Tcl_ProcObjCmd, put proc in namespace specified in name, if any} {
1.32 + catch {eval namespace delete [namespace children :: test_ns_*]}
1.33 + namespace eval test_ns_1 {
1.34 + namespace eval baz {}
1.35 + }
1.36 + proc test_ns_1::baz::p {} {
1.37 + return "p in [namespace current]"
1.38 + }
1.39 + list [test_ns_1::baz::p] \
1.40 + [namespace eval test_ns_1 {baz::p}] \
1.41 + [info commands test_ns_1::baz::*]
1.42 +} {{p in ::test_ns_1::baz} {p in ::test_ns_1::baz} ::test_ns_1::baz::p}
1.43 +test proc-1.2 {Tcl_ProcObjCmd, namespace specified in proc name must exist} {
1.44 + catch {eval namespace delete [namespace children :: test_ns_*]}
1.45 + list [catch {proc test_ns_1::baz::p {} {}} msg] $msg
1.46 +} {1 {can't create procedure "test_ns_1::baz::p": unknown namespace}}
1.47 +test proc-1.3 {Tcl_ProcObjCmd, empty proc name} {
1.48 + catch {eval namespace delete [namespace children :: test_ns_*]}
1.49 + proc :: {} {
1.50 + return "empty called"
1.51 + }
1.52 + list [::] \
1.53 + [info body {}]
1.54 +} {{empty called} {
1.55 + return "empty called"
1.56 + }}
1.57 +test proc-1.4 {Tcl_ProcObjCmd, simple proc name and proc defined in namespace} {
1.58 + catch {eval namespace delete [namespace children :: test_ns_*]}
1.59 + namespace eval test_ns_1 {
1.60 + namespace eval baz {
1.61 + proc p {} {
1.62 + return "p in [namespace current]"
1.63 + }
1.64 + }
1.65 + }
1.66 + list [test_ns_1::baz::p] \
1.67 + [info commands test_ns_1::baz::*]
1.68 +} {{p in ::test_ns_1::baz} ::test_ns_1::baz::p}
1.69 +test proc-1.5 {Tcl_ProcObjCmd, qualified proc name and proc defined in namespace} {
1.70 + catch {eval namespace delete [namespace children :: test_ns_*]}
1.71 + namespace eval test_ns_1::baz {}
1.72 + namespace eval test_ns_1 {
1.73 + proc baz::p {} {
1.74 + return "p in [namespace current]"
1.75 + }
1.76 + }
1.77 + list [test_ns_1::baz::p] \
1.78 + [info commands test_ns_1::baz::*] \
1.79 + [namespace eval test_ns_1::baz {namespace which p}]
1.80 +} {{p in ::test_ns_1::baz} ::test_ns_1::baz::p ::test_ns_1::baz::p}
1.81 +test proc-1.6 {Tcl_ProcObjCmd, namespace code ignores single ":"s in middle or end of command names} {
1.82 + catch {eval namespace delete [namespace children :: test_ns_*]}
1.83 + namespace eval test_ns_1 {
1.84 + proc q: {} {return "q:"}
1.85 + proc value:at: {} {return "value:at:"}
1.86 + }
1.87 + list [namespace eval test_ns_1 {q:}] \
1.88 + [namespace eval test_ns_1 {value:at:}] \
1.89 + [test_ns_1::q:] \
1.90 + [test_ns_1::value:at:] \
1.91 + [lsort [info commands test_ns_1::*]] \
1.92 + [namespace eval test_ns_1 {namespace which q:}] \
1.93 + [namespace eval test_ns_1 {namespace which value:at:}]
1.94 +} {q: value:at: q: value:at: {::test_ns_1::q: ::test_ns_1::value:at:} ::test_ns_1::q: ::test_ns_1::value:at:}
1.95 +test proc-1.7 {Tcl_ProcObjCmd, check that formal parameter names are not array elements} {
1.96 + catch {rename p ""}
1.97 + list [catch {proc p {a(1) a(2)} {
1.98 + set z [expr $a(1)+$a(2)]
1.99 + puts "$z=z, $a(1)=$a(1)"
1.100 + }} msg] $msg
1.101 +} {1 {procedure "p" has formal parameter "a(1)" that is an array element}}
1.102 +test proc-1.8 {Tcl_ProcObjCmd, check that formal parameter names are simple names} {
1.103 + catch {rename p ""}
1.104 + list [catch {proc p {b:a b::a} {
1.105 + }} msg] $msg
1.106 +} {1 {procedure "p" has formal parameter "b::a" that is not a simple name}}
1.107 +
1.108 +test proc-2.1 {TclFindProc, simple proc name and proc not in namespace} {
1.109 + catch {eval namespace delete [namespace children :: test_ns_*]}
1.110 + catch {rename p ""}
1.111 + proc p {} {return "p in [namespace current]"}
1.112 + info body p
1.113 +} {return "p in [namespace current]"}
1.114 +test proc-2.2 {TclFindProc, simple proc name and proc defined in namespace} {
1.115 + catch {eval namespace delete [namespace children :: test_ns_*]}
1.116 + namespace eval test_ns_1 {
1.117 + namespace eval baz {
1.118 + proc p {} {return "p in [namespace current]"}
1.119 + }
1.120 + }
1.121 + namespace eval test_ns_1::baz {info body p}
1.122 +} {return "p in [namespace current]"}
1.123 +test proc-2.3 {TclFindProc, qualified proc name and proc defined in namespace} {
1.124 + catch {eval namespace delete [namespace children :: test_ns_*]}
1.125 + namespace eval test_ns_1::baz {}
1.126 + namespace eval test_ns_1 {
1.127 + proc baz::p {} {return "p in [namespace current]"}
1.128 + }
1.129 + namespace eval test_ns_1 {info body baz::p}
1.130 +} {return "p in [namespace current]"}
1.131 +test proc-2.4 {TclFindProc, global proc and executing in namespace} {
1.132 + catch {eval namespace delete [namespace children :: test_ns_*]}
1.133 + catch {rename p ""}
1.134 + proc p {} {return "global p"}
1.135 + namespace eval test_ns_1::baz {info body p}
1.136 +} {return "global p"}
1.137 +
1.138 +test proc-3.1 {TclObjInterpProc, proc defined and executing in same namespace} {
1.139 + catch {eval namespace delete [namespace children :: test_ns_*]}
1.140 + proc p {} {return "p in [namespace current]"}
1.141 + p
1.142 +} {p in ::}
1.143 +test proc-3.2 {TclObjInterpProc, proc defined and executing in same namespace} {
1.144 + catch {eval namespace delete [namespace children :: test_ns_*]}
1.145 + namespace eval test_ns_1::baz {
1.146 + proc p {} {return "p in [namespace current]"}
1.147 + p
1.148 + }
1.149 +} {p in ::test_ns_1::baz}
1.150 +test proc-3.3 {TclObjInterpProc, proc defined and executing in different namespaces} {
1.151 + catch {eval namespace delete [namespace children :: test_ns_*]}
1.152 + catch {rename p ""}
1.153 + proc p {} {return "p in [namespace current]"}
1.154 + namespace eval test_ns_1::baz {
1.155 + p
1.156 + }
1.157 +} {p in ::}
1.158 +test proc-3.4 {TclObjInterpProc, procs execute in the namespace in which they were defined unless renamed into new namespace} {
1.159 + catch {eval namespace delete [namespace children :: test_ns_*]}
1.160 + catch {rename p ""}
1.161 + namespace eval test_ns_1::baz {
1.162 + proc p {} {return "p in [namespace current]"}
1.163 + rename ::test_ns_1::baz::p ::p
1.164 + list [p] [namespace which p]
1.165 + }
1.166 +} {{p in ::} ::p}
1.167 +test proc-3.5 {TclObjInterpProc, any old result is reset before appending error msg about missing arguments} {
1.168 + proc p {x} {info commands 3m}
1.169 + list [catch {p} msg] $msg
1.170 +} {1 {wrong # args: should be "p x"}}
1.171 +
1.172 +test proc-3.6 {TclObjInterpProc, proper quoting of proc name, Bug 942757} {
1.173 + proc {a b c} {x} {info commands 3m}
1.174 + list [catch {{a b c}} msg] $msg
1.175 +} {1 {wrong # args: should be "{a b c} x"}}
1.176 +
1.177 +catch {eval namespace delete [namespace children :: test_ns_*]}
1.178 +catch {rename p ""}
1.179 +catch {rename {} ""}
1.180 +catch {rename {a b c} {}}
1.181 +catch {unset msg}
1.182 +
1.183 +if {[catch {package require procbodytest}]} {
1.184 + puts "This application couldn't load the \"procbodytest\" package, so I"
1.185 + puts "can't test creation of procs whose bodies have type \"procbody\"."
1.186 + ::tcltest::cleanupTests
1.187 + return
1.188 +}
1.189 +
1.190 +catch {rename p ""}
1.191 +catch {rename t ""}
1.192 +
1.193 +# Note that the test require that procedures whose body is used to create
1.194 +# procbody objects must be executed before the procbodytest::proc command
1.195 +# is executed, so that the Proc struct is populated correctly (CompiledLocals
1.196 +# are added at compile time).
1.197 +
1.198 +test proc-4.1 {TclCreateProc, procbody obj} {
1.199 + catch {
1.200 + proc p x {return "$x:$x"}
1.201 + set rv [p P]
1.202 + procbodytest::proc t x p
1.203 + lappend rv [t T]
1.204 + set rv
1.205 + } result
1.206 + catch {rename p ""}
1.207 + catch {rename t ""}
1.208 + set result
1.209 +} {P:P T:T}
1.210 +
1.211 +test proc-4.2 {TclCreateProc, procbody obj, use compiled locals} {
1.212 + catch {
1.213 + proc p x {
1.214 + set y [string tolower $x]
1.215 + return "$x:$y"
1.216 + }
1.217 + set rv [p P]
1.218 + procbodytest::proc t x p
1.219 + lappend rv [t T]
1.220 + set rv
1.221 + } result
1.222 + catch {rename p ""}
1.223 + catch {rename t ""}
1.224 + set result
1.225 +} {P:p T:t}
1.226 +
1.227 +test proc-4.3 {TclCreateProc, procbody obj, too many args} {
1.228 + catch {
1.229 + proc p x {
1.230 + set y [string tolower $x]
1.231 + return "$x:$y"
1.232 + }
1.233 + set rv [p P]
1.234 + procbodytest::proc t {x x1 x2} p
1.235 + lappend rv [t T]
1.236 + set rv
1.237 + } result
1.238 + catch {rename p ""}
1.239 + catch {rename t ""}
1.240 + set result
1.241 +} {procedure "t": arg list contains 3 entries, precompiled header expects 1}
1.242 +
1.243 +test proc-4.4 {TclCreateProc, procbody obj, inconsitent arg name} {
1.244 + catch {
1.245 + proc p {x y z} {
1.246 + set v [join [list $x $y $z]]
1.247 + set w [string tolower $v]
1.248 + return "$v:$w"
1.249 + }
1.250 + set rv [p P Q R]
1.251 + procbodytest::proc t {x x1 z} p
1.252 + lappend rv [t S T U]
1.253 + set rv
1.254 + } result
1.255 + catch {rename p ""}
1.256 + catch {rename t ""}
1.257 + set result
1.258 +} {procedure "t": formal parameter 1 is inconsistent with precompiled body}
1.259 +
1.260 +test proc-4.5 {TclCreateProc, procbody obj, inconsitent arg default type} {
1.261 + catch {
1.262 + proc p {x y {z Z}} {
1.263 + set v [join [list $x $y $z]]
1.264 + set w [string tolower $v]
1.265 + return "$v:$w"
1.266 + }
1.267 + set rv [p P Q R]
1.268 + procbodytest::proc t {x y z} p
1.269 + lappend rv [t S T U]
1.270 + set rv
1.271 + } result
1.272 + catch {rename p ""}
1.273 + catch {rename t ""}
1.274 + set result
1.275 +} {procedure "t": formal parameter 2 is inconsistent with precompiled body}
1.276 +
1.277 +test proc-4.6 {TclCreateProc, procbody obj, inconsitent arg default type} {
1.278 + catch {
1.279 + proc p {x y z} {
1.280 + set v [join [list $x $y $z]]
1.281 + set w [string tolower $v]
1.282 + return "$v:$w"
1.283 + }
1.284 + set rv [p P Q R]
1.285 + procbodytest::proc t {x y {z Z}} p
1.286 + lappend rv [t S T U]
1.287 + set rv
1.288 + } result
1.289 + catch {rename p ""}
1.290 + catch {rename t ""}
1.291 + set result
1.292 +} {procedure "t": formal parameter 2 is inconsistent with precompiled body}
1.293 +
1.294 +test proc-4.7 {TclCreateProc, procbody obj, inconsitent arg default value} {
1.295 + catch {
1.296 + proc p {x y {z Z}} {
1.297 + set v [join [list $x $y $z]]
1.298 + set w [string tolower $v]
1.299 + return "$v:$w"
1.300 + }
1.301 + set rv [p P Q R]
1.302 + procbodytest::proc t {x y {z ZZ}} p
1.303 + lappend rv [t S T U]
1.304 + set rv
1.305 + } result
1.306 + catch {rename p ""}
1.307 + catch {rename t ""}
1.308 + set result
1.309 +} {procedure "t": formal parameter "z" has default value inconsistent with precompiled body}
1.310 +
1.311 +test proc-5.1 {Bytecompiling noop; test for correct argument substitution} {
1.312 + proc p args {} ; # this will be bytecompiled into t
1.313 + proc t {} {
1.314 + set res {}
1.315 + set a 0
1.316 + set b 0
1.317 + trace add variable a read {append res a ;#}
1.318 + trace add variable b write {append res b ;#}
1.319 + p $a ccccccw {bfe} {$a} [incr b] [incr a] {[incr b]} {$a} hello
1.320 + set res
1.321 + }
1.322 + set result [t]
1.323 + catch {rename p ""}
1.324 + catch {rename t ""}
1.325 + set result
1.326 +} {aba}
1.327 +
1.328 +test proc-6.1 {ProcessProcResultCode: Bug 647307 (negative return code)} {
1.329 + proc a {} {return -code -5}
1.330 + proc b {} a
1.331 + set result [catch b]
1.332 + rename a {}
1.333 + rename b {}
1.334 + set result
1.335 +} -5
1.336 +
1.337 +# cleanup
1.338 +catch {rename p ""}
1.339 +catch {rename t ""}
1.340 +::tcltest::cleanupTests
1.341 +return
1.342 +
1.343 +
1.344 +
1.345 +
1.346 +
1.347 +
1.348 +
1.349 +
1.350 +
1.351 +
1.352 +
1.353 +