diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/NRE.test | 476 | ||||
| -rw-r--r-- | tests/eofchar.data | 846 | ||||
| -rw-r--r-- | tests/ioUtil.test | 333 | ||||
| -rw-r--r-- | tests/macFCmd.test | 204 | ||||
| -rw-r--r-- | tests/osa.test | 48 | ||||
| -rw-r--r-- | tests/pkg.test | 1222 | ||||
| -rw-r--r-- | tests/resource.test | 369 | ||||
| -rw-r--r-- | tests/unsupported.test | 914 |
8 files changed, 4412 insertions, 0 deletions
diff --git a/tests/NRE.test b/tests/NRE.test new file mode 100644 index 0000000..4a279bc --- /dev/null +++ b/tests/NRE.test @@ -0,0 +1,476 @@ +# Commands covered: proc, apply, [interp alias], [namespce import], tailcall +# +# This file contains a collection of tests for the non-recursive executor that +# avoids recursive calls to TEBC. +# +# Copyright (c) 2008 by Miguel Sofer. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: NRE.test,v 1.10 2008/08/01 00:44:05 msofer Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import -force ::tcltest::* +} + +testConstraint tailcall [llength [info commands ::tcl::unsupported::tailcall]] +testConstraint testnrelevels [llength [info commands testnrelevels]] + +# +# The tests that risked blowing the C stack on failure have been removed: we +# can now actually measure using testnrelevels. +# + +if {[testConstraint testnrelevels]} { + namespace eval testnre { + # + # [testnrelevels] returns a 6-list with: C-stack depth, iPtr->numlevels, + # cmdFrame level, callFrame level, tosPtr and callback depth + # + variable last [testnrelevels] + proc depthDiff {} { + variable last + set depth [testnrelevels] + set res {} + foreach t $depth l $last { + lappend res [expr {$t-$l}] + } + set last $depth + return $res + } + proc setabs {} { + uplevel 1 variable abs -[lindex [testnrelevels] 0] + } + + variable body0 { + set x [depthDiff] + if {[incr i] > 10} { + variable abs + incr abs [lindex [testnrelevels] 0] + return [list [lrange $x 0 3] $abs] + } + } + proc makebody txt { + variable body0 + return "$body0; $txt" + } + namespace export * + } + namespace import testnre::* +} + +test NRE-1.1 {self-recursive procs} -setup { + proc a i [makebody {a $i}] +} -body { + setabs + a 0 +} -cleanup { + rename a {} + unset abs +} -result {{0 1 1 1} 0} + +test NRE-1.2 {self-recursive lambdas} -setup { + set a [list i [makebody {apply $::a $i}]] +} -body { + setabs + apply $a 0 +} -cleanup { + unset a abs +} -result {{0 1 1 1} 0} + +test NRE-1.3 {mutually recursive procs and lambdas} -setup { + proc a i { + apply $::b [incr i] + } + set b [list i [makebody {a $i}]] +} -body { + setabs + a 0 +} -cleanup { + rename a {} + unset b abs +} -result {{0 2 2 2} 0} + +# +# Test that aliases are non-recursive +# + +test NRE-2.1 {alias is not recursive} -setup { + proc a i [makebody {b $i}] + interp alias {} b {} a +} -body { + setabs + a 0 +} -cleanup { + rename a {} + rename b {} + unset abs +} -result {{0 2 1 1} 0} + +# +# Test that imports are non-recursive +# + +test NRE-3.1 {imports are not recursive} -setup { + namespace eval foo { + setabs + namespace export a + } + proc foo::a i [makebody {::a $i}] + namespace import foo::a +} -body { + a 0 +} -cleanup { + rename a {} + namespace delete ::foo +} -result {{0 2 1 1} 0} + +test NRE-4.1 {ensembles are not recursive} -setup { + proc a i [makebody {b foo $i}] + namespace ensemble create \ + -command b \ + -map [list foo a] +} -body { + setabs + a 0 +} -cleanup { + rename a {} + rename b {} + unset abs +} -result {{0 2 1 1} 0} + +test NRE-5.1 {[namespace eval] is not recursive} -setup { + namespace eval ::foo { + setabs + } + proc foo::a i [makebody {namespace eval ::foo [list a $i]}] +} -body { + ::foo::a 0 +} -cleanup { + namespace delete ::foo +} -result {{0 2 2 2} 0} + +test NRE-5.2 {[namespace eval] is not recursive} -setup { + namespace eval ::foo { + setabs + } + proc foo::a i [makebody {namespace eval ::foo "set x $i; a $i"}] +} -body { + foo::a 0 +} -cleanup { + namespace delete ::foo +} -result {{0 2 2 2} 0} + +test NRE-6.1 {[uplevel] is not recursive} -setup { + proc a i [makebody {uplevel 1 [list a $i]}] +} -body { + setabs + a 0 +} -cleanup { + rename a {} + unset abs +} -result {{0 2 2 0} 0} + +test NRE-6.2 {[uplevel] is not recursive} -setup { + setabs + proc a i [makebody {uplevel 1 "set x $i; a $i"}] +} -body { + a 0 +} -cleanup { + rename a {} + unset abs +} -result {{0 2 2 0} 0} + +test NRE-7.1 {[catch] is not recursive} -setup { + setabs + proc a i [makebody {uplevel 1 "catch {a $i} msg; set msg"}] +} -body { + a 0 +} -cleanup { + rename a {} + unset x abs +} -result {{0 3 3 0} 0} + +# +# Basic TclOO tests +# + +test NRE-oo.1 {really deep calls in oo - direct} -setup { + oo::object create foo + oo::objdefine foo method bar i [makebody {foo bar $i}] +} -body { + setabs + foo bar 0 +} -cleanup { + foo destroy + unset abs +} -result {{0 1 1 1} 0} + +test NRE-oo.2 {really deep calls in oo - call via [self]} -setup { + oo::object create foo + oo::objdefine foo method bar i [makebody {[self] bar $i}] +} -body { + setabs + foo bar 0 +} -cleanup { + foo destroy + unset abs +} -result {{0 1 1 1} 0} + +test NRE-oo.3 {really deep calls in oo - private calls} -setup { + oo::object create foo + oo::objdefine foo method bar i [makebody {my bar $i}] +} -body { + setabs + foo bar 0 +} -cleanup { + foo destroy + unset abs +} -result {{0 1 1 1} 0} + +test NRE-oo.4 {really deep calls in oo - overriding} -setup { + oo::class create foo { + method bar i [makebody {my bar $i}] + } + oo::class create boo { + superclass foo + method bar i [makebody {next $i}] + } +} -body { + setabs + [boo new] bar 0 +} -cleanup { + foo destroy + unset abs +} -result {{0 1 1 1} 0} + +test NRE-oo.5 {really deep calls in oo - forwards} -setup { + oo::object create foo + set body [makebody {my boo $i}] + oo::objdefine foo " + method bar i {$body} + forward boo ::foo bar + " +} -body { + setabs + foo bar 0 +} -cleanup { + foo destroy + unset abs +} -result {{0 2 1 1} 0} + + +# +# NASTY BUG found by tcllib's interp package +# + +test NRE-X.1 {eval in wrong interp} { + set i [interp create] + set res [$i eval { + set x {namespace children ::} + set y [list namespace children ::] + namespace delete {*}[{*}$y] + set j [interp create] + $j eval {namespace delete {*}[namespace children ::]} + namespace eval foo {} + set res [list [eval $x] [eval $y] [$j eval $x] [$j eval $y]] + interp delete $j + set res + }] + interp delete $i + set res +} {::foo ::foo {} {}} + +# +# Test tailcalls +# + +if {[testConstraint tailcall]} { + namespace eval tcl::unsupported namespace export tailcall + namespace import tcl::unsupported::tailcall +} + +test NRE-T.0 {tailcall is constant space} -constraints {tailcall} -setup { + proc a i { + if {[incr i] > 10} { + return [depthDiff] + } + depthDiff + tailcall a $i + } +} -body { + a 0 +} -cleanup { + rename a {} +} -result {0 0 0 0 0 0} + +test NRE-T.1 {tailcall} -constraints {tailcall} -body { + namespace eval a { + variable x *::a + proc xset {} { + set tmp {} + set ns {[namespace current]} + set level [info level] + for {set i 0} {$i <= [info level]} {incr i} { + uplevel #$i "set x $i$ns" + lappend tmp "$i [info level $i]" + } + lrange $tmp 1 end + } + proc foo {} {tailcall xset; set x noreach} + } + namespace eval b { + variable x *::b + proc xset args {error b::xset} + proc moo {} {set x 0; variable y [::a::foo]; set x} + } + variable x *:: + proc xset args {error ::xset} + list [::b::moo] | $x $a::x $b::x | $::b::y +} -cleanup { + unset x + rename xset {} + namespace delete a b +} -result {1::b | 0:: *::a *::b | {{1 ::b::moo} {2 xset}}} + + +test NRE-T.2 {tailcall in non-proc} -constraints {tailcall} -body { + list [catch {namespace eval a [list tailcall set x 1]} msg] $msg +} -result {1 {tailcall can only be called from a proc or lambda}} + +test NRE-T.3 {tailcall falls off tebc} -constraints {tailcall} -body { + unset -nocomplain x + proc foo {} {tailcall set x 1} + list [catch foo msg] $msg [set x] +} -cleanup { + rename foo {} + unset x +} -result {0 1 1} + +test NRE-T.4 {tailcall falls off tebc} -constraints {tailcall} -body { + set x 2 + proc foo {} {tailcall set x 1} + foo + set x +} -cleanup { + rename foo {} + unset x +} -result 1 + +test NRE-T.5 {tailcall falls off tebc} -constraints {tailcall} -body { + set x 2 + namespace eval bar { + variable x 3 + proc foo {} {tailcall set x 1} + } + bar::foo + list $x $bar::x +} -cleanup { + unset x + namespace delete bar +} -result {1 3} + +test NRE-T.6 {tailcall does remove callframes} -constraints {tailcall} -body { + proc foo {} {info level} + proc moo {} {tailcall foo} + proc boo {} {expr {[moo] - [info level]}} + boo +} -cleanup { + rename foo {} + rename moo {} + rename boo {} +} -result 1 + +test NRE-T.7 {tailcall does return} -constraints {tailcall} -setup { + namespace eval ::foo { + variable res {} + proc a {} { + variable res + append res a + tailcall set x 1 + append res a + } + proc b {} { + variable res + append res b + a + append res b + } + proc c {} { + variable res + append res c + b + append res c + } + } +} -body { + namespace eval ::foo c +} -cleanup { + namespace delete ::foo +} -result cbabc + +test NRE-T.8 {tailcall tailcall} -constraints {tailcall} -setup { + namespace eval ::foo { + variable res {} + proc a {} { + variable res + append res a + tailcall tailcall set x 1 + append res a + } + proc b {} { + variable res + append res b + a + append res b + } + proc c {} { + variable res + append res c + b + append res c + } + } +} -body { + namespace eval ::foo c +} -cleanup { + namespace delete ::foo +} -match glob -result *tailcall* -returnCodes error + +test NRE-T.9 {tailcall factorial} -constraints {tailcall} -setup { + proc fact {n {b 1}} { + if {$n == 1} { + return $b + } + tailcall fact [expr {$n-1}] [expr {$n*$b}] + } +} -body { + list [fact 1] [fact 5] [fact 10] [fact 15] +} -cleanup { + rename fact {} +} -result {1 120 3628800 1307674368000} + + +namespace forget tcl::unsupported::tailcall + +# +# Test that ensembles are non-recursive +# + + + +# cleanup +::tcltest::cleanupTests + +if {[testConstraint testnrelevels]} { + namespace forget testnre::* + namespace delete testnre +} + +if {[testConstraint tailcall]} { + namespace forget tcl::unsupported::tailcall +} + +return diff --git a/tests/eofchar.data b/tests/eofchar.data new file mode 100644 index 0000000..4aa3d70 --- /dev/null +++ b/tests/eofchar.data @@ -0,0 +1,846 @@ +Ho hum +Ho hum +Ho hum +Ho hum +Ho hum +Ho hum +Ho hum +Ho hum +Ho hum +Ho hum +Ho hum += +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla +Ge gla Ge gla Ge gla Ge gla diff --git a/tests/ioUtil.test b/tests/ioUtil.test new file mode 100644 index 0000000..0f0d2fc --- /dev/null +++ b/tests/ioUtil.test @@ -0,0 +1,333 @@ +# This file (ioUtil.test) tests the hookable TclStat(), TclAccess(), +# and Tcl_OpenFileChannel, routines in the file generic/tclIOUtils.c. +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: ioUtil.test,v 1.19 2007/12/13 15:26:06 dgp Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest 2 + namespace import -force ::tcltest::* +} + +testConstraint testopenfilechannelproc \ + [llength [info commands testopenfilechannelproc]] +testConstraint testaccessproc [llength [info commands testaccessproc]] +testConstraint teststatproc [llength [info commands teststatproc]] + +set unsetScript { + catch {unset testStat1(size)} + catch {unset testStat2(size)} + catch {unset testStat3(size)} +} + +test ioUtil-1.1 {TclStat: Check that none of the test procs are there.} {} { + catch {file stat testStat1%.fil testStat1} err1 + catch {file stat testStat2%.fil testStat2} err2 + catch {file stat testStat3%.fil testStat3} err3 + list $err1 $err2 $err3 +} {{could not read "testStat1%.fil": no such file or directory} {could not read "testStat2%.fil": no such file or directory} {could not read "testStat3%.fil": no such file or directory}} + +test ioUtil-1.2 {TclStatInsertProc: Insert the 3 test TclStat_ procedures.} {teststatproc} { + catch {teststatproc insert TclpStat} err1 + teststatproc insert TestStatProc1 + teststatproc insert TestStatProc2 + teststatproc insert TestStatProc3 + set err1 +} {bad arg "insert": must be TestStatProc1, TestStatProc2, or TestStatProc3} + +test ioUtil-1.3 {TclStat: Use "file stat ?" to invoke each procedure.} {teststatproc} { + file stat testStat2%.fil testStat2 + file stat testStat1%.fil testStat1 + file stat testStat3%.fil testStat3 + + list $testStat2(size) $testStat1(size) $testStat3(size) +} {2345 1234 3456} + +eval $unsetScript + +test ioUtil-1.4 {TclStatDeleteProc: "TclpStat" function should not be deletable.} {teststatproc} { + catch {teststatproc delete TclpStat} err2 + set err2 +} {"TclpStat": could not be deleteed} + +test ioUtil-1.5 {TclStatDeleteProc: Delete the 2nd TclStat procedure.} {teststatproc} { + # Delete the 2nd procedure and test that it longer exists but that + # the others do actually return a result. + + teststatproc delete TestStatProc2 + file stat testStat1%.fil testStat1 + catch {file stat testStat2%.fil testStat2} err3 + file stat testStat3%.fil testStat3 + + list $testStat1(size) $err3 $testStat3(size) +} {1234 {could not read "testStat2%.fil": no such file or directory} 3456} + +eval $unsetScript + +test ioUtil-1.6 {TclStatDeleteProc: Delete the 1st TclStat procedure.} {teststatproc} { + # Next delete the 1st procedure and test that only the 3rd procedure + # is the only one that exists. + + teststatproc delete TestStatProc1 + catch {file stat testStat1%.fil testStat1} err4 + catch {file stat testStat2%.fil testStat2} err5 + file stat testStat3%.fil testStat3 + + list $err4 $err5 $testStat3(size) +} {{could not read "testStat1%.fil": no such file or directory} {could not read "testStat2%.fil": no such file or directory} 3456} + +eval $unsetScript + +test ioUtil-1.7 {TclStatDeleteProc: Delete the 3rd procedure & verify all are gone.} {teststatproc} { + # Finally delete the 3rd procedure and check that none of the + # procedures exist. + + teststatproc delete TestStatProc3 + catch {file stat testStat1%.fil testStat1} err6 + catch {file stat testStat2%.fil testStat2} err7 + catch {file stat testStat3%.fil testStat3} err8 + + list $err6 $err7 $err8 +} {{could not read "testStat1%.fil": no such file or directory} {could not read "testStat2%.fil": no such file or directory} {could not read "testStat3%.fil": no such file or directory}} + +eval $unsetScript + +test ioUtil-1.8 {TclStatDeleteProc: Verify that all procs have been deleted.} {teststatproc} { + # Attempt to delete all the Stat procs. again to ensure they no longer + # exist and an error is returned. + + catch {teststatproc delete TestStatProc1} err9 + catch {teststatproc delete TestStatProc2} err10 + catch {teststatproc delete TestStatProc3} err11 + + list $err9 $err10 $err11 +} {{"TestStatProc1": could not be deleteed} {"TestStatProc2": could not be deleteed} {"TestStatProc3": could not be deleteed}} + +eval $unsetScript + +test ioUtil-1.9 {TclAccess: Check that none of the test procs are there.} { + catch {file exists testAccess1%.fil} err1 + catch {file exists testAccess2%.fil} err2 + catch {file exists testAccess3%.fil} err3 + list $err1 $err2 $err3 +} {0 0 0} + +test ioUtil-1.10 {TclAccessInsertProc: Insert the 3 test TclAccess_ procedures.} {testaccessproc} { + catch {testaccessproc insert TclpAccess} err1 + testaccessproc insert TestAccessProc1 + testaccessproc insert TestAccessProc2 + testaccessproc insert TestAccessProc3 + set err1 +} {bad arg "insert": must be TestAccessProc1, TestAccessProc2, or TestAccessProc3} + +test ioUtil-2.3 {TclAccess: Use "file access ?" to invoke each procedure.} {testaccessproc} { + list [file exists testAccess2%.fil] \ + [file exists testAccess1%.fil] \ + [file exists testAccess3%.fil] +} {1 1 1} + +test ioUtil-2.4 {TclAccessDeleteProc: "TclpAccess" function should not be deletable.} {testaccessproc} { + catch {testaccessproc delete TclpAccess} err2 + set err2 +} {"TclpAccess": could not be deleteed} + +test ioUtil-2.5 {TclAccessDeleteProc: Delete the 2nd TclAccess procedure.} {testaccessproc} { + # Delete the 2nd procedure and test that it longer exists but that + # the others do actually return a result. + + testaccessproc delete TestAccessProc2 + set res1 [file exists testAccess1%.fil] + catch {file exists testAccess2%.fil} err3 + set res2 [file exists testAccess3%.fil] + + list $res1 $err3 $res2 +} {1 0 1} + +test ioUtil-2.6 {TclAccessDeleteProc: Delete the 1st TclAccess procedure.} {testaccessproc} { + # Next delete the 1st procedure and test that only the 3rd procedure + # is the only one that exists. + + testaccessproc delete TestAccessProc1 + catch {file exists testAccess1%.fil} err4 + catch {file exists testAccess2%.fil} err5 + set res3 [file exists testAccess3%.fil] + + list $err4 $err5 $res3 +} {0 0 1} + +test ioUtil-2.7 {TclAccessDeleteProc: Delete the 3rd procedure & verify all are gone.} {testaccessproc} { + # Finally delete the 3rd procedure and check that none of the + # procedures exist. + + testaccessproc delete TestAccessProc3 + catch {file exists testAccess1%.fil} err6 + catch {file exists testAccess2%.fil} err7 + catch {file exists testAccess3%.fil} err8 + + list $err6 $err7 $err8 +} {0 0 0} + +test ioUtil-2.8 {TclAccessDeleteProc: Verify that all procs have been deleted.} {testaccessproc} { + # Attempt to delete all the Access procs. again to ensure they no longer + # exist and an error is returned. + + catch {testaccessproc delete TestAccessProc1} err9 + catch {testaccessproc delete TestAccessProc2} err10 + catch {testaccessproc delete TestAccessProc3} err11 + + list $err9 $err10 $err11 +} {{"TestAccessProc1": could not be deleteed} {"TestAccessProc2": could not be deleteed} {"TestAccessProc3": could not be deleteed}} + +# Some of the following tests require a writable current directory +set oldpwd [pwd] +cd [temporaryDirectory] + +test ioUtil-3.1 {TclOpenFileChannel: Check that none of the test procs are there.} {testopenfilechannelproc} { + catch {file delete -force {*}[glob *testOpenFileChannel*]} + catch {file exists testOpenFileChannel1%.fil} err1 + catch {file exists testOpenFileChannel2%.fil} err2 + catch {file exists testOpenFileChannel3%.fil} err3 + catch {file exists __testOpenFileChannel1%__.fil} err4 + catch {file exists __testOpenFileChannel2%__.fil} err5 + catch {file exists __testOpenFileChannel3%__.fil} err6 + list $err1 $err2 $err3 $err4 $err5 $err6 +} {0 0 0 0 0 0} + +test ioUtil-3.2 {TclOpenFileChannelInsertProc: Insert the 3 test TclOpenFileChannel_ procedures.} {testopenfilechannelproc} { + catch {testopenfilechannelproc insert TclpOpenFileChannel} err1 + testopenfilechannelproc insert TestOpenFileChannelProc1 + testopenfilechannelproc insert TestOpenFileChannelProc2 + testopenfilechannelproc insert TestOpenFileChannelProc3 + set err1 +} {bad arg "insert": must be TestOpenFileChannelProc1, TestOpenFileChannelProc2, or TestOpenFileChannelProc3} + +test ioUtil-3.3 {TclOpenFileChannel: Use "file openfilechannel ?" to invoke each procedure.} {testopenfilechannelproc} { + close [open __testOpenFileChannel1%__.fil w] + close [open __testOpenFileChannel2%__.fil w] + close [open __testOpenFileChannel3%__.fil w] + + catch { + close [open testOpenFileChannel1%.fil r] + close [open testOpenFileChannel2%.fil r] + close [open testOpenFileChannel3%.fil r] + } err + + file delete __testOpenFileChannel1%__.fil + file delete __testOpenFileChannel2%__.fil + file delete __testOpenFileChannel3%__.fil + + set err +} {} + +test ioUtil-3.4 {TclOpenFileChannelDeleteProc: "TclpOpenFileChannel" function should not be deletable.} {testopenfilechannelproc} { + catch {testopenfilechannelproc delete TclpOpenFileChannel} err2 + set err2 +} {"TclpOpenFileChannel": could not be deleteed} + +test ioUtil-3.5 {TclOpenFileChannelDeleteProc: Delete the 2nd TclOpenFileChannel procedure.} {testopenfilechannelproc} { + # Delete the 2nd procedure and test that it longer exists but that + # the others do actually return a result. + + testopenfilechannelproc delete TestOpenFileChannelProc2 + + close [open __testOpenFileChannel1%__.fil w] + close [open __testOpenFileChannel3%__.fil w] + + catch { + close [open testOpenFileChannel1%.fil r] + catch {close [open testOpenFileChannel2%.fil r]} msg1 + close [open testOpenFileChannel3%.fil r] + } err3 + + file delete __testOpenFileChannel1%__.fil + file delete __testOpenFileChannel3%__.fil + + list $err3 $msg1 +} {{} {couldn't open "testOpenFileChannel2%.fil": no such file or directory}} + +test ioUtil-3.6 {TclOpenFileChannelDeleteProc: Delete the 1st TclOpenFileChannel procedure.} {testopenfilechannelproc} { + # Next delete the 1st procedure and test that only the 3rd procedure + # is the only one that exists. + + testopenfilechannelproc delete TestOpenFileChannelProc1 + + close [open __testOpenFileChannel3%__.fil w] + + catch { + catch {close [open testOpenFileChannel1%.fil r]} msg2 + catch {close [open testOpenFileChannel2%.fil r]} msg3 + close [open testOpenFileChannel3%.fil r] + } err4 + + file delete __testOpenFileChannel3%__.fil + + list $err4 $msg2 $msg3 +} [list {} \ + {couldn't open "testOpenFileChannel1%.fil": no such file or directory}\ + {couldn't open "testOpenFileChannel2%.fil": no such file or directory}] + +test ioUtil-3.7 {TclOpenFileChannelDeleteProc: Delete the 3rd procedure & verify all are gone.} {testopenfilechannelproc} { + # Finally delete the 3rd procedure and check that none of the + # procedures exist. + + testopenfilechannelproc delete TestOpenFileChannelProc3 + catch { + catch {close [open testOpenFileChannel1%.fil r]} msg4 + catch {close [open testOpenFileChannel2%.fil r]} msg5 + catch {close [open testOpenFileChannel3%.fil r]} msg6 + } err5 + + list $err5 $msg4 $msg5 $msg6 +} [list 1 \ + {couldn't open "testOpenFileChannel1%.fil": no such file or directory}\ + {couldn't open "testOpenFileChannel2%.fil": no such file or directory}\ + {couldn't open "testOpenFileChannel3%.fil": no such file or directory}] + +test ioUtil-3.8 {TclOpenFileChannelDeleteProc: Verify that all procs have been deleted.} {testopenfilechannelproc} { + + # Attempt to delete all the OpenFileChannel procs. again to ensure they no + # longer exist and an error is returned. + + catch {testopenfilechannelproc delete TestOpenFileChannelProc1} err9 + catch {testopenfilechannelproc delete TestOpenFileChannelProc2} err10 + catch {testopenfilechannelproc delete TestOpenFileChannelProc3} err11 + + list $err9 $err10 $err11 +} {{"TestOpenFileChannelProc1": could not be deleteed} {"TestOpenFileChannelProc2": could not be deleteed} {"TestOpenFileChannelProc3": could not be deleteed}} + +test ioUtil-4.1 {open ... a+ must not use O_APPEND: Bug 1773127} -setup { + set f [tcltest::makeFile {} ioutil41.tmp] + set fid [open $f wb] + puts -nonewline $fid 123 + close $fid +} -body { + set fid [open $f ab+] + puts -nonewline $fid 456 + seek $fid 2 + set d [read $fid 2] + seek $fid 4 + puts -nonewline $fid x + close $fid + set fid [open $f rb] + append d [read $fid] + close $fid + return $d +} -cleanup { + tcltest::removeFile $f +} -result 341234x6 + +cd $oldpwd + +# cleanup +::tcltest::cleanupTests +return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/macFCmd.test b/tests/macFCmd.test new file mode 100644 index 0000000..f50e7b9 --- /dev/null +++ b/tests/macFCmd.test @@ -0,0 +1,204 @@ +# This file tests the tclfCmd.c file. +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: macFCmd.test,v 1.11 2003/05/14 19:21:24 das Exp $ +# + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import -force ::tcltest::* +} + +# These tests really need to be run from a writable directory, which +# it is assumed [temporaryDirectory] is. +set oldcwd [pwd] +cd [temporaryDirectory] + +catch {file delete -force foo.dir} +file mkdir foo.dir +if {[catch {file attributes foo.dir -readonly 1}]} { + set ::tcltest::testConstraints(fileSharing) 0 + set ::tcltest::testConstraints(notFileSharing) 1 +} else { + set ::tcltest::testConstraints(fileSharing) 1 + set ::tcltest::testConstraints(notFileSharing) 0 + file attributes foo.dir -readonly 0 +} +file delete -force foo.dir + +test macFCmd-1.1 {GetFileFinderAttributes - no file} {macOnly} { + catch {file delete -force foo.file} + list [catch {file attributes foo.file -creator} msg] $msg +} {1 {could not read "foo.file": no such file or directory}} +test macFCmd-1.2 {GetFileFinderAttributes - creator} {macOnly} { + catch {file delete -force foo.file} + catch {close [open foo.file w]} + list [catch {file attributes foo.file -creator} msg] \ + [regexp {MPW |CWIE} $msg] [file delete -force foo.file] +} {0 1 {}} +test macFCmd-1.3 {GetFileFinderAttributes - type} {macOnly} { + catch {file delete -force foo.file} + catch {close [open foo.file w]} + list [catch {file attributes foo.file -type} msg] $msg \ + [file delete -force foo.file] +} {0 TEXT {}} +test macFCmd-1.4 {GetFileFinderAttributes - not hidden} {macOnly} { + catch {file delete -force foo.file} + catch {close [open foo.file w]} + list [catch {file attributes foo.file -hidden} msg] $msg \ + [file delete -force foo.file] +} {0 0 {}} +test macFCmd-1.5 {GetFileFinderAttributes - hidden} {macOnly} { + catch {file delete -force foo.file} + catch {close [open foo.file w]} + file attributes foo.file -hidden 1 + list [catch {file attributes foo.file -hidden} msg] $msg \ + [file delete -force foo.file] +} {0 1 {}} +test macFCmd-1.6 {GetFileFinderAttributes - folder creator} {macOnly} { + catch {file delete -force foo.dir} + file mkdir foo.dir + list [catch {file attributes foo.dir -creator} msg] $msg \ + [file delete -force foo.dir] +} {0 Fldr {}} +test macFCmd-1.7 {GetFileFinderAttributes - folder type} {macOnly} { + catch {file delete -force foo.dir} + file mkdir foo.dir + list [catch {file attributes foo.dir -type} msg] $msg \ + [file delete -force foo.dir] +} {0 Fldr {}} +test macFCmd-1.8 {GetFileFinderAttributes - folder hidden} {macOnly} { + catch {file delete -force foo.dir} + file mkdir foo.dir + list [catch {file attributes foo.dir -hidden} msg] $msg \ + [file delete -force foo.dir] +} {0 0 {}} + +test macFCmd-2.1 {GetFileReadOnly - bad file} {macOnly} { + catch {file delete -force foo.file} + list [catch {file attributes foo.file -readonly} msg] $msg +} {1 {could not read "foo.file": no such file or directory}} +test macFCmd-2.2 {GetFileReadOnly - file not read only} {macOnly} { + catch {file delete -force foo.file} + close [open foo.file w] + list [catch {file attributes foo.file -readonly} msg] $msg \ + [file delete -force foo.file] +} {0 0 {}} +test macFCmd-2.3 {GetFileReadOnly - file read only} {macOnly} { + catch {file delete -force foo.file} + close [open foo.file w] + file attributes foo.file -readonly 1 + list [catch {file attributes foo.file -readonly} msg] $msg \ + [file delete -force foo.file] +} {0 1 {}} +test macFCmd-2.4 {GetFileReadOnly - directory not read only} {macOnly} { + catch {file delete -force foo.dir} + file mkdir foo.dir + list [catch {file attributes foo.dir -readonly} msg] $msg \ + [file delete -force foo.dir] +} {0 0 {}} +test macFCmd-2.5 {GetFileReadOnly - directory read only} {macOnly fileSharing} { + catch {file delete -force foo.dir} + file mkdir foo.dir + file attributes foo.dir -readonly 1 + list [catch {file attributes foo.dir -readonly} msg] $msg \ + [file delete -force foo.dir] +} {0 1 {}} + +test macFCmd-3.1 {SetFileFinderAttributes - bad file} {macOnly} { + catch {file delete -force foo.file} + list [catch {file attributes foo.file -creator FOOO} msg] $msg +} {1 {could not read "foo.file": no such file or directory}} +test macFCmd-3.2 {SetFileFinderAttributes - creator} {macOnly} { + catch {file delete -force foo.file} + close [open foo.file w] + list [catch {file attributes foo.file -creator FOOO} msg] $msg \ + [file attributes foo.file -creator] [file delete -force foo.file] +} {0 {} FOOO {}} +test macFCmd-3.3 {SetFileFinderAttributes - bad creator} {macOnly} { + catch {file delete -force foo.file} + close [open foo.file w] + list [catch {file attributes foo.file -creator 0} msg] $msg \ + [file delete -force foo.file] +} {1 {expected Macintosh OS type but got "0"} {}} +test macFCmd-3.4 {SetFileFinderAttributes - hidden} {macOnly} { + catch {file delete -force foo.file} + close [open foo.file w] + list [catch {file attributes foo.file -hidden 1} msg] $msg \ + [file attributes foo.file -hidden] [file delete -force foo.file] +} {0 {} 1 {}} +test macFCmd-3.5 {SetFileFinderAttributes - type} {macOnly} { + catch {file delete -force foo.file} + close [open foo.file w] + list [catch {file attributes foo.file -type FOOO} msg] $msg \ + [file attributes foo.file -type] [file delete -force foo.file] +} {0 {} FOOO {}} +test macFCmd-3.6 {SetFileFinderAttributes - bad type} {macOnly} { + catch {file delete -force foo.file} + close [open foo.file w] + list [catch {file attributes foo.file -type 0} msg] $msg \ + [file delete -force foo.file] +} {1 {expected Macintosh OS type but got "0"} {}} +test macFCmd-3.7 {SetFileFinderAttributes - directory} {macOnly} { + catch {file delete -force foo.dir} + file mkdir foo.dir + list [catch {file attributes foo.dir -creator FOOO} msg] \ + $msg [file delete -force foo.dir] +} {1 {cannot set -creator: "foo.dir" is a directory} {}} + +test macFCmd-4.1 {SetFileReadOnly - bad file} {macOnly} { + catch {file delete -force foo.file} + list [catch {file attributes foo.file -readonly 1} msg] $msg +} {1 {could not read "foo.file": no such file or directory}} +test macFCmd-4.2 {SetFileReadOnly - file not readonly} {macOnly} { + catch {file delete -force foo.file} + close [open foo.file w] + list [catch {file attributes foo.file -readonly 0} msg] \ + $msg [file attributes foo.file -readonly] [file delete -force foo.file] +} {0 {} 0 {}} +test macFCmd-4.3 {SetFileReadOnly - file readonly} {macOnly} { + catch {file delete -force foo.file} + close [open foo.file w] + list [catch {file attributes foo.file -readonly 1} msg] \ + $msg [file attributes foo.file -readonly] [file delete -force foo.file] +} {0 {} 1 {}} +test macFCmd-4.4 {SetFileReadOnly - directory not readonly} \ + {macOnly fileSharing} { + catch {file delete -force foo.dir} + file mkdir foo.dir + list [catch {file attributes foo.dir -readonly 0} msg] \ + $msg [file attributes foo.dir -readonly] [file delete -force foo.dir] +} {0 {} 0 {}} +test macFCmd-4.5 {SetFileReadOnly - directory not readonly} \ + {macOnly notFileSharing} { + catch {file delete -force foo.dir} + file mkdir foo.dir + list [catch {file attributes foo.dir -readonly 0} msg] $msg \ + [file delete -force foo.dir] +} {1 {cannot set a directory to read-only when File Sharing is turned off} {}} +test macFCmd-4.6 {SetFileReadOnly - directory readonly} {macOnly fileSharing} { + catch {file delete -force foo.dir} + file mkdir foo.dir + list [catch {file attributes foo.dir -readonly 1} msg] $msg \ + [file attributes foo.dir -readonly] [file delete -force foo.dir] +} {0 {} 1 {}} +test macFCmd-4.7 {SetFileReadOnly - directory readonly} {macOnly notFileSharing} { + catch {file delete -force foo.dir} + file mkdir foo.dir + list [catch {file attributes foo.dir -readonly 1} msg] $msg \ + [file delete -force foo.dir] +} {1 {cannot set a directory to read-only when File Sharing is turned off} {}} + +# cleanup +cd $oldcwd +::tcltest::cleanupTests +return diff --git a/tests/osa.test b/tests/osa.test new file mode 100644 index 0000000..7a16ef1 --- /dev/null +++ b/tests/osa.test @@ -0,0 +1,48 @@ +# Commands covered: AppleScript +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: osa.test,v 1.6 2000/04/10 17:19:02 ericm Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import -force ::tcltest::* +} + +# Only run the test if we can load the AppleScript command +set ::tcltest::testConstraints(appleScript) [expr {[info commands AppleScript] != ""}] + +test osa-1.1 {Tcl_OSAComponentCmd} {macOnly appleScript} { + list [catch AppleScript msg] $msg +} {1 {wrong # args: should be "AppleScript option ?arg ...?"}} +test osa-1.2 {Tcl_OSAComponentCmd} {macOnly appleScript} { + list [catch {AppleScript x} msg] $msg +} {1 {bad option "x": should be compile, decompile, delete, execute, info, load, run or store}} + +test osa-1.3 {TclOSACompileCmd} {macOnly appleScript} { + list [catch {AppleScript compile} msg] $msg +} {1 {wrong # args: should be "AppleScript compile ?options? code"}} + +# cleanup +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/pkg.test b/tests/pkg.test new file mode 100644 index 0000000..4f92d4c --- /dev/null +++ b/tests/pkg.test @@ -0,0 +1,1222 @@ +# -*- tcl -*- +# Commands covered: pkg +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1995-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: pkg.test,v 1.31 2008/07/19 22:50:39 nijtmans Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest 2 + namespace import -force ::tcltest::* +} + +# Do all this in a slave interp to avoid garbaging the +# package list +set i [interp create] +interp eval $i [list set argv $argv] +interp eval $i [list package require tcltest 2] +interp eval $i [list namespace import -force ::tcltest::*] +interp eval $i { + +package forget {*}[package names] +set oldPkgUnknown [package unknown] +package unknown {} +set oldPath $auto_path +set auto_path "" + +test pkg-1.1 {Tcl_PkgProvide procedure} { + package forget t + package provide t 2.3 +} {} +test pkg-1.2 {Tcl_PkgProvide procedure} { + package forget t + package provide t 2.3 + list [catch {package provide t 2.2} msg] $msg +} {1 {conflicting versions provided for package "t": 2.3, then 2.2}} +test pkg-1.3 {Tcl_PkgProvide procedure} { + package forget t + package provide t 2.3 + list [catch {package provide t 2.4} msg] $msg +} {1 {conflicting versions provided for package "t": 2.3, then 2.4}} +test pkg-1.4 {Tcl_PkgProvide procedure} { + package forget t + package provide t 2.3 + list [catch {package provide t 3.3} msg] $msg +} {1 {conflicting versions provided for package "t": 2.3, then 3.3}} +test pkg-1.5 {Tcl_PkgProvide procedure} { + package forget t + package provide t 2.3 + package provide t 2.3 +} {} + +test pkg-1.6 {Tcl_PkgProvide procedure} { + package forget t + package provide t 2.3a1 +} {} + +set n 0 +foreach v { + 2.3k1 2a3a2 2ab3 2.a4 2.b4 2b.4 2a.4 2ba4 2a4b1 + 2b4a1 2b3b2 +} { + test pkg-1.7.$n {Tcl_PkgProvide procedure} { + package forget t + list [catch {package provide t $v} msg] $msg + } [list 1 "expected version number but got \"$v\""] + incr n +} + +test pkg-2.1 {Tcl_PkgRequire procedure, picking best version} { + package forget t + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i; package provide t $i" + } + set x xxx + package require t + set x +} {3.4} +test pkg-2.2 {Tcl_PkgRequire procedure, picking best version} { + package forget t + foreach i {1.4 3.4 2.3 2.4 2.2 3.5 3.2} { + package ifneeded t $i "set x $i; package provide t $i" + } + set x xxx + package require t + set x +} {3.5} +test pkg-2.3 {Tcl_PkgRequire procedure, picking best version} { + package forget t + foreach i {3.5 2.1 2.3} { + package ifneeded t $i "set x $i; package provide t $i" + } + set x xxx + package require t 2.2 + set x +} {2.3} +test pkg-2.4 {Tcl_PkgRequire procedure, picking best version} { + package forget t + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i; package provide t $i" + } + set x xxx + package require -exact t 2.3 + set x +} {2.3} +test pkg-2.5 {Tcl_PkgRequire procedure, picking best version} { + package forget t + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i; package provide t $i" + } + set x xxx + package require t 2.1 + set x +} {2.4} +test pkg-2.6 {Tcl_PkgRequire procedure, can't find suitable version} { + package forget t + package unknown {} + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i" + } + list [catch {package require t 2.5} msg] $msg +} {1 {can't find package t 2.5}} +test pkg-2.7 {Tcl_PkgRequire procedure, can't find suitable version} { + package forget t + package unknown {} + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i" + } + list [catch {package require t 4.1} msg] $msg +} {1 {can't find package t 4.1}} +test pkg-2.8 {Tcl_PkgRequire procedure, can't find suitable version} { + package forget t + package unknown {} + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i" + } + list [catch {package require -exact t 1.3} msg] $msg +} {1 {can't find package t exactly 1.3}} +test pkg-2.9 {Tcl_PkgRequire procedure, can't find suitable version} { + package forget t + package unknown {} + list [catch {package require t} msg] $msg +} {1 {can't find package t}} +test pkg-2.10 {Tcl_PkgRequire procedure, error in ifneeded script} -body { + package forget t + package ifneeded t 2.1 {package provide t 2.1; error "ifneeded test"} + list [catch {package require t 2.1} msg] $msg $::errorInfo +} -match glob -result {1 {ifneeded test} {ifneeded test + while executing +"error "ifneeded test"" + ("package ifneeded*" script) + invoked from within +"package require t 2.1"}} +test pkg-2.11 {Tcl_PkgRequire procedure, ifneeded script doesn't provide package} -body { + package forget t + package ifneeded t 2.1 "set x invoked" + set x xxx + list [catch {package require t 2.1} msg] $msg $x +} -match glob -result {1 * invoked} +test pkg-2.12 {Tcl_PkgRequire procedure, self-deleting script} { + package forget t + package ifneeded t 1.2 "package forget t; set x 1.2; package provide t 1.2" + set x xxx + package require t 1.2 + set x +} {1.2} +test pkg-2.13 {Tcl_PkgRequire procedure, "package unknown" support} { + proc pkgUnknown args { + # args = name requirement + # requirement = v-v (for exact version) + global x + set x $args + package provide [lindex $args 0] [lindex [split [lindex $args 1] -] 0] + } + package forget t + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i" + } + package unknown pkgUnknown + set x xxx + package require -exact t 1.5 + package unknown {} + set x +} {t 1.5-1.5} +test pkg-2.14 {Tcl_PkgRequire procedure, "package unknown" support} { + proc pkgUnknown args { + package ifneeded t 1.2 "set x loaded; package provide t 1.2" + } + package forget t + package unknown pkgUnknown + set x xxx + set result [list [package require t] $x] + package unknown {} + set result +} {1.2 loaded} +test pkg-2.15 {Tcl_PkgRequire procedure, "package unknown" support} { + proc pkgUnknown args { + global x + set x $args + package provide [lindex $args 0] 2.0 + } + package forget {a b} + package unknown pkgUnknown + set x xxx + package require {a b} + package unknown {} + set x +} {{a b} 0-} +test pkg-2.16 {Tcl_PkgRequire procedure, "package unknown" error} { + proc pkgUnknown args { + error "testing package unknown" + } + package forget t + package unknown pkgUnknown + set result [list [catch {package require t} msg] $msg $::errorInfo] + package unknown {} + set result +} {1 {testing package unknown} {testing package unknown + while executing +"error "testing package unknown"" + (procedure "pkgUnknown" line 2) + invoked from within +"pkgUnknown t 0-" + ("package unknown" script) + invoked from within +"package require t"}} +test pkg-2.17 {Tcl_PkgRequire procedure, "package unknown" doesn't load package} { + proc pkgUnknown args { + global x + set x $args + } + package forget t + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i" + } + package unknown pkgUnknown + set x xxx + set result [list [catch {package require -exact t 1.5} msg] $msg $x] + package unknown {} + set result +} {1 {can't find package t exactly 1.5} {t 1.5-1.5}} +test pkg-2.18 {Tcl_PkgRequire procedure, version checks} { + package forget t + package provide t 2.3 + package require t +} {2.3} +test pkg-2.19 {Tcl_PkgRequire procedure, version checks} { + package forget t + package provide t 2.3 + package require t 2.1 +} {2.3} +test pkg-2.20 {Tcl_PkgRequire procedure, version checks} { + package forget t + package provide t 2.3 + package require t 2.3 +} {2.3} +test pkg-2.21 {Tcl_PkgRequire procedure, version checks} { + package forget t + package provide t 2.3 + list [catch {package require t 2.4} msg] $msg +} {1 {version conflict for package "t": have 2.3, need 2.4}} +test pkg-2.22 {Tcl_PkgRequire procedure, version checks} { + package forget t + package provide t 2.3 + list [catch {package require t 1.2} msg] $msg +} {1 {version conflict for package "t": have 2.3, need 1.2}} +test pkg-2.23 {Tcl_PkgRequire procedure, version checks} { + package forget t + package provide t 2.3 + package require -exact t 2.3 +} {2.3} +test pkg-2.24 {Tcl_PkgRequire procedure, version checks} { + package forget t + package provide t 2.3 + list [catch {package require -exact t 2.2} msg] $msg +} {1 {version conflict for package "t": have 2.3, need exactly 2.2}} +test pkg-2.25 {Tcl_PkgRequire procedure, error in ifneeded script} -body { + package forget t + package ifneeded t 2.1 {package provide t 2.1; error "ifneeded test" EI} + list [catch {package require t 2.1} msg] $msg $::errorInfo +} -match glob -result {1 {ifneeded test} {EI + ("package ifneeded*" script) + invoked from within +"package require t 2.1"}} +test pkg-2.26 {Tcl_PkgRequire procedure, error in ifneeded script} -body { + package forget t + package ifneeded t 2.1 {package provide t 2.1; foreach x 1 {error "ifneeded test" EI}} + list [catch {package require t 2.1} msg] $msg $::errorInfo +} -match glob -result {1 {ifneeded test} {EI + ("foreach" body line 1) + invoked from within +"foreach x 1 {error "ifneeded test" EI}" + ("package ifneeded*" script) + invoked from within +"package require t 2.1"}} +test pkg-2.27 {Tcl_PkgRequire: circular dependency} -setup { + package forget foo +} -body { + package ifneeded foo 1 {package require foo 1} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob -result {circular package dependency:*} +test pkg-2.28 {Tcl_PkgRequire: circular dependency} -setup { + package forget foo +} -body { + package ifneeded foo 1 {package require foo 2} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob -result {circular package dependency:*} +test pkg-2.29 {Tcl_PkgRequire: circular dependency} -setup { + package forget foo + package forget bar +} -body { + package ifneeded foo 1 {package require bar 1; package provide foo 1} + package ifneeded bar 1 {package require foo 1; package provide bar 1} + package require foo 1 +} -cleanup { + package forget foo + package forget bar +} -returnCodes error -match glob -result {circular package dependency:*} +test pkg-2.30 {Tcl_PkgRequire: circular dependency} -setup { + package forget foo + package forget bar +} -body { + package ifneeded foo 1 {package require bar 1; package provide foo 1} + package ifneeded foo 2 {package provide foo 2} + package ifneeded bar 1 {package require foo 2; package provide bar 1} + package require foo 1 +} -cleanup { + package forget foo + package forget bar +} -returnCodes error -match glob -result {circular package dependency:*} +test pkg-2.31 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1 {package provide foo 1; error foo} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob -result foo +test pkg-2.32 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1 {package provide foo 1; error foo} + catch {package require foo 1} + package provide foo +} -cleanup { + package forget foo +} -result {} +test pkg-2.33 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1 {package provide foo 2} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob -result {attempt to provide package * failed:*} +test pkg-2.34 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1 {package provide foo 1.1} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob -result {attempt to provide package * failed:*} +test pkg-2.34.1 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1.1 {package provide foo 1} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob -result {attempt to provide package * failed:*} +test pkg-2.34.2 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1.1 {package provide foo 1} + package require foo 1.1 +} -cleanup { + package forget foo +} -returnCodes error -match glob -result {attempt to provide package * failed:*} +test pkg-2.35 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1 {} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob -result {attempt to provide package * failed:*} +test pkg-2.35.1 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1 {break} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob \ +-result {attempt to provide package * failed: bad return code:*} +test pkg-2.36 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1 {continue} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob \ +-result {attempt to provide package * failed: bad return code:*} +test pkg-2.37 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1 {return} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob \ +-result {attempt to provide package * failed: bad return code:*} +test pkg-2.38 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1 {return -level 0 -code 10} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob \ +-result {attempt to provide package * failed: bad return code:*} +test pkg-2.39 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo + set saveUnknown [package unknown] + package unknown {package provide foo 2 ;#} +} -body { + package require foo 1 +} -cleanup { + package forget foo + package unknown $saveUnknown +} -returnCodes error -match glob -result * +test pkg-2.40 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo + set saveUnknown [package unknown] + package unknown {break ;#} +} -body { + package require foo 1 +} -cleanup { + package forget foo + package unknown $saveUnknown +} -returnCodes error -match glob -result {bad return code:*} +test pkg-2.41 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo + set saveUnknown [package unknown] + package unknown {continue ;#} +} -body { + package require foo 1 +} -cleanup { + package forget foo + package unknown $saveUnknown +} -returnCodes error -match glob -result {bad return code:*} +test pkg-2.42 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo + set saveUnknown [package unknown] + package unknown {return ;#} +} -body { + package require foo 1 +} -cleanup { + package forget foo + package unknown $saveUnknown +} -returnCodes error -match glob -result {bad return code:*} +test pkg-2.43 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo + set saveUnknown [package unknown] + package unknown {return -level 0 -code 10 ;#} +} -body { + package require foo 1 +} -cleanup { + package forget foo + package unknown $saveUnknown +} -returnCodes error -match glob -result {bad return code:*} +test pkg-2.44 {Tcl_PkgRequire: exact version matching (1578344)} -setup { + package provide demo 1.2.3 +} -body { + package require -exact demo 1.2 +} -cleanup { + package forget demo +} -returnCodes error -result {version conflict for package "demo": have 1.2.3, need exactly 1.2} + + +test pkg-2.50 {Tcl_PkgRequire procedure, picking best stable version} { + package forget t + foreach i {1.4 3.4 4.0a1 2.3 2.4 2.2} { + package ifneeded t $i "set x $i; package provide t $i" + } + set x xxx + package require t + set x +} {3.4} + +test pkg-2.51 {Tcl_PkgRequire procedure, picking best stable version} { + package forget t + foreach i {1.2b1 1.2 1.3a2 1.3} { + package ifneeded t $i "set x $i; package provide t $i" + } + set x xxx + package require t + set x +} {1.3} + +test pkg-2.52 {Tcl_PkgRequire procedure, picking best stable version} { + package forget t + foreach i {1.2b1 1.2 1.3 1.3a2} { + package ifneeded t $i "set x $i; package provide t $i" + } + set x xxx + package require t + set x +} {1.3} + + + +test pkg-3.1 {Tcl_PackageCmd procedure} { + list [catch {package} msg] $msg +} {1 {wrong # args: should be "package option ?arg ...?"}} +test pkg-3.2 {Tcl_PackageCmd procedure, "forget" option} { + foreach i [package names] { + package forget $i + } + package names +} {} +test pkg-3.3 {Tcl_PackageCmd procedure, "forget" option} { + foreach i [package names] { + package forget $i + } + package forget foo +} {} +test pkg-3.4 {Tcl_PackageCmd procedure, "forget" option} { + foreach i [package names] { + package forget $i + } + package ifneeded t 1.1 {first script} + package ifneeded t 2.3 {second script} + package ifneeded x 1.4 {x's script} + set result {} + lappend result [lsort [package names]] [package versions t] + package forget t + lappend result [lsort [package names]] [package versions t] +} {{t x} {1.1 2.3} x {}} +test pkg-3.5 {Tcl_PackageCmd procedure, "forget" option} { + foreach i [package names] { + package forget $i + } + package ifneeded a 1.1 {first script} + package ifneeded b 2.3 {second script} + package ifneeded c 1.4 {third script} + package forget + set result [list [lsort [package names]]] + package forget a c + lappend result [lsort [package names]] +} {{a b c} b} +test pkg-3.5.1 {Tcl_PackageCmd procedure, "forget" option} { + # Test for Bug 415273 + package ifneeded a 1 "I should have been forgotten" + package forget no-such-package a + set x [package ifneeded a 1] + package forget a + set x +} {} +test pkg-3.6 {Tcl_PackageCmd procedure, "ifneeded" option} { + list [catch {package ifneeded a} msg] $msg +} {1 {wrong # args: should be "package ifneeded package version ?script?"}} +test pkg-3.7 {Tcl_PackageCmd procedure, "ifneeded" option} { + list [catch {package ifneeded a b c d} msg] $msg +} {1 {wrong # args: should be "package ifneeded package version ?script?"}} +test pkg-3.8 {Tcl_PackageCmd procedure, "ifneeded" option} { + list [catch {package ifneeded t xyz} msg] $msg +} {1 {expected version number but got "xyz"}} +test pkg-3.9 {Tcl_PackageCmd procedure, "ifneeded" option} { + foreach i [package names] { + package forget $i + } + list [package ifneeded foo 1.1] [package names] +} {{} {}} +test pkg-3.10 {Tcl_PackageCmd procedure, "ifneeded" option} { + package forget t + package ifneeded t 1.4 "script for t 1.4" + list [package names] [package ifneeded t 1.4] [package versions t] +} {t {script for t 1.4} 1.4} +test pkg-3.11 {Tcl_PackageCmd procedure, "ifneeded" option} { + package forget t + package ifneeded t 1.4 "script for t 1.4" + list [package ifneeded t 1.5] [package names] [package versions t] +} {{} t 1.4} +test pkg-3.12 {Tcl_PackageCmd procedure, "ifneeded" option} { + package forget t + package ifneeded t 1.4 "script for t 1.4" + package ifneeded t 1.4 "second script for t 1.4" + list [package ifneeded t 1.4] [package names] [package versions t] +} {{second script for t 1.4} t 1.4} +test pkg-3.13 {Tcl_PackageCmd procedure, "ifneeded" option} { + package forget t + package ifneeded t 1.4 "script for t 1.4" + package ifneeded t 1.2 "second script" + package ifneeded t 3.1 "last script" + list [package ifneeded t 1.2] [package versions t] +} {{second script} {1.4 1.2 3.1}} +test pkg-3.14 {Tcl_PackageCmd procedure, "names" option} { + list [catch {package names a} msg] $msg +} {1 {wrong # args: should be "package names"}} +test pkg-3.15 {Tcl_PackageCmd procedure, "names" option} { + foreach i [package names] { + package forget $i + } + package names +} {} +test pkg-3.16 {Tcl_PackageCmd procedure, "names" option} { + foreach i [package names] { + package forget $i + } + package ifneeded x 1.2 {dummy} + package provide x 1.3 + package provide y 2.4 + catch {package require z 47.16} + lsort [package names] +} {x y} +test pkg-3.17 {Tcl_PackageCmd procedure, "provide" option} { + list [catch {package provide} msg] $msg +} {1 {wrong # args: should be "package provide package ?version?"}} +test pkg-3.18 {Tcl_PackageCmd procedure, "provide" option} { + list [catch {package provide a b c} msg] $msg +} {1 {wrong # args: should be "package provide package ?version?"}} +test pkg-3.19 {Tcl_PackageCmd procedure, "provide" option} { + package forget t + package provide t +} {} +test pkg-3.20 {Tcl_PackageCmd procedure, "provide" option} { + package forget t + package provide t 2.3 + package provide t +} {2.3} +test pkg-3.21 {Tcl_PackageCmd procedure, "provide" option} { + package forget t + list [catch {package provide t a.b} msg] $msg +} {1 {expected version number but got "a.b"}} +test pkg-3.22 {Tcl_PackageCmd procedure, "require" option} { + list [catch {package require} msg] $msg +} {1 {wrong # args: should be "package require ?-exact? package ?requirement ...?"}} + +test pkg-3.24 {Tcl_PackageCmd procedure, "require" option} { + list [catch {package require -exact a b c} msg] $msg + # Exact syntax: -exact name version + # name ?requirement ...? +} {1 {wrong # args: should be "package require ?-exact? package ?requirement ...?"}} + +test pkg-3.26 {Tcl_PackageCmd procedure, "require" option} { + list [catch {package require x a.b} msg] $msg +} {1 {expected version number but got "a.b"}} +test pkg-3.27 {Tcl_PackageCmd procedure, "require" option} { + list [catch {package require -exact x a.b} msg] $msg +} {1 {expected version number but got "a.b"}} +test pkg-3.28 {Tcl_PackageCmd procedure, "require" option} { + list [catch {package require -exact x} msg] $msg +} {1 {wrong # args: should be "package require ?-exact? package ?requirement ...?"}} +test pkg-3.29 {Tcl_PackageCmd procedure, "require" option} { + list [catch {package require -exact} msg] $msg +} {1 {wrong # args: should be "package require ?-exact? package ?requirement ...?"}} +test pkg-3.30 {Tcl_PackageCmd procedure, "require" option} { + package forget t + package provide t 2.3 + package require t 2.1 +} {2.3} +test pkg-3.31 {Tcl_PackageCmd procedure, "require" option} { + package forget t + list [catch {package require t} msg] $msg +} {1 {can't find package t}} +test pkg-3.32 {Tcl_PackageCmd procedure, "require" option} { + package forget t + package ifneeded t 2.3 "error {synthetic error}" + list [catch {package require t 2.3} msg] $msg +} {1 {synthetic error}} +test pkg-3.33 {Tcl_PackageCmd procedure, "unknown" option} { + list [catch {package unknown a b} msg] $msg +} {1 {wrong # args: should be "package unknown ?command?"}} +test pkg-3.34 {Tcl_PackageCmd procedure, "unknown" option} { + package unknown "test script" + package unknown +} {test script} +test pkg-3.35 {Tcl_PackageCmd procedure, "unknown" option} { + package unknown "test script" + package unknown {} + package unknown +} {} +test pkg-3.36 {Tcl_PackageCmd procedure, "vcompare" option} { + list [catch {package vcompare a} msg] $msg +} {1 {wrong # args: should be "package vcompare version1 version2"}} +test pkg-3.37 {Tcl_PackageCmd procedure, "vcompare" option} { + list [catch {package vcompare a b c} msg] $msg +} {1 {wrong # args: should be "package vcompare version1 version2"}} +test pkg-3.38 {Tcl_PackageCmd procedure, "vcompare" option} { + list [catch {package vcompare x.y 3.4} msg] $msg +} {1 {expected version number but got "x.y"}} +test pkg-3.39 {Tcl_PackageCmd procedure, "vcompare" option} { + list [catch {package vcompare 2.1 a.b} msg] $msg +} {1 {expected version number but got "a.b"}} +test pkg-3.40 {Tcl_PackageCmd procedure, "vcompare" option} { + package vc 2.1 2.3 +} {-1} +test pkg-3.41 {Tcl_PackageCmd procedure, "vcompare" option} { + package vc 2.2.4 2.2.4 +} {0} +test pkg-3.42 {Tcl_PackageCmd procedure, "versions" option} { + list [catch {package versions} msg] $msg +} {1 {wrong # args: should be "package versions package"}} +test pkg-3.43 {Tcl_PackageCmd procedure, "versions" option} { + list [catch {package versions a b} msg] $msg +} {1 {wrong # args: should be "package versions package"}} +test pkg-3.44 {Tcl_PackageCmd procedure, "versions" option} { + package forget t + package versions t +} {} +test pkg-3.45 {Tcl_PackageCmd procedure, "versions" option} { + package forget t + package provide t 2.3 + package versions t +} {} +test pkg-3.46 {Tcl_PackageCmd procedure, "versions" option} { + package forget t + package ifneeded t 2.3 x + package ifneeded t 2.4 y + package versions t +} {2.3 2.4} +test pkg-3.47 {Tcl_PackageCmd procedure, "vsatisfies" option} { + list [catch {package vsatisfies a} msg] $msg +} {1 {wrong # args: should be "package vsatisfies version ?requirement ...?"}} + +test pkg-3.49 {Tcl_PackageCmd procedure, "vsatisfies" option} { + list [catch {package vsatisfies x.y 3.4} msg] $msg +} {1 {expected version number but got "x.y"}} +test pkg-3.50 {Tcl_PackageCmd procedure, "vsatisfies" option} { + list [catch {package vcompare 2.1 a.b} msg] $msg +} {1 {expected version number but got "a.b"}} +test pkg-3.51 {Tcl_PackageCmd procedure, "vsatisfies" option} { + package vs 2.3 2.1 +} {1} +test pkg-3.52 {Tcl_PackageCmd procedure, "vsatisfies" option} { + package vs 2.3 1.2 +} {0} +test pkg-3.53 {Tcl_PackageCmd procedure, "versions" option} { + list [catch {package foo} msg] $msg +} {1 {bad option "foo": must be forget, ifneeded, names, prefer, present, provide, require, unknown, vcompare, versions, or vsatisfies}} + +test pkg-3.54 {Tcl_PackageCmd procedure, "vsatisfies" option} { + list [catch {package vsatisfies 2.1 2.1-3.2-4.5} msg] $msg +} {1 {expected versionMin-versionMax but got "2.1-3.2-4.5"}} + +test pkg-3.55 {Tcl_PackageCmd procedure, "vsatisfies" option} { + list [catch {package vsatisfies 2.1 3.2-x.y} msg] $msg +} {1 {expected version number but got "x.y"}} + +test pkg-3.56 {Tcl_PackageCmd procedure, "vsatisfies" option} { + list [catch {package vsatisfies 2.1 x.y-3.2} msg] $msg +} {1 {expected version number but got "x.y"}} + + +# No tests for FindPackage; can't think up anything detectable +# errors. + +test pkg-4.1 {TclFreePackageInfo procedure} { + interp create foo + foo eval { + package ifneeded t 2.3 x + package ifneeded t 2.4 y + package ifneeded x 3.1 z + package provide q 4.3 + package unknown "will this get freed?" + } + interp delete foo +} {} +test pkg-4.2 {TclFreePackageInfo procedure} -body { + interp create foo + foo eval { + package ifneeded t 2.3 x + package ifneeded t 2.4 y + package ifneeded x 3.1 z + package provide q 4.3 + } + foo alias z kill + proc kill {} { + interp delete foo + } + foo eval package require x 3.1 +} -returnCodes error -match glob -result * + +test pkg-5.1 {CheckVersion procedure} { + list [catch {package vcompare 1 2.1} msg] $msg +} {0 -1} +test pkg-5.2 {CheckVersion procedure} { + list [catch {package vcompare .1 2.1} msg] $msg +} {1 {expected version number but got ".1"}} +test pkg-5.3 {CheckVersion procedure} { + list [catch {package vcompare 111.2a.3 2.1} msg] $msg +} {1 {expected version number but got "111.2a.3"}} +test pkg-5.4 {CheckVersion procedure} { + list [catch {package vcompare 1.2.3. 2.1} msg] $msg +} {1 {expected version number but got "1.2.3."}} +test pkg-5.5 {CheckVersion procedure} { + list [catch {package vcompare 1.2..3 2.1} msg] $msg +} {1 {expected version number but got "1.2..3"}} + +test pkg-6.1 {ComparePkgVersions procedure} { + package vcompare 1.23 1.22 +} {1} +test pkg-6.2 {ComparePkgVersions procedure} { + package vcompare 1.22.1.2.3 1.22.1.2.3 +} {0} +test pkg-6.3 {ComparePkgVersions procedure} { + package vcompare 1.21 1.22 +} {-1} +test pkg-6.4 {ComparePkgVersions procedure} { + package vcompare 1.21 1.21.2 +} {-1} +test pkg-6.5 {ComparePkgVersions procedure} { + package vcompare 1.21.1 1.21 +} {1} +test pkg-6.6 {ComparePkgVersions procedure} { + package vsatisfies 1.21.1 1.21 +} {1} +test pkg-6.7 {ComparePkgVersions procedure} { + package vsatisfies 2.22.3 1.21 +} {0} +test pkg-6.8 {ComparePkgVersions procedure} { + package vsatisfies 1 1 +} {1} +test pkg-6.9 {ComparePkgVersions procedure} { + package vsatisfies 2 1 +} {0} + +test pkg-7.1 {Tcl_PkgPresent procedure, any version} { + package forget t + package provide t 2.4 + package present t +} {2.4} +test pkg-7.2 {Tcl_PkgPresent procedure, correct version} { + package forget t + package provide t 2.4 + package present t 2.4 +} {2.4} +test pkg-7.3 {Tcl_PkgPresent procedure, satisfying version} { + package forget t + package provide t 2.4 + package present t 2.0 +} {2.4} +test pkg-7.4 {Tcl_PkgPresent procedure, not satisfying version} { + package forget t + package provide t 2.4 + list [catch {package present t 2.6} msg] $msg +} {1 {version conflict for package "t": have 2.4, need 2.6}} +test pkg-7.5 {Tcl_PkgPresent procedure, not satisfying version} { + package forget t + package provide t 2.4 + list [catch {package present t 1.0} msg] $msg +} {1 {version conflict for package "t": have 2.4, need 1.0}} +test pkg-7.6 {Tcl_PkgPresent procedure, exact version} { + package forget t + package provide t 2.4 + package present -exact t 2.4 +} {2.4} +test pkg-7.7 {Tcl_PkgPresent procedure, not exact version} { + package forget t + package provide t 2.4 + list [catch {package present -exact t 2.3} msg] $msg +} {1 {version conflict for package "t": have 2.4, need exactly 2.3}} +test pkg-7.8 {Tcl_PkgPresent procedure, unknown package} { + package forget t + list [catch {package present t} msg] $msg +} {1 {package t is not present}} +test pkg-7.9 {Tcl_PkgPresent procedure, unknown package} { + package forget t + list [catch {package present t 2.4} msg] $msg +} {1 {package t 2.4 is not present}} +test pkg-7.10 {Tcl_PkgPresent procedure, unknown package} { + package forget t + list [catch {package present -exact t 2.4} msg] $msg +} {1 {package t 2.4 is not present}} +test pkg-7.11 {Tcl_PackageCmd procedure, "present" option} { + list [catch {package present} msg] $msg +} {1 {wrong # args: should be "package present ?-exact? package ?requirement ...?"}} +test pkg-7.12 {Tcl_PackageCmd procedure, "present" option} { + list [catch {package present a b c} msg] $msg +} {1 {expected version number but got "b"}} +test pkg-7.13 {Tcl_PackageCmd procedure, "present" option} { + list [catch {package present -exact a b c} msg] $msg +} {1 {wrong # args: should be "package present ?-exact? package ?requirement ...?"}} +test pkg-7.14 {Tcl_PackageCmd procedure, "present" option} { + list [catch {package present -bs a b} msg] $msg +} {1 {expected version number but got "a"}} +test pkg-7.15 {Tcl_PackageCmd procedure, "present" option} { + list [catch {package present x a.b} msg] $msg +} {1 {expected version number but got "a.b"}} +test pkg-7.16 {Tcl_PackageCmd procedure, "present" option} { + list [catch {package present -exact x a.b} msg] $msg +} {1 {expected version number but got "a.b"}} +test pkg-7.17 {Tcl_PackageCmd procedure, "present" option} { + list [catch {package present -exact x} msg] $msg +} {1 {wrong # args: should be "package present ?-exact? package ?requirement ...?"}} +test pkg-7.18 {Tcl_PackageCmd procedure, "present" option} { + list [catch {package present -exact} msg] $msg +} {1 {wrong # args: should be "package present ?-exact? package ?requirement ...?"}} + + + + +set n 0 +foreach {r p vs vc} { + 8.5a0 8.5a5 1 -1 + 8.5a0 8.5b1 1 -1 + 8.5a0 8.5.1 1 -1 + 8.5a0 8.6a0 1 -1 + 8.5a0 8.6b0 1 -1 + 8.5a0 8.6.0 1 -1 + 8.5a6 8.5a5 0 1 + 8.5a6 8.5b1 1 -1 + 8.5a6 8.5.1 1 -1 + 8.5a6 8.6a0 1 -1 + 8.5a6 8.6b0 1 -1 + 8.5a6 8.6.0 1 -1 + 8.5b0 8.5a5 0 1 + 8.5b0 8.5b1 1 -1 + 8.5b0 8.5.1 1 -1 + 8.5b0 8.6a0 1 -1 + 8.5b0 8.6b0 1 -1 + 8.5b0 8.6.0 1 -1 + 8.5b2 8.5a5 0 1 + 8.5b2 8.5b1 0 1 + 8.5b2 8.5.1 1 -1 + 8.5b2 8.6a0 1 -1 + 8.5b2 8.6b0 1 -1 + 8.5b2 8.6.0 1 -1 + 8.5 8.5a5 1 1 + 8.5 8.5b1 1 1 + 8.5 8.5.1 1 -1 + 8.5 8.6a0 1 -1 + 8.5 8.6b0 1 -1 + 8.5 8.6.0 1 -1 + 8.5.0 8.5a5 0 1 + 8.5.0 8.5b1 0 1 + 8.5.0 8.5.1 1 -1 + 8.5.0 8.6a0 1 -1 + 8.5.0 8.6b0 1 -1 + 8.5.0 8.6.0 1 -1 + 10 8 0 1 + 8 10 0 -1 + 0.0.1.2 0.1.2 1 -1 +} { + test package-vsatisfies-1.$n {package vsatisfies} { + package vsatisfies $p $r + } $vs + + test package-vcompare-1.$n {package vcompare} { + package vcompare $r $p + } $vc + + incr n +} + +test package-vcompare-2.0 {package vcompare at 32bit boundary} { + package vcompare [expr {1<<31}] [expr {(1<<31)-1}] +} 1 + +# Note: It is correct that the result of the very first test, +# i.e. "5.0 5.0a0" is 1, i.e. that version 5.0a0 satisfies a 5.0 +# requirement. + +# The requirement "5.0" internally translates first to "5.0-6", and +# then to its final form of "5.0a0-6a0". These translations are +# explicitly specified by the TIP (Search for "padded/extended +# internally with 'a0'"). This was done intentionally for exactly the +# tested case, that an alpha package can satisfy a requirement for the +# regular package. An example would be a package FOO requiring Tcl 8.X +# for its operation. It can be used with Tcl 8.Xa0. Without our +# translation that would not be possible. + +set n 0 +foreach {required provided satisfied} { + 5.0 5.0a0 1 + 5.0a0 5.0 1 + + 8.5a0- 8.5a5 1 + 8.5a0- 8.5b1 1 + 8.5a0- 8.5.1 1 + 8.5a0- 8.6a0 1 + 8.5a0- 8.6b0 1 + 8.5a0- 8.6.0 1 + 8.5a6- 8.5a5 0 + 8.5a6- 8.5b1 1 + 8.5a6- 8.5.1 1 + 8.5a6- 8.6a0 1 + 8.5a6- 8.6b0 1 + 8.5a6- 8.6.0 1 + 8.5b0- 8.5a5 0 + 8.5b0- 8.5b1 1 + 8.5b0- 8.5.1 1 + 8.5b0- 8.6a0 1 + 8.5b0- 8.6b0 1 + 8.5b0- 8.6.0 1 + 8.5b2- 8.5a5 0 + 8.5b2- 8.5b1 0 + 8.5b2- 8.5.1 1 + 8.5b2- 8.6a0 1 + 8.5b2- 8.6b0 1 + 8.5b2- 8.6.0 1 + 8.5- 8.5a5 1 + 8.5- 8.5b1 1 + 8.5- 8.5.1 1 + 8.5- 8.6a0 1 + 8.5- 8.6b0 1 + 8.5- 8.6.0 1 + 8.5.0- 8.5a5 0 + 8.5.0- 8.5b1 0 + 8.5.0- 8.5.1 1 + 8.5.0- 8.6a0 1 + 8.5.0- 8.6b0 1 + 8.5.0- 8.6.0 1 + 8.5a0-7 8.5a5 0 + 8.5a0-7 8.5b1 0 + 8.5a0-7 8.5.1 0 + 8.5a0-7 8.6a0 0 + 8.5a0-7 8.6b0 0 + 8.5a0-7 8.6.0 0 + 8.5a6-7 8.5a5 0 + 8.5a6-7 8.5b1 0 + 8.5a6-7 8.5.1 0 + 8.5a6-7 8.6a0 0 + 8.5a6-7 8.6b0 0 + 8.5a6-7 8.6.0 0 + 8.5b0-7 8.5a5 0 + 8.5b0-7 8.5b1 0 + 8.5b0-7 8.5.1 0 + 8.5b0-7 8.6a0 0 + 8.5b0-7 8.6b0 0 + 8.5b0-7 8.6.0 0 + 8.5b2-7 8.5a5 0 + 8.5b2-7 8.5b1 0 + 8.5b2-7 8.5.1 0 + 8.5b2-7 8.6a0 0 + 8.5b2-7 8.6b0 0 + 8.5b2-7 8.6.0 0 + 8.5-7 8.5a5 0 + 8.5-7 8.5b1 0 + 8.5-7 8.5.1 0 + 8.5-7 8.6a0 0 + 8.5-7 8.6b0 0 + 8.5-7 8.6.0 0 + 8.5.0-7 8.5a5 0 + 8.5.0-7 8.5b1 0 + 8.5.0-7 8.5.1 0 + 8.5.0-7 8.6a0 0 + 8.5.0-7 8.6b0 0 + 8.5.0-7 8.6.0 0 + 8.5a0-8.6.1 8.5a5 1 + 8.5a0-8.6.1 8.5b1 1 + 8.5a0-8.6.1 8.5.1 1 + 8.5a0-8.6.1 8.6a0 1 + 8.5a0-8.6.1 8.6b0 1 + 8.5a0-8.6.1 8.6.0 1 + 8.5a6-8.6.1 8.5a5 0 + 8.5a6-8.6.1 8.5b1 1 + 8.5a6-8.6.1 8.5.1 1 + 8.5a6-8.6.1 8.6a0 1 + 8.5a6-8.6.1 8.6b0 1 + 8.5a6-8.6.1 8.6.0 1 + 8.5b0-8.6.1 8.5a5 0 + 8.5b0-8.6.1 8.5b1 1 + 8.5b0-8.6.1 8.5.1 1 + 8.5b0-8.6.1 8.6a0 1 + 8.5b0-8.6.1 8.6b0 1 + 8.5b0-8.6.1 8.6.0 1 + 8.5b2-8.6.1 8.5a5 0 + 8.5b2-8.6.1 8.5b1 0 + 8.5b2-8.6.1 8.5.1 1 + 8.5b2-8.6.1 8.6a0 1 + 8.5b2-8.6.1 8.6b0 1 + 8.5b2-8.6.1 8.6.0 1 + 8.5-8.6.1 8.5a5 1 + 8.5-8.6.1 8.5b1 1 + 8.5-8.6.1 8.5.1 1 + 8.5-8.6.1 8.6a0 1 + 8.5-8.6.1 8.6b0 1 + 8.5-8.6.1 8.6.0 1 + 8.5.0-8.6.1 8.5a5 0 + 8.5.0-8.6.1 8.5b1 0 + 8.5.0-8.6.1 8.5.1 1 + 8.5.0-8.6.1 8.6a0 1 + 8.5.0-8.6.1 8.6b0 1 + 8.5.0-8.6.1 8.6.0 1 + 8.5a0-8.5a0 8.5a0 1 + 8.5a0-8.5a0 8.5b1 0 + 8.5a0-8.5a0 8.4 0 + 8.5b0-8.5b0 8.5a5 0 + 8.5b0-8.5b0 8.5b0 1 + 8.5b0-8.5b0 8.5.1 0 + 8.5-8.5 8.5a5 0 + 8.5-8.5 8.5b1 0 + 8.5-8.5 8.5 1 + 8.5-8.5 8.5.1 0 + 8.5.0-8.5.0 8.5a5 0 + 8.5.0-8.5.0 8.5b1 0 + 8.5.0-8.5.0 8.5.0 1 + 8.5.0-8.5.0 8.5.1 0 + 8.5.0-8.5.0 8.6a0 0 + 8.5.0-8.5.0 8.6b0 0 + 8.5.0-8.5.0 8.6.0 0 + 8.2 9 0 + 8.2- 9 1 + 8.2-8.5 9 0 + 8.2-9.1 9 1 + + 8.5-8.5 8.5b1 0 + 8.5a0-8.5 8.5b1 0 + 8.5a0-8.5.1 8.5b1 1 + + 8.5-8.5 8.5 1 + 8.5.0-8.5.0 8.5 1 + 8.5a0-8.5.0 8.5 0 + +} { + test package-vsatisfies-2.$n "package vsatisfies $provided $required" { + package vsatisfies $provided $required + } $satisfied + incr n +} + +test package-vsatisfies-3.0 "package vsatisfies multiple" { + # yes no + package vsatisfies 8.4 8.4 7.3 +} 1 + +test package-vsatisfies-3.1 "package vsatisfies multiple" { + # no yes + package vsatisfies 8.4 7.3 8.4 +} 1 + +test package-vsatisfies-3.2 "package vsatisfies multiple" { + # yes yes + package vsatisfies 8.4.2 8.4 8.4.1 +} 1 + +test package-vsatisfies-3.3 "package vsatisfies multiple" { + # no no + package vsatisfies 8.4 7.3 6.1 +} 0 + + +proc prefer {args} { + set ip [interp create] + lappend res [$ip eval {package prefer}] + foreach mode $args { + lappend res [$ip eval [list package prefer $mode]] + } + interp delete $ip + return $res +} + +test package-prefer-1.0 {default} { + prefer +} stable + +test package-prefer-1.1 {default} { + set ::env(TCL_PKG_PREFER_LATEST) stable ; # value not relevant! + set res [prefer] + unset ::env(TCL_PKG_PREFER_LATEST) + set res +} latest + +test package-prefer-2.0 {wrong\#args} { + catch {package prefer foo bar} msg + set msg +} {wrong # args: should be "package prefer ?latest|stable?"} + +test package-prefer-2.1 {bogus argument} { + catch {package prefer foo} msg + set msg +} {bad preference "foo": must be latest or stable} + +test package-prefer-3.0 {set, keep} { + package prefer stable +} stable + +test package-prefer-3.1 {set stable, keep} { + prefer stable +} {stable stable} + +test package-prefer-3.2 {set latest, change} { + prefer latest +} {stable latest} + +test package-prefer-3.3 {set latest, keep} { + prefer latest latest +} {stable latest latest} + +test package-prefer-3.4 {set stable, rejected} { + prefer latest stable +} {stable latest latest} + +rename prefer {} + + +set auto_path $oldPath +package unknown $oldPkgUnknown +concat + +cleanupTests +} + +# cleanup +interp delete $i +::tcltest::cleanupTests +return diff --git a/tests/resource.test b/tests/resource.test new file mode 100644 index 0000000..a650d48 --- /dev/null +++ b/tests/resource.test @@ -0,0 +1,369 @@ +# Commands covered: resource +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1996-1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: resource.test,v 1.9 2003/10/23 10:07:30 vincentdarley Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import -force ::tcltest::* +} + +test resource-1.1 {resource tests} {macOnly} { + list [catch {resource} msg] $msg +} {1 {wrong # args: should be "resource option ?arg ...?"}} +test resource-1.2 {resource tests} {macOnly} { + list [catch {resource _bad_} msg] $msg +} {1 {bad option "_bad_": must be close, delete, files, list, open, read, types, or write}} + +# resource open & close tests +test resource-2.1 {resource open & close tests} {macOnly} { + list [catch {resource open} msg] $msg +} {1 {wrong # args: should be "resource open fileName ?permissions?"}} +test resource-2.2 {resource open & close tests} {macOnly} { + list [catch {resource open resource.test r extraArg} msg] $msg +} {1 {wrong # args: should be "resource open fileName ?permissions?"}} +test resource-2.3 {resource open & close tests} {macOnly} { + list [catch {resource open resource.test bad_perms} msg] $msg +} {1 {illegal access mode "bad_perms"}} +test resource-2.4 {resource open & close tests} {macOnly} { + list [catch {resource open _bad_file_} msg] $msg +} {1 {file does not exist}} +test resource-2.5 {resource open & close tests} {macOnly} { + testWriteTextResource -rsrc fileRsrcName -file rsrc.file {error "don't source me"} + set id [resource open rsrc.file] + resource close $id + file delete rsrc.file +} {} +test resource-2.6 {resource open & close tests} {macOnly} { + catch {file delete rsrc.file} + testWriteTextResource -rsrc fileRsrcName -file rsrc.file {A test string} + set id [resource open rsrc.file] + set result [string compare [resource open rsrc.file] $id] + lappend result [resource read TEXT fileRsrcName $id] + resource close $id + file delete rsrc.file + set result +} {0 {A test string}} +test resource-2.7 {resource open & close tests} {macOnly} { + catch {file delete rsrc.file} + testWriteTextResource -rsrc fileRsrcName -file rsrc.file {error "don't source me"} + set id [resource open rsrc.file r] + set result [catch {resource open rsrc.file w} mssg] + resource close $id + file delete rsrc.file + lappend result $mssg + set result +} {1 {Resource already open with different permissions.}} +test resource-2.8 {resource open & close tests} {macOnly} { + list [catch {resource close} msg] $msg +} {1 {wrong # args: should be "resource close resourceRef"}} +test resource-2.9 {resource open & close tests} {macOnly} { + list [catch {resource close foo bar} msg] $msg +} {1 {wrong # args: should be "resource close resourceRef"}} +test resource-2.10 {resource open & close tests} {macOnly} { + list [catch {resource close _bad_resource_} msg] $msg +} {1 {invalid resource file reference "_bad_resource_"}} +test resource-2.11 {resource open & close tests} {macOnly} { + set result [catch {resource close System} mssg] + lappend result $mssg +} {1 {can't close "System" resource file}} +test resource-2.12 {resource open & close tests} {macOnly} { + set result [catch {resource close application} mssg] + lappend result $mssg +} {1 {can't close "application" resource file}} + +# Tests for listing resources +test resource-3.1 {resource list tests} {macOnly} { + list [catch {resource list} msg] $msg +} {1 {wrong # args: should be "resource list resourceType ?resourceRef?"}} +test resource-3.2 {resource list tests} {macOnly} { + list [catch {resource list _bad_type_} msg] $msg +} {1 {expected Macintosh OS type but got "_bad_type_"}} +test resource-3.3 {resource list tests} {macOnly} { + list [catch {resource list TEXT _bad_ref_} msg] $msg +} {1 {invalid resource file reference "_bad_ref_"}} +test resource-3.4 {resource list tests} {macOnly} { + list [catch {resource list TEXT _bad_ref_ extraArg} msg] $msg +} {1 {wrong # args: should be "resource list resourceType ?resourceRef?"}} +test resource-3.5 {resource list tests} {macOnly} { + catch {file delete rsrc.file} + testWriteTextResource -rsrc fileRsrcName -file rsrc.file {error "don't source me"} + set id [resource open rsrc.file] + catch "resource list TEXT $id" result + resource close $id + set result +} {fileRsrcName} +test resource-3.6 {resource list tests} {macOnly} { + # There should not be any resource of this type + resource list XXXX +} {} +test resource-3.7 {resource list tests} {macOnly} { + set resourceList [resource list STR#] + if {[lsearch $resourceList {Tcl Environment Variables}] == -1} { + set result {couldn't find resource that should exist} + } else { + set result ok + } +} {ok} + +# Tests for reading resources +test resource-4.1 {resource read tests} {macOnly} { + list [catch {resource read} msg] $msg +} {1 {wrong # args: should be "resource read resourceType resourceId ?resourceRef?"}} +test resource-4.2 {resource read tests} {macOnly} { + list [catch {resource read TEXT} msg] $msg +} {1 {wrong # args: should be "resource read resourceType resourceId ?resourceRef?"}} +test resource-4.3 {resource read tests} {macOnly} { + list [catch {resource read STR# {_non_existant_resource_}} msg] $msg +} {1 {could not load resource}} +test resource-4.4 {resource read tests} {macOnly} { + # The following resource should exist and load OK without error + catch {resource read STR# {Tcl Environment Variables}} +} {0} + +# Tests for getting resource types +test resource-5.1 {resource types tests} {macOnly} { + list [catch {resource types _bad_ref_} msg] $msg +} {1 {invalid resource file reference "_bad_ref_"}} +test resource-5.2 {resource types tests} {macOnly} { + list [catch {resource types _bad_ref_ extraArg} msg] $msg +} {1 {wrong # args: should be "resource types ?resourceRef?"}} +test resource-5.3 {resource types tests} {macOnly} { + # This should never cause an error + catch {resource types} +} {0} +test resource-5.4 {resource types tests} {macOnly} { + testWriteTextResource -rsrc fileRsrcName -file rsrc.file {error "don't source me"} + set id [resource open rsrc.file] + set result [resource types $id] + resource close $id + set result +} {TEXT} +test resource-5.5 {resource types lists} {macOnly} { + # This should not crash + catch {foreach f [resource types] { resource list $f }} +} {0} + +# resource write tests +test resource-6.1 {resource write tests} {macOnly} { + list [catch {resource write} msg] $msg +} {1 {wrong # args: should be "resource write ?-id resourceId? ?-name resourceName? ?-file resourceRef? ?-force? resourceType data"}} +test resource-6.2 {resource write tests} {macOnly} { + list [catch {resource write _bad_type_ data} msg] $msg +} {1 {expected Macintosh OS type but got "_bad_type_"}} +test resource-6.3 {resource write tests} {macOnly} { + catch {file delete rsrc2.file} + set id [resource open rsrc2.file w] + resource close $id + set id [resource open rsrc2.file r] + set result [catch {resource write -file $id -name Hello TEXT foo} errMsg] + lappend result [string compare $errMsg "cannot write to resource file \"$id\", it was opened read only"] + lappend result [lsearch [resource list TEXT $id] Hello] + resource close $id + file delete rsrc2.file + set result +} {1 0 -1} +test resource-6.4 {resource write tests} {macOnly} { + catch {file delete rsrc2.file} + set id [resource open rsrc2.file w] + resource write -file $id -name Hello TEXT {set x "our test data"} + source -rsrc Hello rsrc2.file + resource close $id + file delete rsrc2.file + set x +} {our test data} +test resource-6.5 {resource write tests} {macOnly} { + catch {file delete rsrc2.file} + set id [resource open rsrc2.file w] + resource write -file $id -id 256 TEXT {HAHAHAHAHAHAHA} + set result [catch {resource write -file $id -id 256 TEXT {HOHOHOHOHOHO}} mssg] + resource close $id + file delete rsrc2.file + lappend result $mssg +} {1 {the resource 256 already exists, use "-force" to overwrite it.}} +test resource-6.6 {resource write tests} {macOnly} { + catch {file delete rsrc2.file} + testWriteTextResource -rsrc fileRsrcName -rsrcid 256 -file rsrc2.file -protected {error "don't tread on me"} + set id [resource open rsrc2.file w] + set result [catch {resource write -id 256 -force -file $id TEXT {NAHNAHNANAHNAH}} mssg] + resource close $id + file delete rsrc2.file + lappend result $mssg +} {1 {could not write resource id 256 of type TEXT, it was protected.}} +test resource-6.7 {resource write tests} {macOnly} { + catch {file delete rsrc2.file} + set id [resource open rsrc2.file w] + resource write -file $id -id 256 -name FOO TEXT {set x [list "our first test data"]} + resource write -file $id -id 256 -name BAR -force TEXT {set x [list "our second test data"]} + source -rsrcid 256 rsrc2.file + lappend x [resource list TEXT $id] + resource close $id + file delete rsrc2.file + set x +} {{our second test data} BAR} + +#Tests for listing open resource files +test resource-7.1 {resource file tests} {macOnly} { + catch {resource files foo bar} mssg + set mssg +} {wrong # args: should be "resource files ?resourceId?"} +test resource-7.2 {resource file tests} {macOnly} { + catch {file delete rsrc2.file} + set rsrcFiles [resource files] + set id [resource open rsrc2.file w] + set result [string compare $rsrcFiles [lrange [resource files] 1 end]] + lappend result [string compare $id [lrange [resource files] 0 0]] + resource close $id + file delete rsrc2.file + set result +} {0 0} +test resource-7.3 {resource file tests} {macOnly} { + set result 0 + foreach file [resource files] { + if {[catch {resource types $file}] != 0} { + set result 1 + } + } + set result +} {0} +test resource-7.4 {resource file tests} {macOnly} { + catch {resource files __NO_SUCH_RESOURCE__} mssg + set mssg +} {invalid resource file reference "__NO_SUCH_RESOURCE__"} +test resource-7.5 {resource file tests} {macOnly} { + set sys [resource files System] + string compare $sys [file join $env(SYS_FOLDER) System] +} {0} +test resource-7.6 {resource file tests} {macOnly} { + set app [resource files application] + string compare $app [info nameofexecutable] +} {0} + +#Tests for the resource delete command +test resource-8.1 {resource delete tests} {macOnly} { + list [catch {resource delete} msg] $msg +} {1 {wrong # args: should be "resource delete ?-id resourceId? ?-name resourceName? ?-file resourceRef? resourceType"}} +test resource-8.2 {resource delete tests} {macOnly} { + list [catch {resource delete TEXT} msg] $msg +} {1 {you must specify either "-id" or "-name" or both to "resource delete"}} +test resource-8.3 {resource delete tests} {macOnly} { + set result [catch {resource delete -file ffffff -id 128 TEXT} mssg] + lappend result $mssg +} {1 {invalid resource file reference "ffffff"}} +test resource-8.4 {resource delete tests} {macOnly} { + catch {file delete rsrc2.file} + testWriteTextResource -rsrc fileRsrcName -rsrcid 128 -file rsrc2.file {Some stuff} + set id [resource open rsrc2.file r] + set result [catch {resource delete -id 128 -file $id TEXT} mssg] + resource close $id + file delete rsrc2.file + lappend result [string compare $mssg "cannot delete from resource file \"$id\", it was opened read only"] +} {1 0} +test resource-8.5 {resource delete tests} {macOnly} { + catch {file delete rsrc2.file} + testWriteTextResource -rsrc fileRsrcName -rsrcid 128 -file rsrc2.file {Some stuff} + set id [resource open rsrc2.file w] + set result [catch {resource delete -id 128 -file $id _bad_type_} mssg] + resource close $id + file delete rsrc2.file + lappend result $mssg +} {1 {expected Macintosh OS type but got "_bad_type_"}} +test resource-8.5.1 {resource delete tests} {macOnly} { + catch {file delete rsrc2.file} + set id [resource open rsrc2.file w] + set result [catch {resource delete -id 128 -file $id TEXT} mssg] + resource close $id + file delete rsrc2.file + lappend result $mssg +} {1 {resource not found}} +test resource-8.6 {resource delete tests} {macOnly} { + catch {file delete rsrc2.file} + set id [resource open rsrc2.file w] + set result [catch {resource delete -name foo -file $id TEXT} mssg] + resource close $id + file delete rsrc2.file + lappend result $mssg +} {1 {resource not found}} +test resource-8.7 {resource delete tests} {macOnly} { + catch {file delete rsrc2.file} + set id [resource open rsrc2.file w] + resource write -file $id -name foo -id 128 TEXT {some stuff} + resource write -file $id -name bar -id 129 TEXT {some stuff} + set result [catch {resource delete -name foo -id 129 -file $id TEXT} mssg] + resource close $id + file delete rsrc2.file + lappend result $mssg +} {1 {"-id" and "-name" values do not point to the same resource}} +test resource-8.8 {resource delete tests} {macOnly} { + catch {file delete rsrc2.file} + testWriteTextResource -rsrc fileRsrcName -rsrcid 256 -file rsrc2.file -protected {error "don't tread on me"} + set id [resource open rsrc2.file w] + set result [catch {resource delete -id 256 -file $id TEXT } mssg] + resource close $id + file delete rsrc2.file + lappend result $mssg +} {1 {resource cannot be deleted: it is protected.}} +test resource-8.9 {resource delete tests} {macOnly} { + catch {file delete rsrc2.file} + testWriteTextResource -rsrc fileRsrcName -rsrcid 128 -file rsrc2.file {Some stuff} + set id [resource open rsrc2.file w] + set result [resource list TEXT $id] + resource delete -id 128 -file $id TEXT + lappend result [resource list TEXT $id] + resource close $id + file delete rsrc2.file + set result +} {fileRsrcName {}} + +# Tests for the Mac version of the source command +catch {file delete rsrc.file} +test resource-9.1 {source command} {macOnly} { + testWriteTextResource -rsrc fileRsrcName -rsrcid 128 \ + -file rsrc.file {set rsrc_foo 1} + catch {unset rsrc_foo} + source -rsrc fileRsrcName rsrc.file + list [catch {set rsrc_foo} msg] $msg +} {0 1} +test resource-9.2 {source command} {macOnly} { + catch {unset rsrc_foo} + list [catch {source -rsrc no_resource rsrc.file} msg] $msg +} {1 {The resource "no_resource" could not be loaded from rsrc.file.}} +test resource-9.3 {source command} {macOnly} { + catch {unset rsrc_foo} + source -rsrcid 128 rsrc.file + list [catch {set rsrc_foo} msg] $msg +} {0 1} +test resource-9.4 {source command} {macOnly} { + catch {unset rsrc_foo} + list [catch {source -rsrcid bad_int rsrc.file} msg] $msg +} {1 {expected integer but got "bad_int"}} +test resource-9.5 {source command} {macOnly} { + catch {unset rsrc_foo} + list [catch {source -rsrcid 100 rsrc.file} msg] $msg +} {1 {The resource "ID=100" could not be loaded from rsrc.file.}} + +# cleanup +catch {file delete rsrc.file} +::tcltest::cleanupTests +return + + + + + + + + + + + + diff --git a/tests/unsupported.test b/tests/unsupported.test new file mode 100644 index 0000000..0c706b8 --- /dev/null +++ b/tests/unsupported.test @@ -0,0 +1,914 @@ +# Commands covered: tailcall, atProcExit, coroutine, yield +# +# This file contains a collection of tests for experimental commands that are +# found in ::tcl::unsupported. The tests will migrate to normal test files +# if/when the commands find their way into the core. +# +# Copyright (c) 2008 by Miguel Sofer. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: unsupported.test,v 1.15 2008/10/14 18:49:47 dgp Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import -force ::tcltest::* +} + +testConstraint testnrelevels [llength [info commands testnrelevels]] +testConstraint atProcExit [llength [info commands ::tcl::unsupported::atProcExit]] + +if {[namespace exists tcl::unsupported]} { + namespace eval tcl::unsupported namespace export * + namespace import tcl::unsupported::* +} + +# +# The tests that risked blowing the C stack on failure have been removed: we +# can now actually measure using testnrelevels. +# + +if {[testConstraint testnrelevels]} { + namespace eval testnre { + # + # [testnrelevels] returns a 6-list with: C-stack depth, iPtr->numlevels, + # cmdFrame level, callFrame level, tosPtr and callback depth + # + variable last [testnrelevels] + proc depthDiff {} { + variable last + set depth [testnrelevels] + set res {} + foreach t $depth l $last { + lappend res [expr {$t-$l}] + } + set last $depth + return $res + } + proc setabs {} { + uplevel 1 variable abs -[lindex [testnrelevels] 0] + } + + variable body0 { + set x [depthDiff] + if {[incr i] > 10} { + variable abs + incr abs [lindex [testnrelevels] 0] + return [list [lrange $x 0 3] $abs] + } + } + proc makebody txt { + variable body0 + return "$body0; $txt" + } + namespace export * + } + namespace import testnre::* +} + +# +# Test atProcExit +# + +test unsupported-A.1 {atProcExit works} -constraints {atProcExit} -setup { + variable x x y y + proc a {} { + variable x 0 y 0 + atProcExit set ::x 1 + set x 2 + set y $x + set x 3 + } + proc b {} a +} -body { + list [b] $x $y +} -cleanup { + unset x y + rename a {} + rename b {} +} -result {3 1 2} + +test unsupported-A.2 {atProcExit} -constraints {atProcExit} -setup { + variable x x y x + proc a {} { + variable x 0 y 0 + atProcExit set ::x 1 + set x 2 + set y $x + set x 3 + } +} -body { + list [a] $x $y +} -cleanup { + unset x y + rename a {} +} -result {3 1 2} + +test unsupported-A.3 {atProcExit} -constraints {atProcExit} -setup { + variable x x y y + proc a {} { + variable x 0 y 0 + atProcExit lappend ::x 1 + lappend x 2 + atProcExit lappend ::x 3 + lappend y $x + lappend x 4 + return 5 + } +} -body { + list [a] $x $y +} -cleanup { + unset x y + rename a {} +} -result {5 {0 2 4 3 1} {0 {0 2}}} + +test unsupported-A.4 {atProcExit errors} -constraints {atProcExit} -setup { + variable x x y y + proc a {} { + variable x 0 y 0 + atProcExit lappend ::x 1 + lappend x 2 + atProcExit lappend ::x 3 + lappend y $x + lappend x 4 + error foo + } +} -body { + list [a] $x $y +} -cleanup { + unset x y + rename a {} +} -returnCodes error -result foo + +test unsupported-A.5 {atProcExit errors} -constraints {atProcExit} -setup { + variable x x y y + proc a {} { + variable x 0 y 0 + atProcExit error foo + lappend x 2 + atProcExit lappend ::x 3 + lappend y $x + lappend x 4 + return 5 + } +} -body { + list [a] $x $y +} -cleanup { + unset x y + rename a {} +} -result {5 {0 2 4 3} {0 {0 2}}} + +test unsupported-A.6 {atProcExit errors} -constraints {atProcExit} -setup { + variable x x y y + proc a {} { + variable x 0 y 0 + atProcExit lappend ::x 1 + lappend x 2 + atProcExit error foo + lappend y $x + lappend x 4 + return 5 + } +} -body { + list [a] $x $y +} -cleanup { + unset x y + rename a {} +} -result {5 {0 2 4} {0 {0 2}}} + +test unsupported-A.7 {atProcExit non-proc} -constraints {atProcExit} -body { + atProcExit set x 2 + set x 1 +} -cleanup { + unset -nocomplain x +} -match glob -result *atProcExit* -returnCodes error + +test unsupported-A.8 {atProcExit and eval} -constraints {knownBug atProcExit} -setup { + proc a {} { + eval atProcExit lappend ::x 2 + set ::x 1 + } +} -body { + list [a] $::x +} -cleanup { + unset -nocomplain ::x +} -result {1 2} + +test unsupported-A9 {atProcExit and uplevel} -constraints {knownBug atProcExit} -setup { + proc a {} { + uplevel 1 [list atProcExit set ::x 2] + set ::x 1 + } +} -body { + list [a] $::x +} -cleanup { + unset -nocomplain ::x +} -result {1 2} + + +# +# Test tailcalls +# + +test unsupported-T.0 {tailcall is constant space} -constraints testnrelevels -setup { + proc a i { + if {[incr i] > 10} { + return [depthDiff] + } + depthDiff + tailcall a $i + } +} -body { + a 0 +} -cleanup { + rename a {} +} -result {0 0 0 0 0 0} + +test unsupported-T.1 {tailcall} -body { + namespace eval a { + variable x *::a + proc xset {} { + set tmp {} + set ns {[namespace current]} + set level [info level] + for {set i 0} {$i <= [info level]} {incr i} { + uplevel #$i "set x $i$ns" + lappend tmp "$i [info level $i]" + } + lrange $tmp 1 end + } + proc foo {} {tailcall xset; set x noreach} + } + namespace eval b { + variable x *::b + proc xset args {error b::xset} + proc moo {} {set x 0; variable y [::a::foo]; set x} + } + variable x *:: + proc xset args {error ::xset} + list [::b::moo] | $x $a::x $b::x | $::b::y +} -cleanup { + unset x + rename xset {} + namespace delete a b +} -result {1::b | 0:: *::a *::b | {{1 ::b::moo} {2 xset}}} + + +test unsupported-T.2 {tailcall in non-proc} -body { + namespace eval a [list tailcall set x 1] +} -match glob -result *tailcall* -returnCodes error + +test unsupported-T.3 {tailcall falls off tebc} -body { + unset -nocomplain x + proc foo {} {tailcall set x 1} + list [catch foo msg] $msg [set x] +} -cleanup { + rename foo {} + unset x +} -result {0 1 1} + +test unsupported-T.4 {tailcall falls off tebc} -body { + set x 2 + proc foo {} {tailcall set x 1} + foo + set x +} -cleanup { + rename foo {} + unset x +} -result 1 + +test unsupported-T.5 {tailcall falls off tebc} -body { + set x 2 + namespace eval bar { + variable x 3 + proc foo {} {tailcall set x 1} + } + bar::foo + list $x $bar::x +} -cleanup { + unset x + namespace delete bar +} -result {1 3} + +test unsupported-T.6 {tailcall does remove callframes} -body { + proc foo {} {info level} + proc moo {} {tailcall foo} + proc boo {} {expr {[moo] - [info level]}} + boo +} -cleanup { + rename foo {} + rename moo {} + rename boo {} +} -result 1 + +test unsupported-T.7 {tailcall does return} -setup { + namespace eval ::foo { + variable res {} + proc a {} { + variable res + append res a + tailcall set x 1 + append res a + } + proc b {} { + variable res + append res b + a + append res b + } + proc c {} { + variable res + append res c + b + append res c + } + } +} -body { + namespace eval ::foo c +} -cleanup { + namespace delete ::foo +} -result cbabc + +test unsupported-T.8 {tailcall tailcall} -setup { + namespace eval ::foo { + variable res {} + proc a {} { + variable res + append res a + tailcall tailcall set x 1 + append res a + } + proc b {} { + variable res + append res b + a + append res b + } + proc c {} { + variable res + append res c + b + append res c + } + } +} -body { + namespace eval ::foo c +} -cleanup { + namespace delete ::foo +} -match glob -result *tailcall* -returnCodes error + +test unsupported-T.9 {tailcall factorial} -setup { + proc fact {n {b 1}} { + if {$n == 1} { + return $b + } + tailcall fact [expr {$n-1}] [expr {$n*$b}] + } +} -body { + list [fact 1] [fact 5] [fact 10] [fact 15] +} -cleanup { + rename fact {} +} -result {1 120 3628800 1307674368000} + +test unsupported-T.10 {tailcall and eval} -constraints {knownBug atProcExit} -setup { + proc a {} { + eval [list tailcall lappend ::x 2] + set ::x 1 + } +} -body { + list [a] $::x +} -cleanup { + unset -nocomplain ::x +} -result {1 2} + +test unsupported-T.11 {tailcall and uplevel} -constraints {knownBug atProcExit} -setup { + proc a {} { + uplevel 1 [list tailcall set ::x 2] + set ::x 1 + } +} -body { + list [a] $::x +} -cleanup { + unset -nocomplain ::x +} -result {1 2} + +# +# Test both together +# + +test unsupported-AT.1 {atProcExit and tailcall} -constraints { + atProcExit +} -setup { + variable x x y y + proc a {} { + variable x 0 y 0 + atProcExit lappend ::x 1 + lappend x 2 + atProcExit lappend ::x 3 + tailcall lappend ::x 6 + lappend y $x + lappend x 4 + return 5 + } +} -body { + list [a] $x $y +} -cleanup { + unset x y + rename a {} +} -result {{0 2 3 1 6} {0 2 3 1 6} 0} + +# +# Test coroutines +# + +set lambda [list {{start 0} {stop 10}} { + # init + set i $start + set imax $stop + yield + + while {$i < $imax} { + yield [expr {$i*$stop}] + incr i + } +}] + + +test unsupported-C.1.1 {coroutine basic} -setup { + coroutine foo ::apply $lambda + set res {} +} -body { + for {set k 1} {$k < 4} {incr k} { + lappend res [foo] + } + set res +} -cleanup { + rename foo {} + unset res +} -result {0 10 20} + +test unsupported-C.1.2 {coroutine basic} -setup { + coroutine foo ::apply $lambda 2 8 + set res {} +} -body { + for {set k 1} {$k < 4} {incr k} { + lappend res [foo] + } + set res +} -cleanup { + rename foo {} + unset res +} -result {16 24 32} + +test unsupported-C.1.3 {yield returns new arg} -setup { + set body { + # init + set i $start + set imax $stop + yield + + while {$i < $imax} { + set stop [yield [expr {$i*$stop}]] + incr i + } + } + coroutine foo ::apply [list {{start 2} {stop 10}} $body] + set res {} +} -body { + for {set k 1} {$k < 4} {incr k} { + lappend res [foo $k] + } + set res +} -cleanup { + rename foo {} + unset res +} -result {20 6 12} + +test unsupported-C.1.4 {yield in nested proc} -setup { + proc moo {} { + upvar 1 i i stop stop + yield [expr {$i*$stop}] + } + set body { + # init + set i $start + set imax $stop + yield + + while {$i < $imax} { + moo + incr i + } + } + coroutine foo ::apply [list {{start 0} {stop 10}} $body] + set res {} +} -body { + for {set k 1} {$k < 4} {incr k} { + lappend res [foo $k] + } + set res +} -cleanup { + rename foo {} + rename moo {} + unset body res +} -result {0 10 20} + +test unsupported-C.1.5 {just yield} -body { + coroutine foo yield + list [foo] [catch foo msg] $msg +} -cleanup { + unset msg +} -result {{} 1 {invalid command name "foo"}} + +test unsupported-C.1.6 {just yield} -body { + coroutine foo [list yield] + list [foo] [catch foo msg] $msg +} -cleanup { + unset msg +} -result {{} 1 {invalid command name "foo"}} + +test unsupported-C.1.7 {yield in nested uplevel} -setup { + set body { + # init + set i $start + set imax $stop + yield + + while {$i < $imax} { + uplevel 0 [list yield [expr {$i*$stop}]] + incr i + } + } + coroutine foo ::apply [list {{start 0} {stop 10}} $body] + set res {} +} -body { + for {set k 1} {$k < 4} {incr k} { + lappend res [eval foo $k] + } + set res +} -cleanup { + rename foo {} + unset body res +} -result {0 10 20} + +test unsupported-C.1.8 {yield in nested uplevel} -setup { + set body { + # init + set i $start + set imax $stop + yield + + while {$i < $imax} { + uplevel 0 yield [expr {$i*$stop}] + incr i + } + } + coroutine foo ::apply [list {{start 0} {stop 10}} $body] + set res {} +} -body { + for {set k 1} {$k < 4} {incr k} { + lappend res [eval foo $k] + } + set res +} -cleanup { + rename foo {} + unset body res +} -result {0 10 20} + +test unsupported-C.1.9 {yield in nested eval} -setup { + proc moo {} { + upvar 1 i i stop stop + yield [expr {$i*$stop}] + } + set body { + # init + set i $start + set imax $stop + yield + + while {$i < $imax} { + eval moo + incr i + } + } + coroutine foo ::apply [list {{start 0} {stop 10}} $body] + set res {} +} -body { + for {set k 1} {$k < 4} {incr k} { + lappend res [foo $k] + } + set res +} -cleanup { + rename moo {} + unset body res +} -result {0 10 20} + +test unsupported-C.1.10 {yield in nested eval} -setup { + set body { + # init + set i $start + set imax $stop + yield + + while {$i < $imax} { + eval yield [expr {$i*$stop}] + incr i + } + } + coroutine foo ::apply [list {{start 0} {stop 10}} $body] + set res {} +} -body { + for {set k 1} {$k < 4} {incr k} { + lappend res [eval foo $k] + } + set res +} -cleanup { + unset body res +} -result {0 10 20} + +test unsupported-C.1.11 {yield outside coroutine} -setup { + proc moo {} { + upvar 1 i i stop stop + yield [expr {$i*$stop}] + } +} -body { + variable i 5 stop 6 + moo +} -cleanup { + rename moo {} + unset i stop +} -returnCodes error -result {yield can only be called in a coroutine} + +test unsupported-C.1.12 {proc as coroutine} -setup { + set body { + # init + set i $start + set imax $stop + yield + + while {$i < $imax} { + uplevel 0 [list yield [expr {$i*$stop}]] + incr i + } + } + proc moo {{start 0} {stop 10}} $body + coroutine foo moo 2 8 +} -body { + list [foo] [foo] +} -cleanup { + unset body + rename moo {} + rename foo {} +} -result {16 24} + +test unsupported-C.2.1 {self deletion on return} -body { + coroutine foo set x 3 + foo +} -returnCodes error -result {invalid command name "foo"} + +test unsupported-C.2.2 {self deletion on return} -body { + coroutine foo ::apply [list {} {yield; yield 1; return 2}] + list [foo] [foo] [catch foo msg] $msg +} -result {1 2 1 {invalid command name "foo"}} + +test unsupported-C.2.3 {self deletion on error return} -body { + coroutine foo ::apply [list {} {yield;yield 1; error ouch!}] + list [foo] [catch foo msg] $msg [catch foo msg] $msg +} -result {1 1 ouch! 1 {invalid command name "foo"}} + +test unsupported-C.2.4 {self deletion on other return} -body { + coroutine foo ::apply [list {} {yield;yield 1; return -code 100 ouch!}] + list [foo] [catch foo msg] $msg [catch foo msg] $msg +} -result {1 100 ouch! 1 {invalid command name "foo"}} + +test unsupported-C.2.5 {deletion of suspended coroutine} -body { + coroutine foo ::apply [list {} {yield; yield 1; return 2}] + list [foo] [rename foo {}] [catch foo msg] $msg +} -result {1 {} 1 {invalid command name "foo"}} + +test unsupported-C.2.6 {deletion of running coroutine} -body { + coroutine foo ::apply [list {} {yield; rename foo {}; yield 1; return 2}] + list [foo] [catch foo msg] $msg +} -result {1 1 {invalid command name "foo"}} + +test unsupported-C.3.1 {info level computation} -setup { + proc a {} {while 1 {yield [info level]}} + proc b {} foo +} -body { + # note that coroutines execute in uplevel #0 + set l0 [coroutine foo a] + set l1 [foo] + set l2 [b] + list $l0 $l1 $l2 +} -cleanup { + rename a {} + rename b {} +} -result {1 1 1} + +test unsupported-C.3.2 {info frame computation} -setup { + proc a {} {while 1 {yield [info frame]}} + proc b {} foo +} -body { + set l0 [coroutine foo a] + set l1 [foo] + set l2 [b] + expr {$l2 - $l1} +} -cleanup { + rename a {} + rename b {} +} -result 1 + +test unsupported-C.3.3 {info coroutine} -setup { + proc a {} {info coroutine} + proc b {} a +} -body { + b +} -cleanup { + rename a {} + rename b {} +} -result {} + +test unsupported-C.3.4 {info coroutine} -setup { + proc a {} {info coroutine} + proc b {} a +} -body { + coroutine foo b +} -cleanup { + rename a {} + rename b {} +} -result ::foo + +test unsupported-C.3.5 {info coroutine} -setup { + proc a {} {info coroutine} + proc b {} {rename [info coroutine] {}; a} +} -body { + coroutine foo b +} -cleanup { + rename a {} + rename b {} +} -result {} + + +test unsupported-C.4.1 {bug #2093188} -setup { + proc foo {} { + set v 1 + trace add variable v {write unset} bar + yield + set v 2 + yield + set v 3 + } + proc bar args {lappend ::res $args} + coroutine a foo +} -body { + list [a] [a] $::res +} -cleanup { + rename foo {} + rename bar {} + unset ::res +} -result {{} 3 {{v {} write} {v {} write} {v {} unset}}} + +test unsupported-C.4.2 {bug #2093188} -setup { + proc foo {} { + set v 1 + trace add variable v {read unset} bar + yield + set v 2 + set v + yield + set v 3 + } + proc bar args {lappend ::res $args} + coroutine a foo +} -body { + list [a] [a] $::res +} -cleanup { + rename foo {} + rename bar {} + unset ::res +} -result {{} 3 {{v {} read} {v {} unset}}} + +test unsupported-C.4.3 {bug #2093947} -setup { + proc foo {} { + set v 1 + trace add variable v {write unset} bar + yield + set v 2 + yield + set v 3 + } + proc bar args {lappend ::res $args} +} -body { + coroutine a foo + a + a + coroutine a foo + a + rename a {} + set ::res +} -cleanup { + rename foo {} + rename bar {} + unset ::res +} -result {{v {} write} {v {} write} {v {} unset} {v {} write} {v {} unset}} + +test unsupported-C.5.1 {right numLevels on coro return} -constraints {testnrelevels} \ +-setup { + proc nestedYield {{val {}}} { + yield $val + } + proc getNumLevel {} { + # remove the level for this proc's call + expr {[lindex [testnrelevels] 1] - 1} + } + proc relativeLevel base { + # remove the level for this proc's call + expr {[getNumLevel] - $base - 1} + } + proc foo {} { + while 1 { + nestedYield + } + } + set res {} +} -body { + set base [getNumLevel] + lappend res [relativeLevel $base] + eval {coroutine a foo} + + # back to base level + lappend res [relativeLevel $base] + a + lappend res [relativeLevel $base] + eval a + lappend res [relativeLevel $base] + eval {eval a} + lappend res [relativeLevel $base] + rename a {} + lappend res [relativeLevel $base] + set res +} -cleanup { + rename foo {} + rename nestedYield {} + rename getNumLevel {} + rename relativeLevel {} + unset res +} -result {0 0 0 0 0 0} + +test unsupported-C.5.2 {right numLevels within coro} -constraints {testnrelevels} \ +-setup { + proc nestedYield {{val {}}} { + yield $val + } + proc getNumLevel {} { + # remove the level for this proc's call + expr {[lindex [testnrelevels] 1] - 1} + } + proc relativeLevel base { + # remove the level for this proc's call + expr {[getNumLevel] - $base - 1} + } + proc foo base { + while 1 { + set base [nestedYield [relativeLevel $base]] + } + } + set res {} +} -body { + lappend res [eval {coroutine a foo [getNumLevel]}] + lappend res [a [getNumLevel]] + lappend res [eval {a [getNumLevel]}] + lappend res [eval {eval {a [getNumLevel]}}] + set base [lindex $res 0] + foreach x $res[set res {}] { + lappend res [expr {$x-$base}] + } + set res +} -cleanup { + rename a {} + rename foo {} + rename nestedYield {} + rename getNumLevel {} + rename relativeLevel {} + unset res +} -result {0 0 0 0} + + + +# cleanup +::tcltest::cleanupTests + + +unset -nocomplain lambda + +if {[testConstraint atProcExit]} { + namespace forget tcl::unsupported::atProcExit +} + +if {[testConstraint testnrelevels]} { + namespace forget testnre::* + namespace delete testnre +} + +return |