diff options
Diffstat (limited to 'tcllib/modules/snit/snit.test')
| -rw-r--r-- | tcllib/modules/snit/snit.test | 9144 |
1 files changed, 9144 insertions, 0 deletions
diff --git a/tcllib/modules/snit/snit.test b/tcllib/modules/snit/snit.test new file mode 100644 index 0000000..1d5b0b2 --- /dev/null +++ b/tcllib/modules/snit/snit.test @@ -0,0 +1,9144 @@ +# -*- tcl -*- +#--------------------------------------------------------------------- +# TITLE: +# snit.test +# +# AUTHOR: +# Will Duquette +# +# DESCRIPTION: +# Test cases for snit.tcl. Uses the ::tcltest:: harness. +# +# If Tcl is 8.5, Snit 2.0 is loaded. +# If Tcl is 8.4, Snit 1.2 is loaded. +# If Tcl is 8.3, Snit 1.2 is loaded. (Kenneth Green's backport). +# +# Tests back-ported to Tcl 8.3 for snit 1.2 backport by kmg +# Backport of test made general by Andreas Kupries. +# +# The tests assume tcltest 2.2 + +#----------------------------------------------------------------------- +# Back-port to Tcl8.3 by Kenneth Green (kmg) +# +# Global changes: +# " eq " => "string equal" +# " ne " -> "!string equal" +#----------------------------------------------------------------------- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.3 +testsNeedTcltest 2.2 + +#--------------------------------------------------------------------- +# Set up a number of constraints. This also determines which +# implementation of snit is loaded and tested. + +# WHD: Work around bugs in 8.5a3 +tcltest::testConstraint bug8.5a3 [expr {![string equal [info patchlevel] "8.5a3"]}] + +# Marks tests which are only for Tk. +tcltest::testConstraint tk [info exists tk_version] + +# If Tk is available, require BWidget +tcltest::testConstraint bwidget [expr { + [tcltest::testConstraint tk] && + ![catch {package require BWidget}] +}] + +# Determine which Snit version to load. If Tcl 8.5, use 2.x. +# Otherwise, use 1.x. (Different variants depending on 8.3 vs 8.4) +if {[package vsatisfies [package present Tcl] 8.5]} { + set snitVersion 2 + set snitFile snit2.tcl +} else { + set snitVersion 1 + set snitFile snit.tcl +} + +# Marks tests which are only for Snit 1 +tcltest::testConstraint snit1 [expr {$snitVersion == 1}] + +# Marks tests which are only for Snit 2 +tcltest::testConstraint snit2 [expr {$snitVersion == 2}] + +# Marks tests which are only for Snit 1 with Tcl 8.3 +tcltest::testConstraint tcl83 [string equal [info tclversion] "8.3"] +tcltest::testConstraint tcl84 [package vsatisfies [package present Tcl] 8.4] + +if {[package vsatisfies [package provide Tcl] 8.6]} { + # 8.6+ + proc expect {six default} { return $six } +} else { + # 8.4/8.5 + proc expect {six default} { return $default } +} + +#--------------------------------------------------------------------- +# Load the snit package. + +testing { + useLocal $snitFile snit +} + +#--------------------------------------------------------------------- + +namespace import ::snit::* + +# Set up for Tk tests: Repeat background errors +proc bgerror {msg} { + global errorInfo + set ::bideError $msg + set ::bideErrorInfo $errorInfo +} + +# Set up for Tk tests: enter the event loop long enough to catch +# any bgerrors. +proc tkbide {{msg "tkbide"} {msec 500}} { + set ::bideVar 0 + set ::bideError "" + set ::bideErrorInfo "" + # It looks like update idletasks does the job. + if {0} { + after $msec {set ::bideVar 1} + tkwait variable ::bideVar + } + update idletasks + if {"" != $::bideError} { + error "$msg: $::bideError" $::bideErrorInfo + } +} + +# cleanup type +proc cleanupType {name} { + if {[namespace exists $name]} { + if {[catch {$name destroy} result]} { + global errorInfo + puts $errorInfo + error "Could not cleanup $name!" + } + } + tkbide "cleanupType $name" +} + +# cleanup before each test +proc cleanup {} { + global errorInfo + + cleanupType ::dog + cleanupType ::cat + cleanupType ::mylabel + cleanupType ::myframe + cleanupType ::foo + cleanupType ::bar + cleanupType ::tail + cleanupType ::papers + cleanupType ::animal + cleanupType ::confused-dog + catch {option clear} + + if {![string equal [info commands "spot"] ""]} { + puts "spot not erased!" + error "spot not erased!" + } + + if {![string equal [info commands "fido"] ""]} { + puts "fido not erased!" + error "fido not erased!" + } +} + +# catch error code and error + +proc codecatch {command} { + if {![catch {uplevel 1 $command} result]} { + error "expected error, got OK" + } + + return "$::errorCode $result" +} + + +#----------------------------------------------------------------------- +# Internals: tests for Snit utility functions + +test Expand-1.1 {template, no arguments} -body { + snit::Expand "My %TEMPLATE%" +} -result {My %TEMPLATE%} + +test Expand-1.2 {template, no matching arguments} -body { + snit::Expand "My %TEMPLATE%" %FOO% foo +} -result {My %TEMPLATE%} + +test Expand-1.3 {template with matching arguments} -body { + snit::Expand "%FOO% %BAR% %FOO%" %FOO% bar %BAR% foo +} -result {bar foo bar} + +test Expand-1.4 {template with odd number of arguments} -body { + snit::Expand "%FOO% %BAR% %FOO%" %FOO% +} -result {char map list unbalanced} -returnCodes error + +test Mappend-1.1 {template, no arguments} -body { + set text "Prefix: " + snit::Mappend text "My %TEMPLATE%" +} -cleanup { + unset text +} -result {Prefix: My %TEMPLATE%} + +test Mappend-1.2 {template, no matching arguments} -body { + set text "Prefix: " + snit::Mappend text "My %TEMPLATE%" %FOO% foo +} -cleanup { + unset text +} -result {Prefix: My %TEMPLATE%} + +test Mappend-1.3 {template with matching arguments} -body { + set text "Prefix: " + snit::Mappend text "%FOO% %BAR% %FOO%" %FOO% bar %BAR% foo +} -cleanup { + unset text +} -result {Prefix: bar foo bar} + +test Mappend-1.4 {template with odd number of arguments} -body { + set text "Prefix: " + snit::Mappend text "%FOO% %BAR% %FOO%" %FOO% +} -cleanup { + unset text +} -returnCodes error -result {char map list unbalanced} + +test RT.UniqueName-1.1 {no name collision} -body { + set counter 0 + + # Standard qualified type name. + set n1 [snit::RT.UniqueName counter ::mytype ::my::%AUTO%] + + # Standard qualified widget name. + set n2 [snit::RT.UniqueName counter ::mytype .my.%AUTO%] + + list $n1 $n2 +} -result {::my::mytype1 .my.mytype2} -cleanup { + unset counter n1 n2 +} + +test RT.UniqueName-1.2 {name collision} -body { + set counter 0 + + # Create the first two equivalent procs. + proc ::mytype1 {} {} + proc ::mytype2 {} {} + + # Create a new name; it should skip to 3. + snit::RT.UniqueName counter ::mytype ::%AUTO% +} -cleanup { + unset counter + rename ::mytype1 "" + rename ::mytype2 "" +} -result {::mytype3} + +test RT.UniqueName-1.3 {nested type name} -body { + set counter 0 + + snit::RT.UniqueName counter ::thisis::yourtype ::your::%AUTO% +} -cleanup { + unset counter +} -result {::your::yourtype1} + +test RT.UniqueInstanceNamespace-1.1 {no name collision} -setup { + namespace eval ::mytype:: {} +} -body { + set counter 0 + snit::RT.UniqueInstanceNamespace counter ::mytype +} -cleanup { + unset counter + namespace delete ::mytype:: +} -result {::mytype::Snit_inst1} + +test RT.UniqueInstanceNamespace-1.2 {name collision} -setup { + namespace eval ::mytype:: {} + namespace eval ::mytype::Snit_inst1:: {} + namespace eval ::mytype::Snit_inst2:: {} +} -body { + set counter 0 + + # Should skip to 3. + snit::RT.UniqueInstanceNamespace counter ::mytype +} -cleanup { + unset counter + namespace delete ::mytype:: +} -result {::mytype::Snit_inst3} + +test Contains-1.1 {contains element} -constraints { + snit1 +} -setup { + set mylist {foo bar baz} +} -body { + snit::Contains baz $mylist +} -cleanup { + unset mylist +} -result {1} + +test Contains-1.2 {does not contain element} -constraints { + snit1 +} -setup { + set mylist {foo bar baz} +} -body { + snit::Contains quux $mylist +} -cleanup { + unset mylist +} -result {0} + +#----------------------------------------------------------------------- +# type compilation + +# snit::compile returns two values, the qualified type name +# and the script to execute to define the type. This section +# only checks the length of the list and the type name; +# the content of the script is validated by the remainder +# of this test suite. + +test compile-1.1 {compile returns qualified type} -body { + set compResult [compile type dog { }] + + list [llength $compResult] [lindex $compResult 0] +} -result {2 ::dog} + +#----------------------------------------------------------------------- +# type destruction + +test typedestruction-1.1 {type command is deleted} -body { + type dog { } + dog destroy + info command ::dog +} -result {} + +test typedestruction-1.2 {instance commands are deleted} -body { + type dog { } + + dog create spot + dog destroy + info command ::spot +} -result {} + +test typedestruction-1.3 {type namespace is deleted} -body { + type dog { } + dog destroy + namespace exists ::dog +} -result {0} + +test typedestruction-1.4 {type proc is destroyed on error} -body { + catch {type dog { + error "Error creating dog" + }} result + + list [namespace exists ::dog] [info commands ::dog] +} -result {0 {}} + +test typedestruction-1.5 {unrelated namespaces are deleted, bug 2898640} -body { + type dog {} + namespace eval dog::unrelated {} + dog destroy +} -result {} + +#----------------------------------------------------------------------- +# type and typemethods + +test type-1.1 {type names get qualified} -body { + type dog {} +} -cleanup { + dog destroy +} -result {::dog} + +test type-1.2 {typemethods can be defined} -body { + type dog { + typemethod foo {a b} { + return [list $a $b] + } + } + + dog foo 1 2 +} -cleanup { + dog destroy +} -result {1 2} + +test type-1.3 {upvar works in typemethods} -body { + type dog { + typemethod goodname {varname} { + upvar $varname myvar + set myvar spot + } + } + + set thename fido + dog goodname thename + set thename +} -cleanup { + dog destroy + unset thename +} -result {spot} + +test type-1.4 {typemethod args can't include type} -body { + type dog { + typemethod foo {a type b} { } + } +} -returnCodes error -result {typemethod foo's arglist may not contain "type" explicitly} + +test type-1.5 {typemethod args can't include self} -body { + type dog { + typemethod foo {a self b} { } + } +} -returnCodes error -result {typemethod foo's arglist may not contain "self" explicitly} + +test type-1.6 {typemethod args can span multiple lines} -body { + # This case caused an error at definition time in 0.9 because the + # arguments were included in a comment in the compile script, and + # the subsequent lines weren't commented. + type dog { + typemethod foo { + a + b + } { } + } +} -cleanup { + dog destroy +} -result {::dog} + + +#----------------------------------------------------------------------- +# typeconstructor + +test typeconstructor-1.1 {a typeconstructor can be defined} -body { + type dog { + typevariable a + + typeconstructor { + set a 1 + } + + typemethod aget {} { + return $a + } + } + + dog aget +} -cleanup { + dog destroy +} -result {1} + +test typeconstructor-1.2 {only one typeconstructor can be defined} -body { + type dog { + typevariable a + + typeconstructor { + set a 1 + } + + typeconstructor { + set a 2 + } + } +} -returnCodes error -result {too many typeconstructors} + +test typeconstructor-1.3 {type proc is destroyed on error} -body { + catch { + type dog { + typeconstructor { + error "Error creating dog" + } + } + } result + + list [namespace exists ::dog] [info commands ::dog] +} -result {0 {}} + +#----------------------------------------------------------------------- +# Type components + +test typecomponent-1.1 {typecomponent defines typevariable} -body { + type dog { + typecomponent mycomp + + typemethod test {} { + return $mycomp + } + } + + dog test +} -cleanup { + dog destroy +} -result {} + +test typecomponent-1.2 {typecomponent trace executes} -body { + type dog { + typecomponent mycomp + + typemethod test {} { + typevariable Snit_typecomponents + set mycomp foo + return $Snit_typecomponents(mycomp) + } + } + + dog test +} -cleanup { + dog destroy +} -result {foo} + +test typecomponent-1.3 {typecomponent -public works} -body { + type dog { + typecomponent mycomp -public string + + typeconstructor { + set mycomp string + } + } + + dog string length foo +} -cleanup { + dog destroy +} -result {3} + +test typecomponent-1.4 {typecomponent -inherit yes} -body { + type dog { + typecomponent mycomp -inherit yes + + typeconstructor { + set mycomp string + } + } + + dog length foo +} -cleanup { + dog destroy +} -result {3} + + +#----------------------------------------------------------------------- +# hierarchical type methods + +test htypemethod-1.1 {hierarchical method, two tokens} -body { + type dog { + typemethod {wag tail} {} { + return "wags tail" + } + } + + dog wag tail +} -cleanup { + dog destroy +} -result {wags tail} + +test htypemethod-1.2 {hierarchical method, three tokens} -body { + type dog { + typemethod {wag tail proudly} {} { + return "wags tail proudly" + } + } + + dog wag tail proudly +} -cleanup { + dog destroy +} -result {wags tail proudly} + +test htypemethod-1.3 {hierarchical method, four tokens} -body { + type dog { + typemethod {wag tail really high} {} { + return "wags tail really high" + } + } + + dog wag tail really high +} -cleanup { + dog destroy +} -result {wags tail really high} + +test htypemethod-1.4 {redefinition is OK} -body { + type dog { + typemethod {wag tail} {} { + return "wags tail" + } + typemethod {wag tail} {} { + return "wags tail briskly" + } + } + + dog wag tail +} -cleanup { + dog destroy +} -result {wags tail briskly} + +# Case 1 +test htypemethod-1.5 {proper error on missing submethod} -constraints { + snit1 +} -body { + cleanup + + type dog { + typemethod {wag tail} {} { } + } + + dog wag +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {wrong number args: should be "::dog wag method args"} + +# Case 2 +test htypemethod-1.6 {proper error on missing submethod} -constraints { + snit2 +} -body { + cleanup + + type dog { + typemethod {wag tail} {} { } + } + + dog wag +} -returnCodes { + error +} -cleanup { + dog destroy +} -result [expect \ + {wrong # args: should be "dog wag subcommand ?arg ...?"} \ + {wrong # args: should be "dog wag subcommand ?argument ...?"}] + +# Case 1 +test htypemethod-1.7 {proper error on bogus submethod} -constraints { + snit1 +} -body { + cleanup + + type dog { + typemethod {wag tail} {} { } + } + + dog wag ears +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {"::dog wag ears" is not defined} + +# Case 2 +test htypemethod-1.8 {proper error on bogus submethod} -constraints { + snit2 +} -body { + cleanup + + type dog { + typemethod {wag tail} {} { } + } + + dog wag ears +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {unknown subcommand "ears": namespace ::dog does not export any commands} + +test htypemethod-2.1 {prefix/method collision, level 1, order 1} -body { + type dog { + typemethod wag {} {} + typemethod {wag tail} {} {} + } +} -returnCodes { + error +} -result {Error in "typemethod {wag tail}...", "wag" has no submethods.} + +test htypemethod-2.2 {prefix/method collision, level 1, order 2} -body { + type dog { + typemethod {wag tail} {} {} + typemethod wag {} {} + } +} -returnCodes { + error +} -result {Error in "typemethod wag...", "wag" has submethods.} + +test htypemethod-2.3 {prefix/method collision, level 2, order 1} -body { + type dog { + typemethod {wag tail} {} {} + typemethod {wag tail proudly} {} {} + } +} -returnCodes { + error +} -result {Error in "typemethod {wag tail proudly}...", "wag tail" has no submethods.} + +test htypemethod-2.4 {prefix/method collision, level 2, order 2} -body { + type dog { + typemethod {wag tail proudly} {} {} + typemethod {wag tail} {} {} + } +} -returnCodes { + error +} -result {Error in "typemethod {wag tail}...", "wag tail" has submethods.} + +#----------------------------------------------------------------------- +# Typemethod delegation + +test dtypemethod-1.1 {delegate typemethod to non-existent component} -body { + set result "" + + type dog { + delegate typemethod foo to bar + } + + dog foo +} -returnCodes { + error +} -result {::dog delegates typemethod "foo" to undefined typecomponent "bar"} + +test dtypemethod-1.2 {delegating to existing typecomponent} -body { + type dog { + delegate typemethod length to string + + typeconstructor { + set string string + } + } + + dog length foo +} -cleanup { + dog destroy +} -result {3} + +# Case 1 +test dtypemethod-1.3 {delegating to existing typecomponent with error} -constraints { + snit1 +} -body { + type dog { + delegate typemethod length to string + + typeconstructor { + set string string + } + } + + dog length foo bar +} -returnCodes { + error +} -result {wrong # args: should be "string length string"} + +# Case 2 +test dtypemethod-1.4 {delegating to existing typecomponent with error} -constraints { + snit2 +} -body { + type dog { + delegate typemethod length to string + + typeconstructor { + set string string + } + } + + dog length foo bar +} -returnCodes { + error +} -result {wrong # args: should be "dog length string"} + +test dtypemethod-1.5 {delegating unknown typemethods to existing typecomponent} -body { + type dog { + delegate typemethod * to string + + typeconstructor { + set string string + } + } + + dog length foo +} -cleanup { + dog destroy +} -result {3} + +# Case 1 +test dtypemethod-1.6 {delegating unknown typemethod to existing typecomponent with error} -body { + type dog { + delegate typemethod * to stringhandler + + typeconstructor { + set stringhandler string + } + } + + dog foo bar +} -constraints { + snit1 +} -returnCodes { + error +} -result {bad option "foo": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, tolower, toupper, totitle, trim, trimleft, trimright, wordend, or wordstart} + +test dtypemethod-1.6a.0 {delegating unknown typemethod to existing typecomponent with error} -body { + type dog { + delegate typemethod * to stringhandler + + typeconstructor { + set stringhandler string + } + } + + dog foo bar +} -constraints { + snit2 tcl8.5minus +} -returnCodes { + error +} -result {unknown or ambiguous subcommand "foo": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart} + +test dtypemethod-1.6a.1 {delegating unknown typemethod to existing typecomponent with error} -body { + type dog { + delegate typemethod * to stringhandler + + typeconstructor { + set stringhandler string + } + } + + dog foo bar +} -constraints { + snit2 tcl8.6plus +} -returnCodes { + error +} -result {unknown or ambiguous subcommand "foo": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart} + +test dtypemethod-1.7 {can't delegate local typemethod: order 1} -body { + type dog { + typemethod foo {} {} + delegate typemethod foo to bar + } +} -returnCodes { + error +} -result {Error in "delegate typemethod foo...", "foo" has been defined locally.} + +test dtypemethod-1.8 {can't delegate local typemethod: order 2} -body { + type dog { + delegate typemethod foo to bar + typemethod foo {} {} + } +} -returnCodes { + error +} -result {Error in "typemethod foo...", "foo" has been delegated} + +# Case 1 +test dtypemethod-1.9 {excepted methods are caught properly} -constraints { + snit1 +} -body { + type dog { + delegate typemethod * to string except {match index} + + typeconstructor { + set string string + } + } + + catch {dog length foo} a + catch {dog match foo} b + catch {dog index foo} c + + list $a $b $c +} -cleanup { + dog destroy +} -result {3 {"::dog match" is not defined} {"::dog index" is not defined}} + +# Case 2 +test dtypemethod-1.10 {excepted methods are caught properly} -constraints { + snit2 +} -body { + type dog { + delegate typemethod * to string except {match index} + + typeconstructor { + set string string + } + } + + catch {dog length foo} a + catch {dog match foo} b + catch {dog index foo} c + + list $a $b $c +} -cleanup { + dog destroy +} -result {3 {unknown subcommand "match": must be length} {unknown subcommand "index": must be length}} + +test dtypemethod-1.11 {as clause can include arguments} -body { + proc tail {a b} { + return "<$a $b>" + } + + type dog { + delegate typemethod wag to tail as {wag briskly} + + typeconstructor { + set tail tail + } + } + + dog wag +} -cleanup { + dog destroy + rename tail "" +} -result {<wag briskly>} + +test dtypemethod-2.1 {'using "%c %m"' gets normal behavior} -body { + type dog { + delegate typemethod length to string using {%c %m} + + typeconstructor { + set string string + } + } + + dog length foo +} -cleanup { + dog destroy +} -result {3} + +test dtypemethod-2.2 {All relevant 'using' conversions are converted} -body { + proc echo {args} { + return $args + } + + type dog { + delegate typemethod {tail wag} using {echo %% %t %M %m %j %n %w %s %c} + } + + dog tail wag +} -cleanup { + dog destroy + rename echo "" +} -result {% ::dog {tail wag} wag tail_wag %n %w %s %c} + +test dtypemethod-2.3 {"%%" is handled properly} -body { + proc echo {args} { join $args "|" } + + type dog { + delegate typemethod wag using {echo %%m %%%m} + } + + dog wag +} -cleanup { + dog destroy + rename echo "" +} -result {%m|%wag} + +test dtypemethod-2.4 {Method "*" and "using"} -body { + proc echo {args} { join $args "|" } + + type dog { + delegate typemethod * using {echo %m} + } + + list [dog wag] [dog bark loudly] +} -cleanup { + dog destroy + rename echo "" +} -result {wag bark|loudly} + +test dtypemethod-3.1 {typecomponent names can be changed dynamically} -body { + proc echo {args} { join $args "|" } + + type dog { + delegate typemethod length to mycomp + + typeconstructor { + set mycomp string + } + + typemethod switchit {} { + set mycomp echo + } + } + + set a [dog length foo] + dog switchit + set b [dog length foo] + + list $a $b +} -cleanup { + dog destroy + rename echo "" +} -result {3 length|foo} + +test dtypemethod-4.1 {hierarchical typemethod, two tokens} -body { + type tail { + method wag {} {return "wags tail"} + } + + type dog { + typeconstructor { + set tail [tail %AUTO%] + } + delegate typemethod {wag tail} to tail as wag + } + + dog wag tail +} -cleanup { + dog destroy + tail destroy +} -result {wags tail} + +test dtypemethod-4.2 {hierarchical typemethod, three tokens} -body { + type tail { + method wag {} {return "wags tail"} + } + + type dog { + typeconstructor { + set tail [tail %AUTO%] + } + delegate typemethod {wag tail proudly} to tail as wag + } + + dog wag tail proudly +} -cleanup { + dog destroy + tail destroy +} -result {wags tail} + +test dtypemethod-4.3 {hierarchical typemethod, four tokens} -body { + type tail { + method wag {} {return "wags tail"} + } + + type dog { + typeconstructor { + set tail [tail %AUTO%] + } + delegate typemethod {wag tail really high} to tail as wag + } + + dog wag tail really high +} -cleanup { + dog destroy + tail destroy +} -result {wags tail} + +test dtypemethod-4.4 {redefinition is OK} -body { + type tail { + method {wag tail} {} {return "wags tail"} + method {wag briskly} {} {return "wags tail briskly"} + } + + type dog { + typeconstructor { + set tail [tail %AUTO%] + } + delegate typemethod {wag tail} to tail as {wag tail} + delegate typemethod {wag tail} to tail as {wag briskly} + } + + dog wag tail +} -cleanup { + dog destroy + tail destroy +} -result {wags tail briskly} + +test dtypemethod-4.5 {last token is used by default} -body { + type tail { + method wag {} {return "wags tail"} + } + + type dog { + typeconstructor { + set tail [tail %AUTO%] + } + delegate typemethod {tail wag} to tail + } + + dog tail wag +} -cleanup { + dog destroy + tail destroy +} -result {wags tail} + +test dtypemethod-4.6 {last token can be *} -body { + type tail { + method wag {} {return "wags"} + method droop {} {return "droops"} + } + + type dog { + typeconstructor { + set tail [tail %AUTO%] + } + delegate typemethod {tail *} to tail + } + + list [dog tail wag] [dog tail droop] +} -cleanup { + dog destroy + tail destroy +} -result {wags droops} + +# Case 2 +test dtypemethod-4.7 {except with multiple tokens} -constraints { + snit1 +} -body { + type tail { + method wag {} {return "wags"} + method droop {} {return "droops"} + } + + type dog { + typeconstructor { + set tail [tail %AUTO%] + } + delegate typemethod {tail *} to tail except droop + } + + catch {dog tail droop} result + + list [dog tail wag] $result +} -cleanup { + dog destroy + tail destroy +} -result {wags {"::dog tail droop" is not defined}} + +# Case 2 +test dtypemethod-4.8 {except with multiple tokens} -constraints { + snit2 +} -body { + type tail { + method wag {} {return "wags"} + method droop {} {return "droops"} + } + + type dog { + typeconstructor { + set tail [tail %AUTO%] + } + delegate typemethod {tail *} to tail except droop + } + + catch {dog tail droop} result + + list [dog tail wag] $result +} -cleanup { + dog destroy + tail destroy +} -result {wags {unknown subcommand "droop": namespace ::dog does not export any commands}} + +test dtypemethod-4.9 {"*" in the wrong spot} -body { + type dog { + delegate typemethod {tail * wag} to tail + } +} -returnCodes { + error +} -result {Error in "delegate typemethod {tail * wag}...", "*" must be the last token.} + +test dtypemethod-5.1 {prefix/typemethod collision} -body { + type dog { + delegate typemethod wag to tail + delegate typemethod {wag tail} to tail as wag + } +} -returnCodes { + error +} -result {Error in "delegate typemethod {wag tail}...", "wag" has no submethods.} + +test dtypemethod-5.2 {prefix/typemethod collision} -body { + type dog { + delegate typemethod {wag tail} to tail as wag + delegate typemethod wag to tail + } +} -returnCodes { + error +} -result {Error in "delegate typemethod wag...", "wag" has submethods.} + +test dtypemethod-5.3 {prefix/typemethod collision} -body { + type dog { + delegate typemethod {wag tail} to tail + delegate typemethod {wag tail proudly} to tail as wag + } +} -returnCodes { + error +} -result {Error in "delegate typemethod {wag tail proudly}...", "wag tail" has no submethods.} + +test dtypemethod-5.4 {prefix/typemethod collision} -body { + type dog { + delegate typemethod {wag tail proudly} to tail as wag + delegate typemethod {wag tail} to tail + } +} -returnCodes { + error +} -result {Error in "delegate typemethod {wag tail}...", "wag tail" has submethods.} + +#----------------------------------------------------------------------- +# type creation + +test creation-1.1 {type instance names get qualified} -body { + type dog { } + + dog create spot +} -cleanup { + dog destroy +} -result {::spot} + +test creation-1.2 {type instance names can be generated} -body { + type dog { } + + dog create my%AUTO% +} -cleanup { + dog destroy +} -result {::mydog1} + +test creation-1.3 {"create" method is optional} -body { + type dog { } + + dog fido +} -cleanup { + dog destroy +} -result {::fido} + +test creation-1.4 {constructor arg can't be type} -body { + type dog { + constructor {type} { } + } +} -returnCodes { + error +} -result {constructor's arglist may not contain "type" explicitly} + +test creation-1.5 {constructor arg can't be self} -body { + type dog { + constructor {self} { } + } +} -returnCodes { + error +} -result {constructor's arglist may not contain "self" explicitly} + +test creation-1.6 {weird names are OK} -body { + # I.e., names with non-identifier characters + type confused-dog { + method meow {} { + return "$self meows." + } + } + + confused-dog spot + spot meow +} -cleanup { + confused-dog destroy +} -result {::spot meows.} + +# Case 1 +test creation-1.7 {If -hasinstances yes, [$type] == [$type create %AUTO%]} -constraints { + snit1 +} -body { + type dog { + variable dummy + } + + set mydog [dog] +} -cleanup { + $mydog destroy + dog destroy +} -result {::dog1} + +# Case 2 +test creation-1.8 {If -hasinstances yes, [$type] == [$type create %AUTO%]} -constraints { + snit2 +} -body { + type dog { + # WHD: In Snit 1.0, this pragma was not needed. + pragma -hastypemethods no + variable dummy + } + + set mydog [dog] +} -cleanup { + # [dog destroy] doesn't exist + $mydog destroy + namespace delete ::dog +} -result {::dog1} + +# Case 1 +test creation-1.9 {If -hasinstances no, [$type] != [$type create %AUTO%]} -constraints { + snit1 +} -body { + type dog { + pragma -hasinstances no + } + + set mydog [dog] +} -cleanup { + dog destroy +} -returnCodes { + error +} -result {wrong # args: should be "::dog method args"} + +# Case 2 +test creation-1.10 {If -hasinstances no, [$type] != [$type create %AUTO%]} -constraints { + snit2 +} -body { + type dog { + pragma -hasinstances no + } + + set mydog [dog] +} -cleanup { + dog destroy +} -returnCodes { + error +} -result [expect \ + {wrong # args: should be "dog subcommand ?arg ...?"} \ + {wrong # args: should be "dog subcommand ?argument ...?"}] + +# Case 1 +test creation-1.11 {If widget, [$type] != [$type create %AUTO%]} -constraints { + snit1 tk +} -body { + widget dog { + variable dummy + } + + set mydog [dog] +} -cleanup { + dog destroy +} -returnCodes { + error +} -result {wrong # args: should be "::dog method args"} + +# Case 2 +test creation-1.12 {If widget, [$type] != [$type create %AUTO%]} -constraints { + snit2 tk +} -body { + widget dog { + variable dummy + } + + set mydog [dog] +} -cleanup { + dog destroy +} -returnCodes { + error +} -result [expect \ + {wrong # args: should be "dog subcommand ?arg ...?"} \ + {wrong # args: should be "dog subcommand ?argument ...?"}] + +test creation-1.13 {If -hastypemethods yes, [$type] == [$type create %AUTO%]} -constraints { + snit1 +} -body { + type dog { + variable dummy + } + + set mydog [dog] +} -cleanup { + dog destroy +} -result {::dog1} + +test creation-1.14 {If -hastypemethods yes, [$type] != [$type create %AUTO%]} -constraints { + snit2 +} -body { + type dog { + variable dummy + } + + set mydog [dog] +} -cleanup { + dog destroy +} -returnCodes { + error +} -result [expect \ + {wrong # args: should be "dog subcommand ?arg ...?"} \ + {wrong # args: should be "dog subcommand ?argument ...?"}] + +test creation-2.1 {Can't call "destroy" in constructor} -body { + type dog { + constructor {} { + $self destroy + } + } + + dog spot +} -cleanup { + dog destroy +} -returnCodes { + error +} -result {Error in constructor: Called 'destroy' method in constructor} + +#----------------------------------------------------------------------- +# procs + +test proc-1.1 {proc args can span multiple lines} -body { + # This case caused an error at definition time in 0.9 because the + # arguments were included in a comment in the compile script, and + # the subsequent lines weren't commented. + type dog { + proc foo { + a + b + } { } + } +} -cleanup { + dog destroy +} -result {::dog} + + +#----------------------------------------------------------------------- +# methods + +test method-1.1 {methods get called} -body { + type dog { + method bark {} { + return "$self barks" + } + } + + dog create spot + spot bark +} -cleanup { + dog destroy +} -result {::spot barks} + +test method-1.2 {methods can call other methods} -body { + type dog { + method bark {} { + return "$self barks." + } + + method chase {quarry} { + return "$self chases $quarry; [$self bark]" + } + } + + dog create spot + spot chase cat +} -cleanup { + dog destroy +} -result {::spot chases cat; ::spot barks.} + +test method-1.3 {instances can call one another} -body { + type dog { + method bark {} { + return "$self barks." + } + + method chase {quarry} { + return "$self chases $quarry; [$quarry bark] [$self bark]" + } + } + + dog create spot + dog create fido + spot chase ::fido +} -cleanup { + dog destroy +} -result {::spot chases ::fido; ::fido barks. ::spot barks.} + +test method-1.4 {upvar works in methods} -body { + type dog { + method goodname {varname} { + upvar $varname myvar + set myvar spot + } + } + + dog create fido + set thename fido + fido goodname thename + set thename +} -cleanup { + dog destroy +} -result {spot} + +# Case 1 +test method-1.5 {unknown methods get an error} -constraints { + snit1 +} -body { + type dog { } + + dog create spot + set result "" + spot chase +} -cleanup { + dog destroy +} -returnCodes { + error +} -result {"::spot chase" is not defined} + +# Case 2 +test method-1.6 {unknown methods get an error} -constraints { + snit2 +} -body { + type dog { } + + dog create spot + set result "" + spot chase +} -cleanup { + dog destroy +} -returnCodes { + error +} -result {unknown subcommand "chase": namespace ::dog::Snit_inst1 does not export any commands} + +test method-1.7 {info type method returns the object's type} -body { + type dog { } + + dog create spot + spot info type +} -cleanup { + dog destroy +} -result {::dog} + +test method-1.8 {instance method can call type method} -body { + type dog { + typemethod hello {} { + return "Hello" + } + method helloworld {} { + return "[$type hello], World!" + } + } + + dog create spot + spot helloworld +} -cleanup { + dog destroy +} -result {Hello, World!} + +test method-1.9 {type methods must be qualified} -body { + type dog { + typemethod hello {} { + return "Hello" + } + method helloworld {} { + return "[hello], World!" + } + } + + dog create spot + spot helloworld +} -cleanup { + dog destroy +} -returnCodes { + error +} -result {invalid command name "hello"} + +# Case 1 +test method-1.10 {too few arguments} -constraints { + snit1 +} -body { + type dog { + method bark {volume} { } + } + + dog create spot + spot bark +} -cleanup { + dog destroy +} -returnCodes { + error +} -result [tcltest::wrongNumArgs ::dog::Snit_methodbark {type selfns win self volume} 4] + +# Case 2 +test method-1.11 {too few arguments} -constraints { + snit2 +} -body { + type dog { + method bark {volume} { } + } + + dog create spot + spot bark +} -cleanup { + dog destroy +} -returnCodes { + error +} -result {wrong # args: should be "spot bark volume"} + +# Case 1 +test method-1.12 {too many arguments} -constraints { + snit1 +} -body { + type dog { + method bark {volume} { } + } + + dog create spot + + spot bark really loud +} -returnCodes { + error +} -result [tcltest::tooManyArgs ::dog::Snit_methodbark {type selfns win self volume}] + +# Case 2 +test method-1.13 {too many arguments} -constraints { + snit2 +} -body { + type dog { + method bark {volume} { } + } + + dog create spot + + spot bark really loud +} -cleanup { + dog destroy +} -returnCodes { + error +} -result {wrong # args: should be "spot bark volume"} + +test method-1.14 {method args can't include type} -body { + type dog { + method foo {a type b} { } + } +} -returnCodes { + error +} -result {method foo's arglist may not contain "type" explicitly} + +test method-1.15 {method args can't include self} -body { + type dog { + method foo {a self b} { } + } +} -returnCodes { + error +} -result {method foo's arglist may not contain "self" explicitly} + +test method-1.16 {method args can span multiple lines} -body { + # This case caused an error at definition time in 0.9 because the + # arguments were included in a comment in the compile script, and + # the subsequent lines weren't commented. + type dog { + method foo { + a + b + } { } + } +} -cleanup { + dog destroy +} -result {::dog} + +#----------------------------------------------------------------------- +# hierarchical methods + +test hmethod-1.1 {hierarchical method, two tokens} -body { + type dog { + method {wag tail} {} { + return "$self wags tail." + } + } + + dog spot + spot wag tail +} -cleanup { + dog destroy +} -result {::spot wags tail.} + +test hmethod-1.2 {hierarchical method, three tokens} -body { + type dog { + method {wag tail proudly} {} { + return "$self wags tail proudly." + } + } + + dog spot + spot wag tail proudly +} -cleanup { + dog destroy +} -result {::spot wags tail proudly.} + +test hmethod-1.3 {hierarchical method, three tokens} -body { + type dog { + method {wag tail really high} {} { + return "$self wags tail really high." + } + } + + dog spot + spot wag tail really high +} -cleanup { + dog destroy +} -result {::spot wags tail really high.} + +test hmethod-1.4 {redefinition is OK} -body { + type dog { + method {wag tail} {} { + return "$self wags tail." + } + method {wag tail} {} { + return "$self wags tail briskly." + } + } + + dog spot + spot wag tail +} -cleanup { + dog destroy +} -result {::spot wags tail briskly.} + +# Case 1 +test hmethod-1.5 {proper error on missing submethod} -constraints { + snit1 +} -body { + type dog { + method {wag tail} {} { } + } + + dog spot + spot wag +} -cleanup { + dog destroy +} -returnCodes { + error +} -result {wrong number args: should be "::spot wag method args"} + +# Case 2 +test hmethod-1.6 {proper error on missing submethod} -constraints { + snit2 +} -body { + type dog { + method {wag tail} {} { } + } + + dog spot + spot wag +} -cleanup { + dog destroy +} -returnCodes { + error +} -result [expect \ + {wrong # args: should be "spot wag subcommand ?arg ...?"} \ + {wrong # args: should be "spot wag subcommand ?argument ...?"}] + +test hmethod-1.7 {submethods called in proper objects} -body { + # NOTE: This test was added in response to a bug report by + # Anton Kovalenko. In Snit 2.0, submethod ensembles were + # created in the type namespace. If a type defines a submethod + # ensemble, then all objects of that type would end up sharing + # a single ensemble. Ensembles are created lazily, so in this + # test, the first call to "fido this tail wag" and "spot this tail wag" + # will yield the correct result, but the second call to + # "fido this tail wag" will yield the same as the call to + # "spot this tail wag", because spot's submethod ensemble has + # displaced fido's. Until the bug is fixed, that is. + # + # Fortunately, Anton provided the fix as well. + type tail { + option -manner + + method wag {} { + return "wags tail $options(-manner)" + } + } + + type dog { + delegate option -manner to tail + delegate method {this tail wag} to tail + + constructor {args} { + set tail [tail %AUTO%] + $self configurelist $args + } + } + + dog fido -manner briskly + dog spot -manner slowly + + list [fido this tail wag] [spot this tail wag] [fido this tail wag] +} -cleanup { + dog destroy + tail destroy +} -result {{wags tail briskly} {wags tail slowly} {wags tail briskly}} + +test hmethod-2.1 {prefix/method collision} -body { + type dog { + method wag {} {} + method {wag tail} {} { + return "$self wags tail." + } + } +} -returnCodes { + error +} -result {Error in "method {wag tail}...", "wag" has no submethods.} + +test hmethod-2.2 {prefix/method collision} -body { + type dog { + method {wag tail} {} { + return "$self wags tail." + } + method wag {} {} + } +} -returnCodes { + error +} -result {Error in "method wag...", "wag" has submethods.} + +test hmethod-2.3 {prefix/method collision} -body { + type dog { + method {wag tail} {} {} + method {wag tail proudly} {} { + return "$self wags tail." + } + } +} -returnCodes { + error +} -result {Error in "method {wag tail proudly}...", "wag tail" has no submethods.} + +test hmethod-2.4 {prefix/method collision} -body { + type dog { + method {wag tail proudly} {} { + return "$self wags tail." + } + method {wag tail} {} {} + } +} -returnCodes { + error +} -result {Error in "method {wag tail}...", "wag tail" has submethods.} + +#----------------------------------------------------------------------- +# mymethod and renaming + +test rename-1.1 {mymethod uses name of instance name variable} -body { + type dog { + method mymethod {} { + list [mymethod] [mymethod "A B"] [mymethod A B] + } + } + + dog fido + fido mymethod +} -cleanup { + dog destroy +} -result {{::snit::RT.CallInstance ::dog::Snit_inst1} {::snit::RT.CallInstance ::dog::Snit_inst1 {A B}} {::snit::RT.CallInstance ::dog::Snit_inst1 A B}} + +test rename-1.2 {instances can be renamed} -body { + type dog { + method names {} { + list [mymethod] $selfns $win $self + } + } + + dog fido + set a [fido names] + rename fido spot + set b [spot names] + + concat $a $b +} -cleanup { + dog destroy +} -result {{::snit::RT.CallInstance ::dog::Snit_inst1} ::dog::Snit_inst1 ::fido ::fido {::snit::RT.CallInstance ::dog::Snit_inst1} ::dog::Snit_inst1 ::fido ::spot} + +test rename-1.3 {rename to "" deletes an instance} -constraints { + bug8.5a3 +} -body { + type dog { } + + dog fido + rename fido "" + namespace children ::dog +} -cleanup { + dog destroy +} -result {} + +test rename-1.4 {rename to "" deletes an instance even after a rename} -constraints { + bug8.5a3 +} -body { + type dog { } + + dog fido + rename fido spot + rename spot "" + namespace children ::dog +} -cleanup { + dog destroy +} -result {} + +test rename-1.5 {creating an object twice destroys the first instance} -constraints { + bug8.5a3 +} -body { + type dog { + # Can't even test this normally. + pragma -canreplace yes + } + + dog fido + set a [namespace children ::dog] + dog fido + set b [namespace children ::dog] + fido destroy + set c [namespace children ::dog] + + list $a $b $c +} -cleanup { + dog destroy +} -result {::dog::Snit_inst1 ::dog::Snit_inst2 {}} + +#----------------------------------------------------------------------- +# mymethod actually works + +test mymethod-1.1 {run mymethod handler} -body { + type foo { + option -command {} + method runcmd {} { + eval [linsert $options(-command) end $self snarf] + return + } + } + type bar { + variable sub + constructor {args} { + set sub [foo fubar -command [mymethod Handler]] + return + } + + method Handler {args} { + set ::RES $args + } + + method test {} { + $sub runcmd + return + } + } + + set ::RES {} + bar boogle + boogle test + set ::RES +} -cleanup { + bar destroy + foo destroy +} -result {::bar::fubar snarf} + +#----------------------------------------------------------------------- +# myproc + +test myproc-1.1 {myproc qualifies proc names} -body { + type dog { + proc foo {} {} + + typemethod getit {} { + return [myproc foo] + } + } + + dog getit +} -cleanup { + dog destroy +} -result {::dog::foo} + +test myproc-1.2 {myproc adds arguments} -body { + type dog { + proc foo {} {} + + typemethod getit {} { + return [myproc foo "a b"] + } + } + + dog getit +} -cleanup { + dog destroy +} -result {::dog::foo {a b}} + +test myproc-1.3 {myproc adds arguments} -body { + type dog { + proc foo {} {} + + typemethod getit {} { + return [myproc foo "a b" c d] + } + } + + dog getit +} -cleanup { + dog destroy +} -result {::dog::foo {a b} c d} + +test myproc-1.4 {procs with selfns work} -body { + type dog { + variable datum foo + + method qualify {} { + return [myproc getdatum $selfns] + } + proc getdatum {selfns} { + return $datum + } + } + dog create spot + eval [spot qualify] +} -cleanup { + dog destroy +} -result {foo} + + +#----------------------------------------------------------------------- +# mytypemethod + +test mytypemethod-1.1 {mytypemethod qualifies typemethods} -body { + type dog { + typemethod this {} {} + + typemethod a {} { + return [mytypemethod this] + } + typemethod b {} { + return [mytypemethod this x] + } + typemethod c {} { + return [mytypemethod this "x y"] + } + typemethod d {} { + return [mytypemethod this x y] + } + } + + list [dog a] [dog b] [dog c] [dog d] +} -cleanup { + dog destroy +} -result {{::dog this} {::dog this x} {::dog this {x y}} {::dog this x y}} + +#----------------------------------------------------------------------- +# typevariable + +test typevariable-1.1 {typevarname qualifies typevariables} -body { + # Note: typevarname is DEPRECATED. Real code should use + # mytypevar instead. + type dog { + method tvname {name} { + typevarname $name + } + } + + dog create spot + spot tvname myvar +} -cleanup { + dog destroy +} -result {::dog::myvar} + +test typevariable-1.2 {undefined typevariables are OK} -body { + type dog { + method tset {value} { + typevariable theValue + + set theValue $value + } + + method tget {} { + typevariable theValue + + return $theValue + } + } + + dog create spot + dog create fido + spot tset Howdy + + list [spot tget] [fido tget] [set ::dog::theValue] +} -cleanup { + dog destroy +} -result {Howdy Howdy Howdy} + +test typevariable-1.3 {predefined typevariables are OK} -body { + type dog { + typevariable greeting Hello + + method tget {} { + return $greeting + } + } + + dog create spot + dog create fido + + list [spot tget] [fido tget] [set ::dog::greeting] +} -cleanup { + dog destroy +} -result {Hello Hello Hello} + +test typevariable-1.4 {typevariables can be arrays} -body { + type dog { + typevariable greetings + + method fill {} { + set greetings(a) Hi + set greetings(b) Howdy + } + } + + dog create spot + spot fill + list $::dog::greetings(a) $::dog::greetings(b) +} -cleanup { + dog destroy +} -result {Hi Howdy} + +test typevariable-1.5 {typevariables can used in typemethods} -body { + type dog { + typevariable greetings Howdy + + typemethod greet {} { + return $greetings + } + } + + dog greet +} -cleanup { + dog destroy +} -result {Howdy} + +test typevariable-1.6 {typevariables can used in procs} -body { + type dog { + typevariable greetings Howdy + + method greet {} { + return [realGreet] + } + + proc realGreet {} { + return $greetings + } + } + + dog create spot + spot greet +} -cleanup { + dog destroy +} -result {Howdy} + +test typevariable-1.7 {mytypevar qualifies typevariables} -body { + type dog { + method tvname {name} { + mytypevar $name + } + } + + dog create spot + spot tvname myvar +} -cleanup { + dog destroy +} -result {::dog::myvar} + +test typevariable-1.8 {typevariable with too many initializers throws an error} -body { + type dog { + typevariable color dark brown + } +} -returnCodes { + error +} -result {Error in "typevariable color...", too many initializers} + +test typevariable-1.9 {typevariable with too many initializers throws an error} -body { + type dog { + typevariable color -array dark brown + } + + set result +} -returnCodes { + error +} -result {Error in "typevariable color...", too many initializers} + +test typevariable-1.10 {typevariable can initialize array variables} -body { + type dog { + typevariable data -array { + family jones + color brown + } + + typemethod getdata {item} { + return $data($item) + } + } + + list [dog getdata family] [dog getdata color] +} -cleanup { + dog destroy +} -result {jones brown} + +#----------------------------------------------------------------------- +# instance variable + +test ivariable-1.1 {myvar qualifies instance variables} -body { + type dog { + method vname {name} { + myvar $name + } + } + + dog create spot + spot vname somevar +} -cleanup { + dog destroy +} -result {::dog::Snit_inst1::somevar} + +test ivariable-1.2 {undefined instance variables are OK} -body { + type dog { + method setgreeting {value} { + variable greeting + + set greeting $value + } + + method getgreeting {} { + variable greeting + + return $greeting + } + } + + set spot [dog create spot] + spot setgreeting Hey + + dog create fido + fido setgreeting Howdy + + list [spot getgreeting] [fido getgreeting] [set ::dog::Snit_inst1::greeting] +} -cleanup { + dog destroy +} -result {Hey Howdy Hey} + +test ivariable-1.3 {instance variables are destroyed automatically} -body { + type dog { + constructor {args} { + variable greeting + + set greeting Hi + } + } + + dog create spot + set g1 $::dog::Snit_inst1::greeting + + spot destroy + list $g1 [info exists ::dog::Snit_inst1::greeting] +} -cleanup { + dog destroy +} -result {Hi 0} + +test ivariable-1.4 {defined instance variables need not be declared} -body { + type dog { + variable greetings + + method put {} { + set greetings Howdy + } + + method get {} { + return $greetings + } + } + + dog create spot + spot put + spot get +} -cleanup { + dog destroy +} -result {Howdy} + +test ivariable-1.5 {instance variables can be arrays} -body { + type dog { + variable greetings + + method fill {} { + set greetings(a) Hi + set greetings(b) Howdy + } + + method vname {} { + return [myvar greetings] + } + } + + dog create spot + spot fill + list [set [spot vname](a)] [set [spot vname](b)] +} -cleanup { + dog destroy +} -result {Hi Howdy} + +test ivariable-1.6 {instance variables can be initialized in the definition} -body { + type dog { + variable greetings {Hi Howdy} + variable empty {} + + method list {} { + list $greetings $empty + } + } + + dog create spot + spot list +} -cleanup { + dog destroy +} -result {{Hi Howdy} {}} + +test ivariable-1.7 {variable is illegal when selfns is undefined} -body { + type dog { + method caller {} { + callee + } + proc callee {} { + variable foo + } + } + + dog create spot + + spot caller +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {can't read "selfns": no such variable} + +test ivariable-1.8 {myvar is illegal when selfns is undefined} -body { + type dog { + method caller {} { + callee + } + proc callee {} { + myvar foo + } + } + + dog create spot + + spot caller +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {can't read "selfns": no such variable} + +test ivariable-1.9 {procs which define selfns see instance variables} -body { + type dog { + variable greeting Howdy + + method caller {} { + return [callee $selfns] + } + + proc callee {selfns} { + return $greeting + } + } + + dog create spot + + spot caller +} -cleanup { + dog destroy +} -result {Howdy} + +test ivariable-1.10 {in methods, variable works with fully qualified names} -body { + namespace eval ::somenamespace:: { + set somevar somevalue + } + + type dog { + method get {} { + variable ::somenamespace::somevar + return $somevar + } + } + + dog create spot + + spot get +} -cleanup { + dog destroy +} -result {somevalue} + +test ivariable-1.11 {variable with too many initializers throws an error} -body { + type dog { + variable color dark brown + } +} -returnCodes { + error +} -result {Error in "variable color...", too many initializers} + +test ivariable-1.12 {variable with too many initializers throws an error} -body { + type dog { + variable color -array dark brown + } +} -returnCodes { + error +} -result {Error in "variable color...", too many initializers} + +test ivariable-1.13 {variable can initialize array variables} -body { + type dog { + variable data -array { + family jones + color brown + } + + method getdata {item} { + return $data($item) + } + } + + dog spot + list [spot getdata family] [spot getdata color] +} -cleanup { + dog destroy +} -result {jones brown} + +#----------------------------------------------------------------------- +# codename +# +# NOTE: codename is deprecated; myproc should be used instead. + +test codename-1.1 {codename qualifies procs} -body { + type dog { + method qualify {} { + return [codename myproc] + } + proc myproc {} { } + } + dog create spot + spot qualify +} -cleanup { + dog destroy +} -result {::dog::myproc} + +test codename-1.2 {procs with selfns work} -body { + type dog { + variable datum foo + + method qualify {} { + return [list [codename getdatum] $selfns] + } + proc getdatum {selfns} { + return $datum + } + } + dog create spot + eval [spot qualify] +} -cleanup { + dog destroy +} -result {foo} + +#----------------------------------------------------------------------- +# Options + +test option-1.1 {options get default values} -body { + type dog { + option -color golden + } + + dog create spot + spot cget -color +} -cleanup { + dog destroy +} -result {golden} + +test option-1.2 {options can be set} -body { + type dog { + option -color golden + } + + dog create spot + spot configure -color black + spot cget -color +} -cleanup { + dog destroy +} -result {black} + +test option-1.3 {multiple options can be set} -body { + type dog { + option -color golden + option -akc 0 + } + + dog create spot + spot configure -color brown -akc 1 + list [spot cget -color] [spot cget -akc] +} -cleanup { + dog destroy +} -result {brown 1} + +test option-1.4 {options can be retrieved as instance variable} -body { + type dog { + option -color golden + option -akc 0 + + method listopts {} { + list $options(-color) $options(-akc) + } + } + + dog create spot + spot configure -color black -akc 1 + spot listopts +} -cleanup { + dog destroy +} -result {black 1} + +test option-1.5 {options can be set as an instance variable} -body { + type dog { + option -color golden + option -akc 0 + + method setopts {} { + set options(-color) black + set options(-akc) 1 + } + } + + dog create spot + spot setopts + list [spot cget -color] [spot cget -akc] +} -cleanup { + dog destroy +} -result {black 1} + +test option-1.6 {options can be set at creation time} -body { + type dog { + option -color golden + option -akc 0 + } + + dog create spot -color white -akc 1 + list [spot cget -color] [spot cget -akc] +} -cleanup { + dog destroy +} -result {white 1} + +test option-1.7 {undefined option: cget} -body { + type dog { + option -color golden + option -akc 0 + } + + dog create spot + spot cget -colour +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {unknown option "-colour"} + +test option-1.8 {undefined option: configure} -body { + type dog { + option -color golden + option -akc 0 + } + + dog create spot + spot configure -colour blue +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {unknown option "-colour"} + +test option-1.9 {options default to ""} -body { + type dog { + option -color + } + + dog create spot + spot cget -color +} -cleanup { + dog destroy +} -result {} + +test option-1.10 {spaces allowed in option defaults} -body { + type dog { + option -breed "golden retriever" + } + dog fido + fido cget -breed +} -cleanup { + dog destroy +} -result {golden retriever} + +test option-1.11 {brackets allowed in option defaults} -body { + type dog { + option -regexp {[a-z]+} + } + + dog fido + fido cget -regexp +} -cleanup { + dog destroy +} -result {[a-z]+} + +test option-2.1 {configure returns info, local options only} -body { + type dog { + option -color black + option -akc 1 + } + + dog create spot + spot configure -color red + spot configure -akc 0 + spot configure +} -cleanup { + dog destroy +} -result {{-color color Color black red} {-akc akc Akc 1 0}} + +test option-2.2 {configure -opt returns info, local options only} -body { + type dog { + option -color black + option -akc 1 + } + + dog create spot + spot configure -color red + spot configure -color +} -cleanup { + dog destroy +} -result {-color color Color black red} + +test option-2.3 {configure -opt returns info, explicit options} -body { + type papers { + option -akcflag 1 + } + + type dog { + option -color black + delegate option -akc to papers as -akcflag + constructor {args} { + set papers [papers create $self.papers] + } + + destructor { + catch {$self.papers destroy} + } + } + + dog create spot + spot configure -akc 0 + spot configure -akc +} -cleanup { + dog destroy +} -result {-akc akc Akc 1 0} + +test option-2.4 {configure -unknownopt} -body { + type papers { + option -akcflag 1 + } + + type dog { + option -color black + delegate option -akc to papers as -akcflag + constructor {args} { + set papers [papers create $self.papers] + } + + destructor { + catch {$self.papers destroy} + } + } + + dog create spot + spot configure -foo +} -returnCodes { + error +} -cleanup { + dog destroy + papers destroy +} -result {unknown option "-foo"} + +test option-2.5 {configure returns info, unknown options} -constraints { + tk +} -body { + widgetadaptor myframe { + option -foo a + delegate option -width to hull + delegate option * to hull + constructor {args} { + installhull [frame $self] + } + } + + myframe .frm + set a [.frm configure -foo] + set b [.frm configure -width] + set c [.frm configure -height] + destroy .frm + tkbide + + list $a $b $c + +} -cleanup { + myframe destroy +} -result {{-foo foo Foo a a} {-width width Width 0 0} {-height height Height 0 0}} + +test option-2.6 {configure -opt unknown to implicit component} -constraints { + tk +} -body { + widgetadaptor myframe { + delegate option * to hull + constructor {args} { + installhull [frame $self] + } + } + myframe .frm + catch {.frm configure -quux} result + destroy .frm + tkbide + set result +} -cleanup { + myframe destroy +} -result {unknown option "-quux"} + +test option-3.1 {set option resource name explicitly} -body { + type dog { + option {-tailcolor tailColor} black + } + + dog fido + + fido configure -tailcolor +} -cleanup { + dog destroy +} -result {-tailcolor tailColor TailColor black black} + +test option-3.2 {set option class name explicitly} -body { + type dog { + option {-tailcolor tailcolor TailColor} black + } + + dog fido + + fido configure -tailcolor +} -cleanup { + dog destroy +} -result {-tailcolor tailcolor TailColor black black} + +test option-3.3 {delegated option's names come from owner} -body { + type tail { + option -color black + } + + type dog { + delegate option -tailcolor to tail as -color + + constructor {args} { + set tail [tail fidotail] + } + } + + dog fido + + fido configure -tailcolor +} -cleanup { + dog destroy + tail destroy +} -result {-tailcolor tailcolor Tailcolor black black} + +test option-3.4 {delegated option's resource name set explicitly} -body { + type tail { + option -color black + } + + type dog { + delegate option {-tailcolor tailColor} to tail as -color + + constructor {args} { + set tail [tail fidotail] + } + } + + dog fido + + fido configure -tailcolor +} -cleanup { + dog destroy + tail destroy +} -result {-tailcolor tailColor TailColor black black} + +test option-3.5 {delegated option's class name set explicitly} -body { + type tail { + option -color black + } + + type dog { + delegate option {-tailcolor tailcolor TailColor} to tail as -color + + constructor {args} { + set tail [tail fidotail] + } + } + + dog fido + + fido configure -tailcolor +} -cleanup { + dog destroy + tail destroy +} -result {-tailcolor tailcolor TailColor black black} + +test option-3.6 {delegated option's default comes from component} -body { + type tail { + option -color black + } + + type dog { + delegate option -tailcolor to tail as -color + + constructor {args} { + set tail [tail fidotail -color red] + } + } + + dog fido + + fido configure -tailcolor +} -cleanup { + dog destroy + tail destroy +} -result {-tailcolor tailcolor Tailcolor black red} + +test option-4.1 {local option name must begin with hyphen} -body { + type dog { + option nohyphen + } +} -returnCodes { + error +} -result {Error in "option nohyphen...", badly named option "nohyphen"} + +test option-4.2 {local option name must be lower case} -body { + type dog { + option -Upper + } +} -returnCodes { + error +} -result {Error in "option -Upper...", badly named option "-Upper"} + +test option-4.3 {local option name may not contain spaces} -body { + type dog { + option {"-with space"} + } +} -returnCodes { + error +} -result {Error in "option {"-with space"}...", badly named option "-with space"} + +test option-4.4 {delegated option name must begin with hyphen} -body { + type dog { + delegate option nohyphen to tail + } +} -returnCodes { + error +} -result {Error in "delegate option nohyphen...", badly named option "nohyphen"} + +test option-4.5 {delegated option name must be lower case} -body { + type dog { + delegate option -Upper to tail + } +} -returnCodes { + error +} -result {Error in "delegate option -Upper...", badly named option "-Upper"} + +test option-4.6 {delegated option name may not contain spaces} -body { + type dog { + delegate option {"-with space"} to tail + } +} -returnCodes { + error +} -result {Error in "delegate option {"-with space"}...", badly named option "-with space"} + +test option-5.1 {local widget options read from option database} -constraints { + tk +} -body { + widget dog { + option -foo a + option -bar b + + typeconstructor { + option add *Dog.bar bb + } + } + + dog .fido + set a [.fido cget -foo] + set b [.fido cget -bar] + destroy .fido + tkbide + + list $a $b + +} -cleanup { + dog destroy +} -result {a bb} + +test option-5.2 {local option database values available in constructor} -constraints { + tk +} -body { + widget dog { + option -bar b + variable saveit + + typeconstructor { + option add *Dog.bar bb + } + + constructor {args} { + set saveit $options(-bar) + } + + method getit {} { + return $saveit + } + } + + dog .fido + set result [.fido getit] + destroy .fido + tkbide + + set result +} -cleanup { + dog destroy +} -result {bb} + +test option-6.1 {if no options, no options variable} -body { + type dog { + variable dummy + } + + dog spot + spot info vars options +} -cleanup { + dog destroy +} -result {} + +test option-6.2 {if no options, no options methods} -body { + type dog { + variable dummy + } + + dog spot + spot info methods c* +} -cleanup { + dog destroy +} -result {} + +#----------------------------------------------------------------------- +# onconfigure + +test onconfigure-1.1 {invalid onconfigure methods are caught} -body { + type dog { + onconfigure -color {value} { } + } +} -returnCodes { + error +} -result {onconfigure -color: option "-color" unknown} + +test onconfigure-1.2 {onconfigure methods take one argument} -body { + type dog { + option -color golden + + onconfigure -color {value badarg} { } + } +} -returnCodes { + error +} -result {onconfigure -color handler should have one argument, got "value badarg"} + +test onconfigure-1.3 {onconfigure methods work} -body { + type dog { + option -color golden + + onconfigure -color {value} { + set options(-color) "*$value*" + } + } + + dog create spot + spot configure -color brown + spot cget -color +} -cleanup { + dog destroy +} -result {*brown*} + +test onconfigure-1.4 {onconfigure arg can't be type} -body { + type dog { + option -color + onconfigure -color {type} { } + } +} -returnCodes { + error +} -result {onconfigure -color's arglist may not contain "type" explicitly} + +test onconfigure-1.5 {onconfigure arg can't be self} -body { + type dog { + option -color + onconfigure -color {self} { } + } +} -returnCodes { + error +} -result {onconfigure -color's arglist may not contain "self" explicitly} + +#----------------------------------------------------------------------- +# oncget + +test oncget-1.1 {invalid oncget methods are caught} -body { + type dog { + oncget -color { } + } +} -returnCodes { + error +} -result {Error in "oncget -color...", option "-color" unknown} + +test oncget-1.2 {oncget methods work} -body { + cleanup + + type dog { + option -color golden + + oncget -color { + return "*$options(-color)*" + } + } + + dog create spot + spot configure -color brown + spot cget -color +} -cleanup { + dog destroy +} -result {*brown*} + +#----------------------------------------------------------------------- +# constructor + + +test constructor-1.1 {constructor can do things} -body { + type dog { + variable a + variable b + constructor {args} { + set a 1 + set b 2 + } + method foo {} { + list $a $b + } + } + + dog create spot + spot foo +} -cleanup { + dog destroy +} -result {1 2} + +test constructor-1.2 {constructor with no configurelist ignores args} -body { + type dog { + constructor {args} { } + option -color golden + option -akc 0 + } + + dog create spot -color white -akc 1 + list [spot cget -color] [spot cget -akc] +} -cleanup { + dog destroy +} -result {golden 0} + +test constructor-1.3 {constructor with configurelist gets args} -body { + type dog { + constructor {args} { + $self configurelist $args + } + option -color golden + option -akc 0 + } + + dog create spot -color white -akc 1 + list [spot cget -color] [spot cget -akc] +} -cleanup { + dog destroy +} -result {white 1} + +test constructor-1.4 {constructor with specific args} -body { + type dog { + option -value "" + constructor {a b args} { + set options(-value) [list $a $b $args] + } + } + + dog spot retriever golden -akc 1 + spot cget -value +} -cleanup { + dog destroy +} -result {retriever golden {-akc 1}} + +test constructor-1.5 {constructor with list as one list arg} -body { + type dog { + option -value "" + constructor {args} { + set options(-value) $args + } + } + + dog spot {retriever golden} + spot cget -value +} -cleanup { + dog destroy +} -result {{retriever golden}} + +test constructor-1.6 {default constructor configures options} -body { + type dog { + option -color brown + option -breed mutt + } + + dog spot -color golden -breed retriever + list [spot cget -color] [spot cget -breed] +} -cleanup { + dog destroy +} -result {golden retriever} + +test constructor-1.7 {default constructor takes no args if no options} -body { + type dog { + variable color + } + + dog spot -color golden +} -returnCodes { + error +} -result "Error in constructor: [tcltest::tooManyArgs ::dog::Snit_constructor {type selfns win self}]" + +#----------------------------------------------------------------------- +# destroy + +test destroy-1.1 {destroy cleans up the instance} -body { + type dog { + option -color golden + } + + set a [namespace children ::dog::] + dog create spot + set b [namespace children ::dog::] + spot destroy + set c [namespace children ::dog::] + list $a $b $c [info commands ::dog::spot] +} -cleanup { + dog destroy +} -result {{} ::dog::Snit_inst1 {} {}} + +test destroy-1.2 {incomplete objects are destroyed} -body { + array unset ::dog::snit_ivars + + type dog { + option -color golden + + constructor {args} { + $self configurelist $args + + if {"red" == [$self cget -color]} { + error "No Red Dogs!" + } + } + } + + catch {dog create spot -color red} result + set names [array names ::dog::snit_ivars] + list $result $names [info commands ::dog::spot] +} -cleanup { + dog destroy +} -result {{Error in constructor: No Red Dogs!} {} {}} + +test destroy-1.3 {user-defined destructors are called} -body { + type dog { + typevariable flag "" + + constructor {args} { + set flag "created $self" + } + + destructor { + set flag "destroyed $self" + } + + typemethod getflag {} { + return $flag + } + } + + dog create spot + set a [dog getflag] + spot destroy + list $a [dog getflag] +} -cleanup { + dog destroy +} -result {{created ::spot} {destroyed ::spot}} + +#----------------------------------------------------------------------- +# delegate: general syntax tests + +test delegate-1.1 {can only delegate methods or options} -body { + type dog { + delegate foo bar to baz + } +} -returnCodes { + error +} -result {Error in "delegate foo bar...", "foo"?} + +test delegate-1.2 {"to" must appear in the right place} -body { + type dog { + delegate method foo from bar + } +} -returnCodes { + error +} -result {Error in "delegate method foo...", unknown delegation option "from"} + +test delegate-1.3 {"as" must have a target} -body { + type dog { + delegate method foo to bar as + } +} -returnCodes { + error +} -result {Error in "delegate method foo...", invalid syntax} + +test delegate-1.4 {"as" must have a single target} -body { + type dog { + delegate method foo to bar as baz quux + } +} -returnCodes { + error +} -result {Error in "delegate method foo...", unknown delegation option "quux"} + +test delegate-1.5 {"as" doesn't work with "*"} -body { + type dog { + delegate method * to hull as foo + } +} -returnCodes { + error +} -result {Error in "delegate method *...", cannot specify "as" with "*"} + +test delegate-1.6 {"except" must have a target} -body { + type dog { + delegate method * to bar except + } +} -returnCodes { + error +} -result {Error in "delegate method *...", invalid syntax} + +test delegate-1.7 {"except" must have a single target} -body { + type dog { + delegate method * to bar except baz quux + } +} -returnCodes { + error +} -result {Error in "delegate method *...", unknown delegation option "quux"} + +test delegate-1.8 {"except" works only with "*"} -body { + type dog { + delegate method foo to hull except bar + } +} -returnCodes { + error +} -result {Error in "delegate method foo...", can only specify "except" with "*"} + +test delegate-1.9 {only "as" or "except"} -body { + type dog { + delegate method foo to bar with quux + } +} -returnCodes { + error +} -result {Error in "delegate method foo...", unknown delegation option "with"} + + +#----------------------------------------------------------------------- +# delegated methods + +test dmethod-1.1 {delegate method to non-existent component} -body { + type dog { + delegate method foo to bar + } + + dog create spot + spot foo +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {::dog ::spot delegates method "foo" to undefined component "bar"} + +test dmethod-1.2 {delegating to existing component} -body { + type dog { + constructor {args} { + set string string + } + + delegate method length to string + } + + dog create spot + spot length foo +} -cleanup { + dog destroy +} -result {3} + +# Case 1 +test dmethod-1.3 {delegating to existing component with error} -constraints { + snit1 +} -body { + type dog { + constructor {args} { + set string string + } + + delegate method length to string + } + + dog create spot + spot length foo bar +} -cleanup { + dog destroy +} -returnCodes { + error +} -result {wrong # args: should be "string length string"} + +# Case 2 +test dmethod-1.4 {delegating to existing component with error} -constraints { + snit2 +} -body { + type dog { + constructor {args} { + set string string + } + + delegate method length to string + } + + dog create spot + spot length foo bar +} -cleanup { + dog destroy +} -returnCodes { + error +} -result {wrong # args: should be "spot length string"} + +test dmethod-1.5 {delegating unknown methods to existing component} -body { + type dog { + constructor {args} { + set string string + } + + delegate method * to string + } + + dog create spot + spot length foo +} -cleanup { + dog destroy +} -result {3} + +test dmethod-1.6 {delegating unknown method to existing component with error} -body { + type dog { + constructor {args} { + set stringhandler string + } + + delegate method * to stringhandler + } + + dog create spot + spot foo bar +} -constraints { + snit1 +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {bad option "foo": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, tolower, toupper, totitle, trim, trimleft, trimright, wordend, or wordstart} + +test dmethod-1.6a.0 {delegating unknown method to existing component with error} -body { + type dog { + constructor {args} { + set stringhandler string + } + + delegate method * to stringhandler + } + + dog create spot + spot foo bar +} -constraints { + snit2 tcl8.5minus +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {unknown or ambiguous subcommand "foo": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart} + +test dmethod-1.6a.1 {delegating unknown method to existing component with error} -body { + type dog { + constructor {args} { + set stringhandler string + } + + delegate method * to stringhandler + } + + dog create spot + spot foo bar +} -constraints { + snit2 tcl8.6plus +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {unknown or ambiguous subcommand "foo": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart} + +test dmethod-1.7 {can't delegate local method: order 1} -body { + type cat { + method foo {} {} + delegate method foo to hull + } +} -returnCodes { + error +} -result {Error in "delegate method foo...", "foo" has been defined locally.} + +test dmethod-1.8 {can't delegate local method: order 2} -body { + type cat { + delegate method foo to hull + method foo {} {} + } +} -returnCodes { + error +} -result {Error in "method foo...", "foo" has been delegated} + +# Case 1 +test dmethod-1.9 {excepted methods are caught properly} -constraints { + snit1 +} -body { + type tail { + method wag {} {return "wagged"} + method flaunt {} {return "flaunted"} + method tuck {} {return "tuck"} + } + + type cat { + method meow {} {} + delegate method * to tail except {wag tuck} + + constructor {args} { + set tail [tail %AUTO%] + } + } + + cat fifi + + catch {fifi flaunt} a + catch {fifi wag} b + catch {fifi tuck} c + + list $a $b $c +} -cleanup { + cat destroy + tail destroy +} -result {flaunted {"::fifi wag" is not defined} {"::fifi tuck" is not defined}} + +# Case 2 +test dmethod-1.10 {excepted methods are caught properly} -constraints { + snit2 +} -body { + type tail { + method wag {} {return "wagged"} + method flaunt {} {return "flaunted"} + method tuck {} {return "tuck"} + } + + type cat { + method meow {} {} + delegate method * to tail except {wag tuck} + + constructor {args} { + set tail [tail %AUTO%] + } + } + + cat fifi + + catch {fifi flaunt} a + catch {fifi wag} b + catch {fifi tuck} c + + list $a $b $c +} -cleanup { + cat destroy + tail destroy +} -result {flaunted {unknown subcommand "wag": must be flaunt} {unknown subcommand "tuck": must be flaunt}} + +test dmethod-1.11 {as clause can include arguments} -body { + type tail { + method wag {adverb} {return "wagged $adverb"} + } + + type dog { + delegate method wag to tail as {wag briskly} + + constructor {args} { + set tail [tail %AUTO%] + } + } + + dog spot + + spot wag +} -cleanup { + dog destroy + tail destroy +} -result {wagged briskly} + +test dmethod-2.1 {'using "%c %m"' gets normal behavior} -body { + type tail { + method wag {adverb} {return "wagged $adverb"} + } + + type dog { + delegate method wag to tail using {%c %m} + + constructor {args} { + set tail [tail %AUTO%] + } + } + + dog spot + + spot wag briskly +} -cleanup { + dog destroy + tail destroy +} -result {wagged briskly} + +test dmethod-2.2 {All 'using' conversions are converted} -body { + proc echo {args} { return $args } + + type dog { + delegate method {tail wag} using {echo %% %t %M %m %j %n %w %s %c} + } + + dog spot + + spot tail wag +} -cleanup { + dog destroy + rename echo "" +} -result {% ::dog {tail wag} wag tail_wag ::dog::Snit_inst1 ::spot ::spot %c} + +test dmethod-2.3 {"%%" is handled properly} -body { + proc echo {args} { join $args "|" } + + type dog { + delegate method wag using {echo %%m %%%m} + } + + dog spot + + spot wag +} -cleanup { + dog destroy + rename echo "" +} -result {%m|%wag} + +test dmethod-2.4 {Method "*" and "using"} -body { + proc echo {args} { join $args "|" } + + type dog { + delegate method * using {echo %m} + } + + dog spot + + list [spot wag] [spot bark loudly] +} -cleanup { + dog destroy + rename echo "" +} -result {wag bark|loudly} + + +test dmethod-3.1 {component names can be changed dynamically} -body { + type tail1 { + method wag {} {return "wagged"} + } + + type tail2 { + method wag {} {return "drooped"} + } + + type dog { + delegate method wag to tail + + constructor {args} { + set tail [tail1 %AUTO%] + } + + method switchit {} { + set tail [tail2 %AUTO%] + } + } + + dog fido + + set a [fido wag] + fido switchit + set b [fido wag] + + list $a $b +} -cleanup { + dog destroy + tail1 destroy + tail2 destroy +} -result {wagged drooped} + +test dmethod-4.1 {hierarchical method, two tokens} -body { + type tail { + method wag {} {return "wags tail"} + } + + type dog { + constructor {} { + set tail [tail %AUTO%] + } + delegate method {wag tail} to tail as wag + } + + dog spot + spot wag tail +} -cleanup { + dog destroy + tail destroy +} -result {wags tail} + +test dmethod-4.2 {hierarchical method, three tokens} -body { + type tail { + method wag {} {return "wags tail"} + } + + type dog { + constructor {} { + set tail [tail %AUTO%] + } + delegate method {wag tail proudly} to tail as wag + } + + dog spot + spot wag tail proudly +} -cleanup { + dog destroy + tail destroy +} -result {wags tail} + +test dmethod-4.3 {hierarchical method, three tokens} -body { + type tail { + method wag {} {return "wags tail"} + } + + type dog { + constructor {} { + set tail [tail %AUTO%] + } + delegate method {wag tail really high} to tail as wag + } + + dog spot + spot wag tail really high +} -cleanup { + dog destroy + tail destroy +} -result {wags tail} + +test dmethod-4.4 {redefinition is OK} -body { + type tail { + method {wag tail} {} {return "wags tail"} + method {wag briskly} {} {return "wags tail briskly"} + } + + type dog { + constructor {} { + set tail [tail %AUTO%] + } + delegate method {wag tail} to tail as {wag tail} + delegate method {wag tail} to tail as {wag briskly} + } + + dog spot + spot wag tail +} -cleanup { + dog destroy + tail destroy +} -result {wags tail briskly} + +test dmethod-4.5 {all tokens are used by default} -body { + type tail { + method wag {} {return "wags tail"} + } + + type dog { + constructor {} { + set tail [tail %AUTO%] + } + delegate method {tail wag} to tail + } + + dog spot + spot tail wag +} -cleanup { + dog destroy + tail destroy +} -result {wags tail} + +test dmethod-4.6 {last token can be *} -body { + type tail { + method wag {} {return "wags"} + method droop {} {return "droops"} + } + + type dog { + constructor {} { + set tail [tail %AUTO%] + } + delegate method {tail *} to tail + } + + dog spot + + list [spot tail wag] [spot tail droop] +} -cleanup { + dog destroy + tail destroy +} -result {wags droops} + +# Case 1 +test dmethod-4.7 {except with multiple tokens} -constraints { + snit1 +} -body { + type tail { + method wag {} {return "wags"} + method droop {} {return "droops"} + } + + type dog { + constructor {} { + set tail [tail %AUTO%] + } + delegate method {tail *} to tail except droop + } + + dog spot + + catch {spot tail droop} result + + list [spot tail wag] $result +} -cleanup { + dog destroy + tail destroy +} -result {wags {"::spot tail droop" is not defined}} + +# Case 2 +test dmethod-4.8 {except with multiple tokens} -constraints { + snit2 +} -body { + type tail { + method wag {} {return "wags"} + method droop {} {return "droops"} + } + + type dog { + constructor {} { + set tail [tail %AUTO%] + } + delegate method {tail *} to tail except droop + } + + dog spot + + catch {spot tail droop} result + + list [spot tail wag] $result +} -cleanup { + dog destroy + tail destroy +} -result {wags {unknown subcommand "droop": namespace ::dog::Snit_inst1 does not export any commands}} + +test dmethod-4.9 {"*" in the wrong spot} -body { + type dog { + delegate method {tail * wag} to tail + } +} -returnCodes { + error +} -result {Error in "delegate method {tail * wag}...", "*" must be the last token.} + +test dmethod-5.1 {prefix/method collision} -body { + type dog { + delegate method wag to tail + delegate method {wag tail} to tail as wag + } +} -returnCodes { + error +} -result {Error in "delegate method {wag tail}...", "wag" has no submethods.} + +test dmethod-5.2 {prefix/method collision} -body { + type dog { + delegate method {wag tail} to tail as wag + delegate method wag to tail + } +} -returnCodes { + error +} -result {Error in "delegate method wag...", "wag" has submethods.} + +test dmethod-5.3 {prefix/method collision} -body { + type dog { + delegate method {wag tail} to tail + delegate method {wag tail proudly} to tail as wag + } +} -returnCodes { + error +} -result {Error in "delegate method {wag tail proudly}...", "wag tail" has no submethods.} + +test dmethod-5.4 {prefix/method collision} -body { + type dog { + delegate method {wag tail proudly} to tail as wag + delegate method {wag tail} to tail + } +} -returnCodes { + error +} -result {Error in "delegate method {wag tail}...", "wag tail" has submethods.} + +#----------------------------------------------------------------------- +# delegated options + +test doption-1.1 {delegate option to non-existent component} -body { + type dog { + delegate option -foo to bar + } + + dog create spot + spot cget -foo +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {component "bar" is undefined in ::dog ::spot} + +test doption-1.2 {delegating option to existing component: cget} -body { + type cat { + option -color "black" + } + + cat create hershey + + type dog { + constructor {args} { + set catthing ::hershey + } + + delegate option -color to catthing + } + + dog create spot + spot cget -color +} -cleanup { + dog destroy + cat destroy +} -result {black} + +test doption-1.3 {delegating option to existing component: configure} -body { + type cat { + option -color "black" + } + + cat create hershey + + type dog { + constructor {args} { + set catthing ::hershey + $self configurelist $args + } + + delegate option -color to catthing + } + + dog create spot -color blue + list [spot cget -color] [hershey cget -color] +} -cleanup { + dog destroy + cat destroy +} -result {blue blue} + +test doption-1.4 {delegating unknown options to existing component} -body { + type cat { + option -color "black" + } + + cat create hershey + + type dog { + constructor {args} { + set catthing ::hershey + + # Note: must do this after components are defined; this + # may be a problem. + $self configurelist $args + } + + delegate option * to catthing + } + + dog create spot -color blue + list [spot cget -color] [hershey cget -color] +} -cleanup { + dog destroy + cat destroy +} -result {blue blue} + +test doption-1.5 {can't oncget for delegated option} -body { + type dog { + delegate option -color to catthing + + oncget -color { } + } +} -returnCodes { + error +} -result {Error in "oncget -color...", option "-color" is delegated} + +test doption-1.6 {can't onconfigure for delegated option} -body { + type dog { + delegate option -color to catthing + + onconfigure -color {value} { } + } +} -returnCodes { + error +} -result {onconfigure -color: option "-color" is delegated} + +test doption-1.7 {delegating unknown options to existing component: error} -body { + type cat { + option -color "black" + } + + cat create hershey + + type dog { + constructor {args} { + set catthing ::hershey + $self configurelist $args + } + + delegate option * to catthing + } + + dog create spot -colour blue +} -returnCodes { + error +} -cleanup { + dog destroy + cat destroy +} -result {Error in constructor: unknown option "-colour"} + +test doption-1.8 {can't delegate local option: order 1} -body { + type cat { + option -color "black" + delegate option -color to hull + } +} -returnCodes { + error +} -result {Error in "delegate option -color...", "-color" has been defined locally} + +test doption-1.9 {can't delegate local option: order 2} -body { + type cat { + delegate option -color to hull + option -color "black" + } +} -returnCodes { + error +} -result {Error in "option -color...", cannot define "-color" locally, it has been delegated} + +test doption-1.10 {excepted options are caught properly on cget} -body { + type tail { + option -a a + option -b b + option -c c + } + + type cat { + delegate option * to tail except {-b -c} + + constructor {args} { + set tail [tail %AUTO%] + } + } + + cat fifi + + catch {fifi cget -a} a + catch {fifi cget -b} b + catch {fifi cget -c} c + + list $a $b $c +} -cleanup { + cat destroy + tail destroy +} -result {a {unknown option "-b"} {unknown option "-c"}} + +test doption-1.11 {excepted options are caught properly on configurelist} -body { + type tail { + option -a a + option -b b + option -c c + } + + type cat { + delegate option * to tail except {-b -c} + + constructor {args} { + set tail [tail %AUTO%] + } + } + + cat fifi + + catch {fifi configurelist {-a 1}} a + catch {fifi configurelist {-b 1}} b + catch {fifi configurelist {-c 1}} c + + list $a $b $c +} -cleanup { + cat destroy + tail destroy +} -result {{} {unknown option "-b"} {unknown option "-c"}} + +test doption-1.12 {excepted options are caught properly on configure, 1} -body { + type tail { + option -a a + option -b b + option -c c + } + + type cat { + delegate option * to tail except {-b -c} + + constructor {args} { + set tail [tail %AUTO%] + } + } + + cat fifi + + catch {fifi configure -a 1} a + catch {fifi configure -b 1} b + catch {fifi configure -c 1} c + + list $a $b $c +} -cleanup { + cat destroy + tail destroy +} -result {{} {unknown option "-b"} {unknown option "-c"}} + +test doption-1.13 {excepted options are caught properly on configure, 2} -body { + type tail { + option -a a + option -b b + option -c c + } + + type cat { + delegate option * to tail except {-b -c} + + constructor {args} { + set tail [tail %AUTO%] + } + } + + cat fifi + + catch {fifi configure -a} a + catch {fifi configure -b} b + catch {fifi configure -c} c + + list $a $b $c +} -cleanup { + cat destroy + tail destroy +} -result {{-a a A a a} {unknown option "-b"} {unknown option "-c"}} + +test doption-1.14 {configure query skips excepted options} -body { + type tail { + option -a a + option -b b + option -c c + } + + type cat { + option -d d + delegate option * to tail except {-b -c} + + constructor {args} { + set tail [tail %AUTO%] + } + } + + cat fifi + + fifi configure +} -cleanup { + cat destroy + tail destroy +} -result {{-d d D d d} {-a a A a a}} + + +#----------------------------------------------------------------------- +# from + +test from-1.1 {getting default values} -body { + type dog { + option -foo FOO + option -bar BAR + + constructor {args} { + $self configure -foo [from args -foo AAA] + $self configure -bar [from args -bar] + } + } + + dog create spot + list [spot cget -foo] [spot cget -bar] +} -cleanup { + dog destroy +} -result {AAA BAR} + +test from-1.2 {getting non-default values} -body { + type dog { + option -foo FOO + option -bar BAR + option -args + + constructor {args} { + $self configure -foo [from args -foo] + $self configure -bar [from args -bar] + $self configure -args $args + } + } + + dog create spot -foo quux -baz frobnitz -bar frobozz + list [spot cget -foo] [spot cget -bar] [spot cget -args] +} -cleanup { + dog destroy +} -result {quux frobozz {-baz frobnitz}} + +#----------------------------------------------------------------------- +# Widgetadaptors + +test widgetadaptor-1.1 {creating a widget: hull hijacking} -constraints { + tk +} -body { + widgetadaptor mylabel { + constructor {args} { + installhull [label $self] + $self configurelist $args + } + + delegate method * to hull + delegate option * to hull + } + + mylabel create .label -text "My Label" + + set a [.label cget -text] + set b [hull1.label cget -text] + + destroy .label + tkbide + list $a $b +} -cleanup { + mylabel destroy +} -result {{My Label} {My Label}} + +test widgetadaptor-1.2 {destroying a widget with destroy} -constraints { + tk +} -body { + widgetadaptor mylabel { + constructor {} { + installhull [label $self] + } + } + + mylabel create .label + set a [namespace children ::mylabel] + destroy .label + set b [namespace children ::mylabel] + tkbide + list $a $b +} -cleanup { + mylabel destroy +} -result {::mylabel::Snit_inst1 {}} + +test widgetadaptor-1.3 {destroying two widgets of the same type with destroy} -constraints { + tk +} -body { + widgetadaptor mylabel { + constructor {} { + installhull [label $self] + } + } + + mylabel create .lab1 + mylabel create .lab2 + set a [namespace children ::mylabel] + destroy .lab1 + destroy .lab2 + set b [namespace children ::mylabel] + tkbide + list $a $b +} -cleanup { + mylabel destroy +} -result {{::mylabel::Snit_inst1 ::mylabel::Snit_inst2} {}} + +test widgetadaptor-1.4 {destroying a widget with rename, then destroy type} -constraints { + tk bug8.5a3 +} -body { + widgetadaptor mylabel { + constructor {} { + installhull [label $self] + } + } + + mylabel create .label + set a [namespace children ::mylabel] + rename .label "" + set b [namespace children ::mylabel] + + mylabel destroy + tkbide + list $a $b +} -result {::mylabel::Snit_inst1 {}} + +test widgetadaptor-1.5 {destroying two widgets of the same type with rename} -constraints { + tk bug8.5a3 +} -body { + widgetadaptor mylabel { + constructor {} { + installhull [label $self] + } + } + + mylabel create .lab1 + mylabel create .lab2 + set a [namespace children ::mylabel] + rename .lab1 "" + rename .lab2 "" + set b [namespace children ::mylabel] + mylabel destroy + tkbide + list $a $b +} -result {{::mylabel::Snit_inst1 ::mylabel::Snit_inst2} {}} + +test widgetadaptor-1.6 {create/destroy twice, with destroy} -constraints { + tk +} -body { + widgetadaptor mylabel { + constructor {} { + installhull [label $self] + } + } + + mylabel create .lab1 + set a [namespace children ::mylabel] + destroy .lab1 + + mylabel create .lab1 + set b [namespace children ::mylabel] + destroy .lab1 + + set c [namespace children ::mylabel] + mylabel destroy + tkbide + list $a $b $c +} -result {::mylabel::Snit_inst1 ::mylabel::Snit_inst2 {}} + +test widgetadaptor-1.7 {create/destroy twice, with rename} -constraints { + tk bug8.5a3 +} -body { + widgetadaptor mylabel { + constructor {} { + installhull [label $self] + } + } + + mylabel create .lab1 + set a [namespace children ::mylabel] + rename .lab1 "" + + mylabel create .lab1 + set b [namespace children ::mylabel] + rename .lab1 "" + + set c [namespace children ::mylabel] + mylabel destroy + tkbide + list $a $b $c +} -result {::mylabel::Snit_inst1 ::mylabel::Snit_inst2 {}} + +test widgetadaptor-1.8 {"create" is optional} -constraints { + tk +} -body { + widgetadaptor mylabel { + constructor {args} { + installhull [label $self] + } + method howdy {} {return "Howdy!"} + } + + mylabel .label + set a [.label howdy] + + destroy .label + tkbide + set a +} -cleanup { + mylabel destroy +} -result {Howdy!} + +# Case 1 +test widgetadaptor-1.9 {"create" is optional, but must be a valid name} -constraints { + snit1 + tk +} -body { + widgetadaptor mylabel { + constructor {args} { + installhull [label $self] + } + method howdy {} {return "Howdy!"} + } + + catch {mylabel foo} result + tkbide + set result +} -cleanup { + mylabel destroy +} -result {"::mylabel foo" is not defined} + +# Case 2 +test widgetadaptor-1.10 {"create" is optional, but must be a valid name} -constraints { + snit2 + tk +} -body { + widgetadaptor mylabel { + constructor {args} { + installhull [label $self] + } + method howdy {} {return "Howdy!"} + } + + catch {mylabel foo} result + tkbide + set result +} -cleanup { + mylabel destroy +} -result {unknown subcommand "foo": namespace ::mylabel does not export any commands} + +test widgetadaptor-1.11 {user-defined destructors are called} -constraints { + tk +} -body { + widgetadaptor mylabel { + typevariable flag "" + + constructor {args} { + installhull [label $self] + set flag "created $self" + } + + destructor { + set flag "destroyed $self" + } + + typemethod getflag {} { + return $flag + } + } + + mylabel .label + set a [mylabel getflag] + destroy .label + tkbide + list $a [mylabel getflag] +} -cleanup { + mylabel destroy +} -result {{created .label} {destroyed .label}} + +# Case 1 +test widgetadaptor-1.12 {destroy method not defined for widget types} -constraints { + snit1 + tk +} -body { + widgetadaptor mylabel { + constructor {args} { + installhull [label $self] + } + } + + mylabel .label + catch {.label destroy} result + destroy .label + tkbide + set result +} -cleanup { + mylabel destroy +} -result {".label destroy" is not defined} + +# Case 2 +test widgetadaptor-1.13 {destroy method not defined for widget types} -constraints { + snit2 + tk +} -body { + widgetadaptor mylabel { + constructor {args} { + installhull [label $self] + } + } + + mylabel .label + catch {.label destroy} result + destroy .label + tkbide + set result +} -cleanup { + mylabel destroy +} -result {unknown subcommand "destroy": namespace ::mylabel::Snit_inst1 does not export any commands} + +test widgetadaptor-1.14 {hull can be repeatedly renamed} -constraints { + tk +} -body { + widgetadaptor basetype { + constructor {args} { + installhull [label $self] + } + + method basemethod {} { return "basemethod" } + } + + widgetadaptor w1 { + constructor {args} { + installhull [basetype create $self] + } + } + + widgetadaptor w2 { + constructor {args} { + installhull [w1 $self] + } + } + + set a [w2 .foo] + destroy .foo + tkbide + set a +} -cleanup { + w2 destroy + w1 destroy + basetype destroy +} -result {.foo} + +test widgetadaptor-1.15 {widget names can be generated} -constraints { + tk +} -body { + widgetadaptor unique { + constructor {args} { + installhull [label $self] + } + } + + set w [unique .%AUTO%] + destroy $w + tkbide + set w +} -cleanup { + unique destroy +} -result {.unique1} + +test widgetadaptor-1.16 {snit::widgetadaptor as hull} -constraints { + tk +} -body { + widgetadaptor mylabel { + constructor {args} { + installhull [label $self] + $self configurelist $args + } + method method1 {} { + return "method1" + } + delegate option * to hull + } + + widgetadaptor mylabel2 { + constructor {args} { + installhull [mylabel $self] + $self configurelist $args + } + method method2 {} { + return "method2: [$hull method1]" + } + delegate option * to hull + } + + mylabel2 .label -text "Some Text" + set a [.label method2] + set b [.label cget -text] + .label configure -text "More Text" + set c [.label cget -text] + set d [namespace children ::mylabel2] + set e [namespace children ::mylabel] + + destroy .label + + set f [namespace children ::mylabel2] + set g [namespace children ::mylabel] + + mylabel2 destroy + mylabel destroy + + tkbide + list $a $b $c $d $e $f $g +} -result {{method2: method1} {Some Text} {More Text} ::mylabel2::Snit_inst1 ::mylabel::Snit_inst1 {} {}} + +test widgetadaptor-1.17 {snit::widgetadaptor as hull; use rename} -constraints { + tk bug8.5a3 +} -body { + widgetadaptor mylabel { + constructor {args} { + installhull [label $self] + $self configurelist $args + } + method method1 {} { + return "method1" + } + delegate option * to hull + } + + widgetadaptor mylabel2 { + constructor {args} { + installhull [mylabel $self] + $self configurelist $args + } + method method2 {} { + return "method2: [$hull method1]" + } + delegate option * to hull + } + + mylabel2 .label -text "Some Text" + set a [.label method2] + set b [.label cget -text] + .label configure -text "More Text" + set c [.label cget -text] + set d [namespace children ::mylabel2] + set e [namespace children ::mylabel] + + rename .label "" + + set f [namespace children ::mylabel2] + set g [namespace children ::mylabel] + + mylabel2 destroy + mylabel destroy + + tkbide + list $a $b $c $d $e $f $g +} -result {{method2: method1} {Some Text} {More Text} ::mylabel2::Snit_inst1 ::mylabel::Snit_inst1 {} {}} + +test widgetadaptor-1.18 {BWidget Label as hull} -constraints { + bwidget +} -body { + widgetadaptor mylabel { + constructor {args} { + installhull [Label $win] + $self configurelist $args + } + delegate option * to hull + } + + mylabel .label -text "Some Text" + set a [.label cget -text] + + .label configure -text "More Text" + set b [.label cget -text] + + set c [namespace children ::mylabel] + + destroy .label + + set d [namespace children ::mylabel] + + mylabel destroy + + tkbide + list $a $b $c $d +} -result {{Some Text} {More Text} ::mylabel::Snit_inst1 {}} + +test widgetadaptor-1.19 {error in widgetadaptor constructor} -constraints { + tk +} -body { + widgetadaptor mylabel { + constructor {args} { + error "Simulated Error" + } + } + + mylabel .lab +} -returnCodes { + error +} -cleanup { + mylabel destroy +} -result {Error in constructor: Simulated Error} + + +#----------------------------------------------------------------------- +# Widgets + +# A widget is just a widgetadaptor with an automatically created hull +# component (a Tk frame). So the widgetadaptor tests apply; all we +# need to test here is the frame creation. + +test widget-1.1 {creating a widget} -constraints { + tk +} -body { + widget myframe { + method hull {} { return $hull } + + delegate method * to hull + delegate option * to hull + } + + myframe create .frm -background green + + set a [.frm cget -background] + set b [.frm hull] + + destroy .frm + tkbide + list $a $b +} -cleanup { + myframe destroy +} -result {green ::hull1.frm} + +test widget-2.1 {can't redefine hull} -constraints { + tk +} -body { + widget myframe { + method resethull {} { set hull "" } + } + + myframe .frm + + .frm resethull +} -returnCodes { + error +} -cleanup { + myframe destroy +} -result {can't set "hull": The hull component cannot be redefined} + +#----------------------------------------------------------------------- +# install +# +# The install command is used to install widget components, while getting +# options for the option database. + +test install-1.1 {installed components are created properly} -constraints { + tk +} -body { + widget myframe { + # Delegate an option just to make sure the component variable + # exists. + delegate option -font to text + + constructor {args} { + install text using text $win.text -background green + } + + method getit {} { + $win.text cget -background + } + } + + myframe .frm + set a [.frm getit] + destroy .frm + tkbide + set a +} -cleanup { + myframe destroy +} -result {green} + +test install-1.2 {installed components are saved properly} -constraints { + tk +} -body { + widget myframe { + # Delegate an option just to make sure the component variable + # exists. + delegate option -font to text + + constructor {args} { + install text using text $win.text -background green + } + + method getit {} { + $text cget -background + } + } + + myframe .frm + set a [.frm getit] + destroy .frm + tkbide + set a +} -cleanup { + myframe destroy +} -result {green} + +test install-1.3 {can't install until hull exists} -constraints { + tk +} -body { + widgetadaptor myframe { + # Delegate an option just to make sure the component variable + # exists. + delegate option -font to text + + constructor {args} { + install text using text $win.text -background green + } + } + + myframe .frm +} -returnCodes { + error +} -cleanup { + myframe destroy +} -result {Error in constructor: tried to install "text" before the hull exists} + +test install-1.4 {install queries option database} -constraints { + tk +} -body { + widget myframe { + delegate option -font to text + + typeconstructor { + option add *Myframe.font Courier + } + + constructor {args} { + install text using text $win.text + } + } + + myframe .frm + set a [.frm cget -font] + destroy .frm + tkbide + set a +} -cleanup { + myframe destroy +} -result {Courier} + +test install-1.5 {explicit options override option database} -constraints { + tk +} -body { + widget myframe { + delegate option -font to text + + typeconstructor { + option add *Myframe.font Courier + } + + constructor {args} { + install text using text $win.text -font Times + } + } + + myframe .frm + set a [.frm cget -font] + destroy .frm + tkbide + set a +} -cleanup { + myframe destroy +} -result {Times} + +test install-1.6 {option db works with targetted options} -constraints { + tk +} -body { + widget myframe { + delegate option -textfont to text as -font + + typeconstructor { + option add *Myframe.textfont Courier + } + + constructor {args} { + install text using text $win.text + } + } + + myframe .frm + set a [.frm cget -textfont] + destroy .frm + tkbide + set a +} -cleanup { + myframe destroy +} -result {Courier} + +test install-1.7 {install works for snit::types} -body { + type tail { + option -tailcolor black + } + + type dog { + delegate option -tailcolor to tail + + constructor {args} { + install tail using tail $self.tail + } + } + + dog fido + fido cget -tailcolor +} -cleanup { + dog destroy + tail destroy +} -result {black} + +test install-1.8 {install can install non-widget components} -constraints { + tk +} -body { + type dog { + option -tailcolor black + } + + widget myframe { + delegate option -tailcolor to thedog + + typeconstructor { + option add *Myframe.tailcolor green + } + + constructor {args} { + install thedog using dog $win.dog + } + } + + myframe .frm + set a [.frm cget -tailcolor] + destroy .frm + tkbide + set a + +} -cleanup { + dog destroy + myframe destroy +} -result {green} + +test install-1.9 {ok if no options are delegated to component} -constraints { + tk +} -body { + type dog { + option -tailcolor black + } + + widget myframe { + constructor {args} { + install thedog using dog $win.dog + } + } + + myframe .frm + destroy .frm + tkbide + + # Test passes if no error is raised. + list ok +} -cleanup { + myframe destroy + dog destroy +} -result {ok} + +test install-2.1 { + delegate option * for a non-shadowed option. The text widget's + -foreground and -font options should be set according to what's + in the option database on the widgetclass. +} -constraints { + tk +} -body { + widget myframe { + delegate option * to text + + typeconstructor { + option add *Myframe.foreground red + option add *Myframe.font {Times 14} + } + + constructor {args} { + install text using text $win.text + } + } + + myframe .frm + set a [.frm cget -foreground] + set b [.frm cget -font] + destroy .frm + tkbide + + list $a $b +} -cleanup { + myframe destroy +} -result {red {Times 14}} + +test install-2.2 { + Delegate option * for a shadowed option. Foreground is declared + as a non-delegated option, hence it will pick up the option database + default. -foreground is not included in the "delegate option *", so + the text widget's -foreground option will not be set from the + option database. +} -constraints { + tk +} -body { + widget myframe { + option -foreground white + delegate option * to text + + typeconstructor { + option add *Myframe.foreground red + } + + constructor {args} { + install text using text $win.text + } + + method getit {} { + $text cget -foreground + } + } + + myframe .frm + set a [.frm cget -foreground] + set b [.frm getit] + destroy .frm + tkbide + + expr {![string equal $a $b]} +} -cleanup { + myframe destroy +} -result {1} + +test install-2.3 { + Delegate option * for a creation option. Because the text widget's + -foreground is set explicitly by the constructor, that always + overrides the option database. +} -constraints { + tk +} -body { + widget myframe { + delegate option * to text + + typeconstructor { + option add *Myframe.foreground red + } + + constructor {args} { + install text using text $win.text -foreground blue + } + } + + myframe .frm + set a [.frm cget -foreground] + destroy .frm + tkbide + + set a +} -cleanup { + myframe destroy +} -result {blue} + +test install-2.4 { + Delegate option * with an excepted option. Because the text widget's + -state is excepted, it won't be set from the option database. +} -constraints { + tk +} -body { + widget myframe { + delegate option * to text except -state + + typeconstructor { + option add *Myframe.foreground red + option add *Myframe.state disabled + } + + constructor {args} { + install text using text $win.text + } + + method getstate {} { + $text cget -state + } + } + + myframe .frm + set a [.frm getstate] + destroy .frm + tkbide + + set a +} -cleanup { + myframe destroy +} -result {normal} + +#----------------------------------------------------------------------- +# Advanced installhull tests +# +# installhull is used to install the hull widget for both widgets and +# widget adaptors. It has two forms. In one form it installs a widget +# created by some third party; in this form no querying of the option +# database is needed, because we haven't taken responsibility for creating +# it. But in the other form (installhull using) installhull actually +# creates the widget, and takes responsibility for querying the +# option database as needed. +# +# NOTE: "installhull using" is always used to create a widget's hull frame. +# +# That options passed into installhull override those from the +# option database. + +test installhull-1.1 { + options delegated to a widget's hull frame with the same name are + initialized from the option database. Note that there's no + explicit code in Snit to do this; it happens because we set the + -class when the widget was created. In fact, it happens whether + we delegate the option name or not. +} -constraints { + tk +} -body { + widget myframe { + delegate option -background to hull + + typeconstructor { + option add *Myframe.background red + option add *Myframe.width 123 + } + + method getwid {} { + $hull cget -width + } + } + + myframe .frm + set a [.frm cget -background] + set b [.frm getwid] + destroy .frm + tkbide + list $a $b +} -cleanup { + myframe destroy +} -result {red 123} + +test installhull-1.2 { + Options delegated to a widget's hull frame with a different name are + initialized from the option database. +} -constraints { + tk +} -body { + widget myframe { + delegate option -mainbackground to hull as -background + + typeconstructor { + option add *Myframe.mainbackground red + } + } + + myframe .frm + set a [.frm cget -mainbackground] + destroy .frm + tkbide + set a +} -cleanup { + myframe destroy +} -result {red} + +test installhull-1.3 { + options delegated to a widgetadaptor's hull frame with the same name are + initialized from the option database. Note that there's no + explicit code in Snit to do this; there's no way to change the + adapted hull widget's -class, so the widget is simply being + initialized normally. +} -constraints { + tk +} -body { + widgetadaptor myframe { + delegate option -background to hull + + typeconstructor { + option add *Frame.background red + option add *Frame.width 123 + } + + constructor {args} { + installhull using frame + } + + method getwid {} { + $hull cget -width + } + } + + myframe .frm + set a [.frm cget -background] + set b [.frm getwid] + destroy .frm + tkbide + list $a $b +} -cleanup { + myframe destroy +} -result {red 123} + +test installhull-1.4 { + Options delegated to a widget's hull frame with a different name are + initialized from the option database. +} -constraints { + tk +} -body { + widgetadaptor myframe { + delegate option -mainbackground to hull as -background + + typeconstructor { + option add *Frame.mainbackground red + } + + constructor {args} { + installhull using frame + } + } + + myframe .frm + set a [.frm cget -mainbackground] + destroy .frm + tkbide + set a +} -cleanup { + myframe destroy +} -result {red} + +test installhull-1.5 { + Option values read from the option database are overridden by options + explicitly passed, even if delegated under a different name. +} -constraints { + tk +} -body { + widgetadaptor myframe { + delegate option -mainbackground to hull as -background + + typeconstructor { + option add *Frame.mainbackground red + option add *Frame.width 123 + } + + constructor {args} { + installhull using frame -background green -width 321 + } + + method getwid {} { + $hull cget -width + } + } + + myframe .frm + set a [.frm cget -mainbackground] + set b [.frm getwid] + destroy .frm + tkbide + list $a $b +} -cleanup { + myframe destroy +} -result {green 321} + + +#----------------------------------------------------------------------- +# Instance Introspection + +# Case 1 +test iinfo-1.1 {object info too few args} -constraints { + snit1 +} -body { + type dog { } + + dog create spot + + spot info +} -returnCodes { + error +} -cleanup { + dog destroy +} -result [tcltest::wrongNumArgs ::snit::RT.method.info {type selfns win self command args} 4] + +# Case 2 +test iinfo-1.2 {object info too few args} -constraints { + snit2 +} -body { + type dog { } + + dog create spot + + spot info +} -returnCodes { + error +} -cleanup { + dog destroy +} -result [expect \ + {wrong # args: should be "spot info command ?arg ...?"} \ + {wrong # args: should be "spot info command ..."}] + +test iinfo-1.3 {object info too many args} -body { + type dog { } + + dog create spot + + spot info type foo +} -returnCodes { + error +} -cleanup { + dog destroy +} -result [tcltest::tooManyArgs ::snit::RT.method.info.type {type selfns win self}] + +test iinfo-2.1 {object info type} -body { + type dog { } + + dog create spot + spot info type +} -cleanup { + dog destroy +} -result {::dog} + +test iinfo-3.1 {object info typevars} -body { + type dog { + typevariable thisvar 1 + + constructor {args} { + typevariable thatvar 2 + } + } + + dog create spot + lsort [spot info typevars] +} -cleanup { + dog destroy +} -result {::dog::thatvar ::dog::thisvar} + +test iinfo-3.2 {object info typevars with pattern} -body { + type dog { + typevariable thisvar 1 + + constructor {args} { + typevariable thatvar 2 + } + } + + dog create spot + spot info typevars *this* +} -cleanup { + dog destroy +} -result {::dog::thisvar} + +test iinfo-4.1 {object info vars} -body { + type dog { + variable hisvar 1 + + constructor {args} { + variable hervar + set hervar 2 + } + } + + dog create spot + lsort [spot info vars] +} -cleanup { + dog destroy +} -result {::dog::Snit_inst1::hervar ::dog::Snit_inst1::hisvar} + +test iinfo-4.2 {object info vars with pattern} -body { + type dog { + variable hisvar 1 + + constructor {args} { + variable hervar + set hervar 2 + } + } + + dog create spot + spot info vars "*his*" +} -cleanup { + dog destroy +} -result {::dog::Snit_inst1::hisvar} + +test iinfo-5.1 {object info no vars defined} -body { + type dog { } + + dog create spot + list [spot info vars] [spot info typevars] +} -cleanup { + dog destroy +} -result {{} {}} + +test iinfo-6.1 {info options with no options} -body { + type dog { } + dog create spot + + llength [spot info options] +} -cleanup { + dog destroy +} -result {0} + +test iinfo-6.2 {info options with only local options} -body { + type dog { + option -foo a + option -bar b + } + dog create spot + + lsort [spot info options] +} -cleanup { + dog destroy +} -result {-bar -foo} + +test iinfo-6.3 {info options with local and delegated options} -body { + type dog { + option -foo a + option -bar b + delegate option -quux to sibling + } + dog create spot + + lsort [spot info options] +} -cleanup { + dog destroy +} -result {-bar -foo -quux} + +test iinfo-6.4 {info options with unknown delegated options} -constraints { + tk tcl83 +} -body { + widgetadaptor myframe { + option -foo a + delegate option * to hull + constructor {args} { + installhull [frame $self] + } + } + myframe .frm + + set a [lsort [.frm info options]] + destroy .frm + tkbide + set a +} -cleanup { + myframe destroy +} -result {-background -bd -bg -borderwidth -class -colormap -container -cursor -foo -height -highlightbackground -highlightcolor -highlightthickness -relief -takefocus -visual -width} + +test iinfo-6.5 {info options with unknown delegated options} -constraints { + tk tcl84 +} -body { + widgetadaptor myframe { + option -foo a + delegate option * to hull + constructor {args} { + installhull [frame $self] + } + } + myframe .frm + + set a [lsort [.frm info options]] + destroy .frm + tkbide + set a +} -cleanup { + myframe destroy +} -result {-background -bd -bg -borderwidth -class -colormap -container -cursor -foo -height -highlightbackground -highlightcolor -highlightthickness -padx -pady -relief -takefocus -visual -width} + +test iinfo-6.6 {info options with exceptions} -constraints { + tk tcl83 +} -body { + widgetadaptor myframe { + option -foo a + delegate option * to hull except -background + constructor {args} { + installhull [frame $self] + } + } + myframe .frm + + set a [lsort [.frm info options]] + destroy .frm + tkbide + set a +} -cleanup { + myframe destroy +} -result {-bd -bg -borderwidth -class -colormap -container -cursor -foo -height -highlightbackground -highlightcolor -highlightthickness -relief -takefocus -visual -width} + +test iinfo-6.7 {info options with exceptions} -constraints { + tk tcl84 +} -body { + widgetadaptor myframe { + option -foo a + delegate option * to hull except -background + constructor {args} { + installhull [frame $self] + } + } + myframe .frm + + set a [lsort [.frm info options]] + destroy .frm + tkbide + set a +} -cleanup { + myframe destroy +} -result {-bd -bg -borderwidth -class -colormap -container -cursor -foo -height -highlightbackground -highlightcolor -highlightthickness -padx -pady -relief -takefocus -visual -width} + +test iinfo-6.8 {info options with pattern} -constraints { + tk +} -body { + widgetadaptor myframe { + option -foo a + delegate option * to hull + constructor {args} { + installhull [frame $self] + } + } + myframe .frm + + set a [lsort [.frm info options -c*]] + destroy .frm + tkbide + set a +} -cleanup { + myframe destroy +} -result {-class -colormap -container -cursor} + +test iinfo-7.1 {info typemethods, simple case} -body { + type dog { } + + dog spot + + lsort [spot info typemethods] +} -cleanup { + dog destroy +} -result {create destroy info} + +test iinfo-7.2 {info typemethods, with pattern} -body { + type dog { } + + dog spot + + spot info typemethods i* +} -cleanup { + dog destroy +} -result {info} + +test iinfo-7.3 {info typemethods, with explicit typemethods} -body { + type dog { + typemethod foo {} {} + delegate typemethod bar to comp + } + + dog spot + + lsort [spot info typemethods] +} -cleanup { + dog destroy +} -result {bar create destroy foo info} + +test iinfo-7.4 {info typemethods, with implicit typemethods} -body { + type dog { + delegate typemethod * to comp + + typeconstructor { + set comp string + } + } + + dog create spot + + set a [lsort [spot info typemethods]] + + dog length foo + dog is boolean yes + + set b [lsort [spot info typemethods]] + + set c [spot info typemethods len*] + + list $a $b $c +} -cleanup { + dog destroy +} -result {{create destroy info} {create destroy info is length} length} + +test iinfo-7.5 {info typemethods, with hierarchical typemethods} -body { + type dog { + delegate typemethod {comp foo} to comp + + typemethod {comp bar} {} {} + } + + dog create spot + + lsort [spot info typemethods] +} -cleanup { + dog destroy +} -result {{comp bar} {comp foo} create destroy info} + + +test iinfo-8.1 {info methods, simple case} -body { + type dog { } + + dog spot + + lsort [spot info methods] +} -cleanup { + dog destroy +} -result {destroy info} + +test iinfo-8.2 {info methods, with pattern} -body { + type dog { } + + dog spot + + spot info methods i* +} -cleanup { + dog destroy +} -result {info} + +test iinfo-8.3 {info methods, with explicit methods} -body { + type dog { + method foo {} {} + delegate method bar to comp + } + + dog spot + + lsort [spot info methods] +} -cleanup { + dog destroy +} -result {bar destroy foo info} + +test iinfo-8.4 {info methods, with implicit methods} -body { + type dog { + delegate method * to comp + + constructor {args} { + set comp string + } + } + + dog create spot + + set a [lsort [spot info methods]] + + spot length foo + spot is boolean yes + + set b [lsort [spot info methods]] + + set c [spot info methods len*] + + list $a $b $c +} -cleanup { + dog destroy +} -result {{destroy info} {destroy info is length} length} + +test iinfo-8.5 {info methods, with hierarchical methods} -body { + type dog { + delegate method {comp foo} to comp + + method {comp bar} {} {} + } + + dog create spot + + lsort [spot info methods] +} -cleanup { + dog destroy +} -result {{comp bar} {comp foo} destroy info} + +test iinfo-9.1 {info args} -body { + type dog { + method bark {volume} {} + } + + dog spot + + spot info args bark +} -cleanup { + dog destroy +} -result {volume} + +test iinfo-9.2 {info args, too few args} -body { + type dog { + method bark {volume} {} + } + + dog spot + + spot info args +} -returnCodes error -cleanup { + dog destroy +} -result [tcltest::wrongNumArgs ::snit::RT.method.info.args {type selfns win self method} 4] + +test iinfo-9.3 {info args, too many args} -body { + type dog { + method bark {volume} {} + } + + dog spot + + spot info args bark wag +} -returnCodes error -cleanup { + dog destroy +} -result [tcltest::tooManyArgs ::snit::RT.method.info.args {type selfns win self method}] + +test iinfo-9.4 {info args, unknown method} -body { + type dog { + } + + dog spot + + spot info args bark +} -returnCodes error -cleanup { + dog destroy +} -result {Unknown method "bark"} + +test iinfo-9.5 {info args, delegated method} -body { + type dog { + component x + delegate method bark to x + } + + dog spot + + spot info args bark +} -returnCodes error -cleanup { + dog destroy +} -result {Delegated method "bark"} + +test iinfo-10.1 {info default} -body { + type dog { + method bark {{volume 50}} {} + } + + dog spot + + list [spot info default bark volume def] $def +} -cleanup { + dog destroy +} -result {1 50} + +test iinfo-10.2 {info default, too few args} -body { + type dog { + method bark {volume} {} + } + + dog spot + + spot info default +} -returnCodes error -cleanup { + dog destroy +} -result [tcltest::wrongNumArgs ::snit::RT.method.info.default {type selfns win self method aname dvar} 4] + +test iinfo-10.3 {info default, too many args} -body { + type dog { + method bark {volume} {} + } + + dog spot + + spot info default bark wag def foo +} -returnCodes error -cleanup { + dog destroy +} -result [tcltest::tooManyArgs ::snit::RT.method.info.default {type selfns win self method aname dvar}] + +test iinfo-10.4 {info default, unknown method} -body { + type dog { + } + + dog spot + + spot info default bark x var +} -returnCodes error -cleanup { + dog destroy +} -result {Unknown method "bark"} + +test iinfo-10.5 {info default, delegated method} -body { + type dog { + component x + delegate method bark to x + } + + dog spot + + spot info default bark x var +} -returnCodes error -cleanup { + dog destroy +} -result {Delegated method "bark"} + +test iinfo-11.1 {info body} -body { + type dog { + typevariable x + variable y + method bark {volume} { + speaker on + speaker play bark.snd + speaker off + } + } + + dog spot + + spot info body bark +} -cleanup { + dog destroy +} -result { + speaker on + speaker play bark.snd + speaker off + } + +test iinfo-11.2 {info body, too few args} -body { + type dog { + method bark {volume} {} + } + + dog spot + + spot info body +} -returnCodes error -cleanup { + dog destroy +} -result [tcltest::wrongNumArgs ::snit::RT.method.info.body {type selfns win self method} 4] + +test iinfo-11.3 {info body, too many args} -body { + type dog { + method bark {volume} {} + } + + dog spot + + spot info body bark wag +} -returnCodes error -cleanup { + dog destroy +} -result [tcltest::tooManyArgs ::snit::RT.method.info.body {type selfns win self method}] + +test iinfo-11.4 {info body, unknown method} -body { + type dog { + } + + dog spot + + spot info body bark +} -returnCodes error -cleanup { + dog destroy +} -result {Unknown method "bark"} + +test iinfo-11.5 {info body, delegated method} -body { + type dog { + component x + delegate method bark to x + } + + dog spot + + spot info body bark +} -returnCodes error -cleanup { + dog destroy +} -result {Delegated method "bark"} + +#----------------------------------------------------------------------- +# Type Introspection + +# Case 1 +test tinfo-1.1 {type info too few args} -constraints { + snit1 +} -body { + type dog { } + + dog info +} -returnCodes { + error +} -cleanup { + dog destroy +} -result [tcltest::wrongNumArgs ::snit::RT.typemethod.info {type command args} 1] + +# Case 2 +test tinfo-1.2 {type info too few args} -constraints { + snit2 +} -body { + type dog { } + + dog info +} -returnCodes { + error +} -cleanup { + dog destroy +} -result [expect \ + {wrong # args: should be "dog info command ?arg ...?"} \ + {wrong # args: should be "dog info command ..."}] + +test tinfo-1.3 {type info too many args} -body { + type dog { } + + dog info instances foo bar +} -returnCodes { + error +} -cleanup { + dog destroy +} -result [tcltest::tooManyArgs ::snit::RT.typemethod.info.instances {type ?pattern?}] + +test tinfo-2.1 {type info typevars} -body { + type dog { + typevariable thisvar 1 + + constructor {args} { + typevariable thatvar 2 + } + } + + dog create spot + lsort [dog info typevars] +} -cleanup { + dog destroy +} -result {::dog::thatvar ::dog::thisvar} + +test tinfo-3.1 {type info instances} -body { + type dog { } + + dog create spot + dog create fido + + lsort [dog info instances] +} -cleanup { + dog destroy +} -result {::fido ::spot} + +test tinfo-3.2 {widget info instances} -constraints { + tk +} -body { + widgetadaptor mylabel { + constructor {args} { + installhull [label $self] + } + } + + mylabel .lab1 + mylabel .lab2 + + set result [mylabel info instances] + + destroy .lab1 + destroy .lab2 + tkbide + + lsort $result +} -cleanup { + mylabel destroy +} -result {.lab1 .lab2} + +test tinfo-3.3 {type info instances with non-global namespaces} -body { + type dog { } + + dog create ::spot + + namespace eval ::dogs:: { + set ::qname [dog create fido] + } + + list $qname [lsort [dog info instances]] +} -cleanup { + dog destroy +} -result {::dogs::fido {::dogs::fido ::spot}} + +test tinfo-3.4 {type info instances with pattern} -body { + type dog { } + + dog create spot + dog create fido + + dog info instances "*f*" +} -cleanup { + dog destroy +} -result {::fido} + +test tinfo-3.5 {type info instances with unrelated child namespace, bug 2898640} -body { + type dog { } + namespace eval dog::unrelated {} + dog create fido + + dog info instances +} -cleanup { + dog destroy +} -result {::fido} + +test tinfo-4.1 {type info typevars with pattern} -body { + type dog { + typevariable thisvar 1 + + constructor {args} { + typevariable thatvar 2 + } + } + + dog create spot + dog info typevars *this* +} -cleanup { + dog destroy +} -result {::dog::thisvar} + +test tinfo-5.1 {type info typemethods, simple case} -body { + type dog { } + + lsort [dog info typemethods] +} -cleanup { + dog destroy +} -result {create destroy info} + +test tinfo-5.2 {type info typemethods, with pattern} -body { + type dog { } + + dog info typemethods i* +} -cleanup { + dog destroy +} -result {info} + +test tinfo-5.3 {type info typemethods, with explicit typemethods} -body { + type dog { + typemethod foo {} {} + delegate typemethod bar to comp + } + + lsort [dog info typemethods] +} -cleanup { + dog destroy +} -result {bar create destroy foo info} + +test tinfo-5.4 {type info typemethods, with implicit typemethods} -body { + type dog { + delegate typemethod * to comp + + typeconstructor { + set comp string + } + } + + set a [lsort [dog info typemethods]] + + dog length foo + dog is boolean yes + + set b [lsort [dog info typemethods]] + + set c [dog info typemethods len*] + + list $a $b $c +} -cleanup { + dog destroy +} -result {{create destroy info} {create destroy info is length} length} + +test tinfo-5.5 {info typemethods, with hierarchical typemethods} -body { + type dog { + delegate typemethod {comp foo} to comp + + typemethod {comp bar} {} {} + } + + lsort [dog info typemethods] +} -cleanup { + dog destroy +} -result {{comp bar} {comp foo} create destroy info} + +test tinfo-6.1 {type info args} -body { + type dog { + typemethod bark {volume} {} + } + + dog info args bark +} -cleanup { + dog destroy +} -result {volume} + +test tinfo-6.2 {type info args, too few args} -body { + type dog { + typemethod bark {volume} {} + } + + dog info args +} -returnCodes error -cleanup { + dog destroy +} -result [tcltest::wrongNumArgs ::snit::RT.typemethod.info.args {type method} 1] + +test tinfo-6.3 {type info args, too many args} -body { + type dog { + typemethod bark {volume} {} + } + + dog info args bark wag +} -returnCodes error -cleanup { + dog destroy +} -result [tcltest::tooManyArgs ::snit::RT.typemethod.info.args {type method}] + +test tinfo-6.4 {type info args, unknown method} -body { + type dog { + } + + dog info args bark +} -returnCodes error -cleanup { + dog destroy +} -result {Unknown typemethod "bark"} + +test tinfo-6.5 {type info args, delegated method} -body { + type dog { + delegate typemethod bark to x + } + + dog info args bark +} -returnCodes error -cleanup { + dog destroy +} -result {Delegated typemethod "bark"} + +test tinfo-7.1 {type info default} -body { + type dog { + typemethod bark {{volume 50}} {} + } + + list [dog info default bark volume def] $def +} -cleanup { + dog destroy +} -result {1 50} + +test tinfo-7.2 {type info default, too few args} -body { + type dog { + typemethod bark {volume} {} + } + + dog info default +} -returnCodes error -cleanup { + dog destroy +} -result [tcltest::wrongNumArgs ::snit::RT.typemethod.info.default {type method aname dvar} 1] + +test tinfo-7.3 {type info default, too many args} -body { + type dog { + typemethod bark {volume} {} + } + + dog info default bark wag def foo +} -returnCodes error -cleanup { + dog destroy +} -result [tcltest::tooManyArgs ::snit::RT.typemethod.info.default {type method aname dvar}] + +test tinfo-7.4 {type info default, unknown method} -body { + type dog { + } + + dog info default bark x var +} -returnCodes error -cleanup { + dog destroy +} -result {Unknown typemethod "bark"} + +test tinfo-7.5 {type info default, delegated method} -body { + type dog { + delegate typemethod bark to x + } + + dog info default bark x var +} -returnCodes error -cleanup { + dog destroy +} -result {Delegated typemethod "bark"} + +test tinfo-8.1 {type info body} -body { + type dog { + typevariable x + variable y + typemethod bark {volume} { + speaker on + speaker play bark.snd + speaker off + } + } + + dog info body bark +} -cleanup { + dog destroy +} -result { + speaker on + speaker play bark.snd + speaker off + } + +test tinfo-8.2 {type info body, too few args} -body { + type dog { + typemethod bark {volume} {} + } + + dog info body +} -returnCodes error -cleanup { + dog destroy +} -result [tcltest::wrongNumArgs ::snit::RT.typemethod.info.body {type method} 1] + +test tinfo-8.3 {type info body, too many args} -body { + type dog { + typemethod bark {volume} {} + } + + dog info body bark wag +} -returnCodes error -cleanup { + dog destroy +} -result [tcltest::tooManyArgs ::snit::RT.typemethod.info.body {type method}] + +test tinfo-8.4 {type info body, unknown method} -body { + type dog { + } + + dog info body bark +} -returnCodes error -cleanup { + dog destroy +} -result {Unknown typemethod "bark"} + +test tinfo-8.5 {type info body, delegated method} -body { + type dog { + delegate typemethod bark to x + } + + dog info body bark +} -returnCodes error -cleanup { + dog destroy +} -result {Delegated typemethod "bark"} + +#----------------------------------------------------------------------- +# Setting the widget class explicitly + +test widgetclass-1.1 {can't set widgetclass for snit::types} -body { + type dog { + widgetclass Dog + } +} -returnCodes { + error +} -result {widgetclass cannot be set for snit::types} + +test widgetclass-1.2 {can't set widgetclass for snit::widgetadaptors} -constraints { + tk +} -body { + widgetadaptor dog { + widgetclass Dog + } +} -returnCodes { + error +} -result {widgetclass cannot be set for snit::widgetadaptors} + +test widgetclass-1.3 {widgetclass must begin with uppercase letter} -constraints { + tk +} -body { + widget dog { + widgetclass dog + } +} -returnCodes { + error +} -result {widgetclass "dog" does not begin with an uppercase letter} + +test widgetclass-1.4 {widgetclass can only be defined once} -constraints { + tk +} -body { + widget dog { + widgetclass Dog + widgetclass Dog + } +} -returnCodes { + error +} -result {too many widgetclass statements} + +test widgetclass-1.5 {widgetclass set successfully} -constraints { + tk +} -body { + widget dog { + widgetclass DogWidget + } + + # The test passes if no error is thrown. + list ok +} -cleanup { + dog destroy +} -result {ok} + +test widgetclass-1.6 {implicit widgetclass applied to hull} -constraints { + tk +} -body { + widget dog { + typeconstructor { + option add *Dog.background green + } + + method background {} { + $hull cget -background + } + } + + dog .dog + + set bg [.dog background] + + destroy .dog + + set bg +} -cleanup { + dog destroy +} -result {green} + +test widgetclass-1.7 {explicit widgetclass applied to hull} -constraints { + tk +} -body { + widget dog { + widgetclass DogWidget + + typeconstructor { + option add *DogWidget.background green + } + + method background {} { + $hull cget -background + } + } + + dog .dog + + set bg [.dog background] + + destroy .dog + + set bg +} -cleanup { + dog destroy +} -result {green} + +#----------------------------------------------------------------------- +# hulltype statement + +test hulltype-1.1 {can't set hulltype for snit::types} -body { + type dog { + hulltype Dog + } +} -returnCodes { + error +} -result {hulltype cannot be set for snit::types} + +test hulltype-1.2 {can't set hulltype for snit::widgetadaptors} -constraints { + tk +} -body { + widgetadaptor dog { + hulltype Dog + } +} -returnCodes { + error +} -result {hulltype cannot be set for snit::widgetadaptors} + +test hulltype-1.3 {hulltype can be frame} -constraints { + tk +} -body { + widget dog { + delegate option * to hull + hulltype frame + } + + dog .fido + catch {.fido configure -use} result + destroy .fido + tkbide + + set result +} -cleanup { + dog destroy +} -result {unknown option "-use"} + +test hulltype-1.4 {hulltype can be toplevel} -constraints { + tk +} -body { + widget dog { + delegate option * to hull + hulltype toplevel + } + + dog .fido + catch {.fido configure -use} result + destroy .fido + tkbide + + set result +} -cleanup { + dog destroy +} -result {-use use Use {} {}} + +test hulltype-1.5 {hulltype can only be defined once} -constraints { + tk +} -body { + widget dog { + hulltype frame + hulltype toplevel + } +} -returnCodes { + error +} -result {too many hulltype statements} + +test hulltype-2.1 {list of valid hulltypes} -constraints { + tk +} -body { + lsort $::snit::hulltypes +} -result {frame labelframe tk::frame tk::labelframe tk::toplevel toplevel ttk::frame ttk::labelframe} + + +#----------------------------------------------------------------------- +# expose statement + +test expose-1.1 {can't expose nothing} -body { + type dog { + expose + } +} -constraints { + snit1 +} -returnCodes { + error +} -result [tcltest::wrongNumArgs ::snit::Comp.statement.expose {component ?as? ?methodname?} 0] + +test expose-1.1a {can't expose nothing} -body { + type dog { + expose + } +} -constraints { + snit2 +} -returnCodes { + error +} -result [tcltest::wrongNumArgs expose {component ?as? ?methodname?} 0] + +test expose-1.2 {expose a component that's never installed} -body { + type dog { + expose tail + } + + dog fido + + fido tail wag +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {undefined component "tail"} + +test expose-1.3 {exposed method returns component command} -body { + type tail { } + + type dog { + expose tail + + constructor {} { + install tail using tail $self.tail + } + + destructor { + $tail destroy + } + } + + dog fido + + fido tail +} -cleanup { + dog destroy + tail destroy +} -result {::fido.tail} + +test expose-1.4 {exposed method calls component methods} -body { + type tail { + method wag {args} {return "wag<$args>"} + method droop {} {return "droop"} + } + + type dog { + expose tail + + constructor {} { + install tail using tail $self.tail + } + + destructor { + $tail destroy + } + } + + dog fido + + list [fido tail wag] [fido tail wag abc] [fido tail wag abc def] \ + [fido tail droop] +} -cleanup { + dog destroy + tail destroy +} -result {wag<> wag<abc> {wag<abc def>} droop} + +#----------------------------------------------------------------------- +# Error handling +# +# This section verifies that errorInfo and errorCode are propagated +# appropriately on error. + +test error-1.1 {typemethod errors propagate properly} -body { + type dog { + typemethod generr {} { + error bogusError bogusInfo bogusCode + } + } + + catch {dog generr} result + + global errorInfo errorCode + + list $result [string match "*bogusInfo*" $errorInfo] $errorCode +} -cleanup { + dog destroy +} -result {bogusError 1 bogusCode} + +test error-1.2 {snit::type constructor errors propagate properly} -body { + type dog { + constructor {} { + error bogusError bogusInfo bogusCode + } + } + + catch {dog fido} result + + global errorInfo errorCode + + list $result [string match "*bogusInfo*" $errorInfo] $errorCode +} -cleanup { + dog destroy +} -result {{Error in constructor: bogusError} 1 bogusCode} + +test error-1.3 {snit::widget constructor errors propagate properly} -constraints { + tk +} -body { + widget dog { + constructor {args} { + error bogusError bogusInfo bogusCode + } + } + + catch {dog .fido} result + + global errorInfo errorCode + + list $result [string match "*bogusInfo*" $errorInfo] $errorCode +} -cleanup { + dog destroy +} -result {{Error in constructor: bogusError} 1 bogusCode} + +test error-1.4 {method errors propagate properly} -body { + type dog { + method generr {} { + error bogusError bogusInfo bogusCode + } + } + + dog fido + catch {fido generr} result + + global errorInfo errorCode + + list $result [string match "*bogusInfo*" $errorInfo] $errorCode +} -cleanup { + dog destroy +} -result {bogusError 1 bogusCode} + +test error-1.5 {onconfigure errors propagate properly} -body { + type dog { + option -generr + + onconfigure -generr {value} { + error bogusError bogusInfo bogusCode + } + } + + dog fido + catch {fido configure -generr 0} result + + global errorInfo errorCode + + list $result [string match "*bogusInfo*" $errorInfo] $errorCode +} -cleanup { + dog destroy +} -result {bogusError 1 bogusCode} + +test error-1.6 {oncget errors propagate properly} -body { + type dog { + option -generr + + oncget -generr { + error bogusError bogusInfo bogusCode + } + } + + dog fido + catch {fido cget -generr} result + + global errorInfo errorCode + + list $result [string match "*bogusInfo*" $errorInfo] $errorCode +} -cleanup { + dog destroy +} -result {bogusError 1 bogusCode} + +#----------------------------------------------------------------------- +# Externally defined typemethods + +test etypemethod-1.1 {external typemethods can be called as expected} -body { + type dog { } + typemethod dog foo {a} {return "+$a+"} + + dog foo bar +} -cleanup { + dog destroy +} -result {+bar+} + +test etypemethod-1.2 {external typemethods can use typevariables} -body { + type dog { + typevariable somevar "Howdy" + } + typemethod dog getvar {} {return $somevar} + + dog getvar +} -cleanup { + dog destroy +} -result {Howdy} + +test etypemethod-1.3 {typemethods can be redefined dynamically} -body { + type dog { + typemethod foo {} { return "foo" } + } + set a [dog foo] + + typemethod dog foo {} { return "bar"} + + set b [dog foo] + + list $a $b +} -cleanup { + dog destroy +} -result {foo bar} + +test etypemethod-1.4 {can't define external typemethod if no type} -body { + typemethod extremelyraredog foo {} { return "bar"} +} -returnCodes { + error +} -result {no such type: "extremelyraredog"} + +test etypemethod-2.1 {external hierarchical method, two tokens} -body { + type dog { } + typemethod dog {wag tail} {} { + return "wags tail" + } + + dog wag tail +} -cleanup { + dog destroy +} -result {wags tail} + +test etypemethod-2.2 {external hierarchical method, three tokens} -body { + type dog { } + typemethod dog {wag tail proudly} {} { + return "wags tail proudly" + } + + dog wag tail proudly +} -cleanup { + dog destroy +} -result {wags tail proudly} + +test etypemethod-2.3 {external hierarchical method, three tokens} -body { + type dog { } + typemethod dog {wag tail really high} {} { + return "wags tail really high" + } + + dog wag tail really high +} -cleanup { + dog destroy +} -result {wags tail really high} + +test etypemethod-2.4 {redefinition is OK} -body { + type dog { } + typemethod dog {wag tail} {} { + return "wags tail" + } + typemethod dog {wag tail} {} { + return "wags tail briskly" + } + + dog wag tail +} -cleanup { + dog destroy +} -result {wags tail briskly} + +test etypemethod-3.1 {prefix/method collision} -body { + type dog { + typemethod wag {} {} + } + + typemethod dog {wag tail} {} {} +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {Cannot define "wag tail", "wag" has no submethods.} + +test etypemethod-3.2 {prefix/method collision} -body { + type dog { + typemethod {wag tail} {} {} + } + + typemethod dog wag {} {} +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {Cannot define "wag", "wag" has submethods.} + +test etypemethod-3.3 {prefix/method collision} -body { + type dog { + typemethod {wag tail} {} {} + } + + typemethod dog {wag tail proudly} {} {} +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {Cannot define "wag tail proudly", "wag tail" has no submethods.} + +test etypemethod-3.4 {prefix/method collision} -body { + type dog { + typemethod {wag tail proudly} {} {} + } + + typemethod dog {wag tail} {} {} +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {Cannot define "wag tail", "wag tail" has submethods.} + +#----------------------------------------------------------------------- +# Externally defined methods + +test emethod-1.1 {external methods can be called as expected} -body { + type dog { } + method dog bark {a} {return "+$a+"} + + dog spot + spot bark woof +} -cleanup { + dog destroy +} -result {+woof+} + +test emethod-1.2 {external methods can use typevariables} -body { + type dog { + typevariable somevar "Hello" + } + method dog getvar {} {return $somevar} + + dog spot + spot getvar +} -cleanup { + dog destroy +} -result {Hello} + +test emethod-1.3 {external methods can use variables} -body { + type dog { + variable somevar "Greetings" + } + method dog getvar {} {return $somevar} + + dog spot + spot getvar +} -cleanup { + dog destroy +} -result {Greetings} + +test emethod-1.4 {methods can be redefined dynamically} -body { + type dog { + method bark {} { return "woof" } + } + + dog spot + + set a [spot bark] + + method dog bark {} { return "arf"} + + set b [spot bark] + + list $a $b +} -cleanup { + dog destroy +} -result {woof arf} + +test emethod-1.5 {delegated methods can't be redefined} -body { + type dog { + delegate method bark to someotherdog + } + + method dog bark {} { return "arf"} +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {Cannot define "bark", "bark" has been delegated} + +test emethod-1.6 {can't define external method if no type} -body { + method extremelyraredog foo {} { return "bar"} +} -returnCodes { + error +} -result {no such type: "extremelyraredog"} + +test emethod-2.1 {external hierarchical method, two tokens} -body { + type dog { } + method dog {wag tail} {} { + return "$self wags tail." + } + + dog spot + spot wag tail +} -cleanup { + dog destroy +} -result {::spot wags tail.} + +test emethod-2.2 {external hierarchical method, three tokens} -body { + type dog { } + method dog {wag tail proudly} {} { + return "$self wags tail proudly." + } + + dog spot + spot wag tail proudly +} -cleanup { + dog destroy +} -result {::spot wags tail proudly.} + +test emethod-2.3 {external hierarchical method, three tokens} -body { + type dog { } + method dog {wag tail really high} {} { + return "$self wags tail really high." + } + + dog spot + spot wag tail really high +} -cleanup { + dog destroy +} -result {::spot wags tail really high.} + +test emethod-2.4 {redefinition is OK} -body { + type dog { } + method dog {wag tail} {} { + return "$self wags tail." + } + method dog {wag tail} {} { + return "$self wags tail briskly." + } + + dog spot + spot wag tail +} -cleanup { + dog destroy +} -result {::spot wags tail briskly.} + +test emethod-3.1 {prefix/method collision} -body { + type dog { + method wag {} {} + } + + method dog {wag tail} {} { + return "$self wags tail." + } +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {Cannot define "wag tail", "wag" has no submethods.} + +test emethod-3.2 {prefix/method collision} -body { + type dog { + method {wag tail} {} { + return "$self wags tail." + } + } + + method dog wag {} {} +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {Cannot define "wag", "wag" has submethods.} + +test emethod-3.3 {prefix/method collision} -body { + type dog { + method {wag tail} {} {} + } + + method dog {wag tail proudly} {} { + return "$self wags tail." + } +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {Cannot define "wag tail proudly", "wag tail" has no submethods.} + +test emethod-3.4 {prefix/method collision} -body { + type dog { + method {wag tail proudly} {} { + return "$self wags tail." + } + } + + method dog {wag tail} {} {} +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {Cannot define "wag tail", "wag tail" has submethods.} + + +#----------------------------------------------------------------------- +# Macros + +test macro-1.1 {can't redefine non-macros} -body { + snit::macro method {} {} +} -returnCodes { + error +} -result {invalid macro name "method"} + +test macro-1.2 {can define and use a macro} -body { + snit::macro hello {name} { + method hello {} "return {Hello, $name!}" + } + + type dog { + hello World + } + + dog spot + + spot hello + +} -cleanup { + dog destroy +} -result {Hello, World!} + +test macro-1.3 {can redefine macro} -body { + snit::macro dup {} {} + snit::macro dup {} {} + + set dummy "No error" +} -result {No error} + +test macro-1.4 {can define macro in namespace} -body { + snit::macro ::test::goodbye {name} { + method goodbye {} "return {Goodbye, $name!}" + } + + type dog { + ::test::goodbye World + } + + dog spot + + spot goodbye +} -cleanup { + dog destroy +} -result {Goodbye, World!} + +test macro-1.5 {_proc and _variable are defined} -body { + snit::macro testit {} { + set a [info commands _variable] + set b [info commands _proc] + method testit {} "list $a $b" + } + + type dog { + testit + } + + dog spot + + spot testit +} -cleanup { + dog destroy +} -result {_variable _proc} + +test macro-1.6 {_variable works} -body { + snit::macro test1 {} { + _variable myvar "_variable works" + } + + snit::macro test2 {} { + _variable myvar + + method testit {} "return {$myvar}" + } + + type dog { + test1 + test2 + } + + dog spot + + spot testit +} -cleanup { + dog destroy +} -result {_variable works} + +#----------------------------------------------------------------------- +# Component Statement + +test component-1.1 {component defines an instance variable} -body { + type dog { + component tail + } + + dog spot + + namespace tail [spot info vars tail] +} -cleanup { + dog destroy +} -result {tail} + +test component-1.2 {-public exposes the component} -body { + type tail { + method wag {} { + return "Wag, wag" + } + } + + type dog { + component tail -public mytail + + constructor {} { + set tail [tail %AUTO%] + } + } + + dog spot + + spot mytail wag +} -cleanup { + dog destroy + tail destroy +} -result {Wag, wag} + +test component-1.3 {-inherit requires a boolean value} -body { + type dog { + component animal -inherit foo + } +} -returnCodes { + error +} -result {component animal -inherit: expected boolean value, got "foo"} + +test component-1.4 {-inherit delegates unknown methods to the component} -body { + type animal { + method eat {} { + return "Eat, eat." + } + } + + type dog { + component animal -inherit yes + + constructor {} { + set animal [animal %AUTO%] + } + } + + dog spot + + spot eat +} -cleanup { + dog destroy + animal destroy +} -result {Eat, eat.} + +test component-1.5 {-inherit delegates unknown options to the component} -body { + type animal { + option -size medium + } + + type dog { + component animal -inherit yes + + constructor {} { + set animal [animal %AUTO%] + } + } + + dog spot + + spot cget -size +} -cleanup { + dog destroy + animal destroy +} -result {medium} + +#----------------------------------------------------------------------- +# Typevariables, Variables, Typecomponents, Components + +test typevar_var-1.1 {variable/typevariable collisions not allowed: order 1} -body { + type dog { + typevariable var + variable var + } +} -returnCodes { + error +} -result {Error in "variable var...", "var" is already a typevariable} + +test typevar_var-1.2 {variable/typevariable collisions not allowed: order 2} -body { + type dog { + variable var + typevariable var + } +} -returnCodes { + error +} -result {Error in "typevariable var...", "var" is already an instance variable} + +test typevar_var-1.3 {component/typecomponent collisions not allowed: order 1} -body { + type dog { + typecomponent comp + component comp + } +} -returnCodes { + error +} -result {Error in "component comp...", "comp" is already a typevariable} + +test typevar_var-1.4 {component/typecomponent collisions not allowed: order 2} -body { + type dog { + component comp + typecomponent comp + } +} -returnCodes { + error +} -result {Error in "typecomponent comp...", "comp" is already an instance variable} + +test typevar_var-1.5 {can't delegate options to typecomponents} -body { + type dog { + typecomponent comp + + delegate option -opt to comp + } +} -returnCodes { + error +} -result {Error in "delegate option -opt...", "comp" is already a typevariable} + +test typevar_var-1.6 {can't delegate typemethods to instance components} -body { + type dog { + component comp + + delegate typemethod foo to comp + } +} -returnCodes { + error +} -result {Error in "delegate typemethod foo...", "comp" is already an instance variable} + +test typevar_var-1.7 {can delegate methods to typecomponents} -body { + proc echo {args} {return [join $args "|"]} + + type dog { + typecomponent tail + + typeconstructor { + set tail echo + } + + delegate method wag to tail + } + + dog spot + spot wag briskly +} -cleanup { + dog destroy + rename echo "" +} -result {wag|briskly} + +#----------------------------------------------------------------------- +# Option syntax tests. +# +# This set of tests verifies that the option statement is interpreted +# properly, that errors are caught, and that the type's optionInfo +# array is initialized properly. +# +# TBD: At some point, this needs to be folded into the regular +# option tests. + +test optionsyntax-1.1 {local option names are saved} -body { + type dog { + option -foo + option -bar + } + + set ::dog::Snit_optionInfo(local) +} -cleanup { + dog destroy +} -result {-foo -bar} + +test optionsyntax-1.2 {islocal flag is set} -body { + type dog { + option -foo + } + + set ::dog::Snit_optionInfo(islocal--foo) +} -cleanup { + dog destroy +} -result {1} + +test optionsyntax-2.1 {implicit resource and class} -body { + type dog { + option -foo + } + + list \ + $::dog::Snit_optionInfo(resource--foo) \ + $::dog::Snit_optionInfo(class--foo) +} -cleanup { + dog destroy +} -result {foo Foo} + +test optionsyntax-2.2 {explicit resource, default class} -body { + type dog { + option {-foo ffoo} + } + + list \ + $::dog::Snit_optionInfo(resource--foo) \ + $::dog::Snit_optionInfo(class--foo) +} -cleanup { + dog destroy +} -result {ffoo Ffoo} + +test optionsyntax-2.3 {explicit resource and class} -body { + type dog { + option {-foo ffoo FFoo} + } + + list \ + $::dog::Snit_optionInfo(resource--foo) \ + $::dog::Snit_optionInfo(class--foo) +} -cleanup { + dog destroy +} -result {ffoo FFoo} + +test optionsyntax-2.4 {can't redefine explicit resource} -body { + type dog { + option {-foo ffoo} + option {-foo foo} + } +} -returnCodes { + error +} -result {Error in "option {-foo foo}...", resource name redefined from "ffoo" to "foo"} + +test optionsyntax-2.5 {can't redefine explicit class} -body { + type dog { + option {-foo ffoo Ffoo} + option {-foo ffoo FFoo} + } +} -returnCodes { + error +} -result {Error in "option {-foo ffoo FFoo}...", class name redefined from "Ffoo" to "FFoo"} + +test optionsyntax-2.6 {can redefine implicit resource and class} -body { + type dog { + option -foo + option {-foo ffoo} + option {-foo ffoo FFoo} + option -foo + } +} -cleanup { + dog destroy +} -result {::dog} + +test optionsyntax-3.1 {no default value} -body { + type dog { + option -foo + } + + set ::dog::Snit_optionInfo(default--foo) +} -cleanup { + dog destroy +} -result {} + +test optionsyntax-3.2 {default value, old syntax} -body { + type dog { + option -foo bar + } + + set ::dog::Snit_optionInfo(default--foo) +} -cleanup { + dog destroy +} -result {bar} + +test optionsyntax-3.3 {option definition options can be set} -body { + type dog { + option -foo \ + -default Bar \ + -validatemethod Validate \ + -configuremethod Configure \ + -cgetmethod Cget \ + -readonly 1 + } + + list \ + $::dog::Snit_optionInfo(default--foo) \ + $::dog::Snit_optionInfo(validate--foo) \ + $::dog::Snit_optionInfo(configure--foo) \ + $::dog::Snit_optionInfo(cget--foo) \ + $::dog::Snit_optionInfo(readonly--foo) +} -cleanup { + dog destroy +} -result {Bar Validate Configure Cget 1} + +test optionsyntax-3.4 {option definition option values accumulate} -body { + type dog { + option -foo -default Bar + option -foo -validatemethod Validate + option -foo -configuremethod Configure + option -foo -cgetmethod Cget + option -foo -readonly 1 + } + + list \ + $::dog::Snit_optionInfo(default--foo) \ + $::dog::Snit_optionInfo(validate--foo) \ + $::dog::Snit_optionInfo(configure--foo) \ + $::dog::Snit_optionInfo(cget--foo) \ + $::dog::Snit_optionInfo(readonly--foo) +} -cleanup { + dog destroy +} -result {Bar Validate Configure Cget 1} + +test optionsyntax-3.5 {option definition option values can be redefined} -body { + type dog { + option -foo -default Bar + option -foo -validatemethod Validate + option -foo -configuremethod Configure + option -foo -cgetmethod Cget + option -foo -readonly 1 + option -foo -default Bar2 + option -foo -validatemethod Validate2 + option -foo -configuremethod Configure2 + option -foo -cgetmethod Cget2 + option -foo -readonly 0 + } + + list \ + $::dog::Snit_optionInfo(default--foo) \ + $::dog::Snit_optionInfo(validate--foo) \ + $::dog::Snit_optionInfo(configure--foo) \ + $::dog::Snit_optionInfo(cget--foo) \ + $::dog::Snit_optionInfo(readonly--foo) +} -cleanup { + dog destroy +} -result {Bar2 Validate2 Configure2 Cget2 0} + +test optionsyntax-3.6 {option -readonly defaults to 0} -body { + type dog { + option -foo + } + + set ::dog::Snit_optionInfo(readonly--foo) +} -cleanup { + dog destroy +} -result {0} + +test optionsyntax-3.7 {option -readonly can be any boolean} -body { + type dog { + option -foo -readonly 0 + option -foo -readonly 1 + option -foo -readonly y + option -foo -readonly n + } +} -cleanup { + dog destroy +} -result {::dog} + +test optionsyntax-3.8 {option -readonly must be a boolean} -body { + type dog { + option -foo -readonly foo + } +} -returnCodes { + error +} -result {Error in "option -foo...", -readonly requires a boolean, got "foo"} + +test optionsyntax-3.9 {option -readonly can't be empty} -body { + type dog { + option -foo -readonly {} + } +} -returnCodes { + error +} -result {Error in "option -foo...", -readonly requires a boolean, got ""} + +#----------------------------------------------------------------------- +# 'delegate option' Syntax tests. +# +# This set of tests verifies that the 'delegation option' statement is +# interpreted properly, and that the type's optionInfo +# array is initialized properly. +# +# TBD: At some point, this needs to be folded into the regular +# option tests. + +test delegateoptionsyntax-1.1 {'delegated' lists delegated option names} -body { + type dog { + delegate option -foo to comp + delegate option -bar to comp + } + + set ::dog::Snit_optionInfo(delegated) +} -cleanup { + dog destroy +} -result {-foo -bar} + +test delegateoptionsyntax-1.2 {'delegated' does not include '*'} -body { + type dog { + delegate option * to comp + } + + set ::dog::Snit_optionInfo(delegated) +} -cleanup { + dog destroy +} -result {} + +test delegateoptionsyntax-1.3 {'islocal' is set to 0} -body { + type dog { + delegate option -foo to comp + } + + set ::dog::Snit_optionInfo(islocal--foo) +} -cleanup { + dog destroy +} -result {0} + +test delegateoptionsyntax-1.4 {'islocal' is not set for '*'} -body { + type dog { + delegate option * to comp + } + + info exists ::dog::Snit_optionInfo(islocal-*) +} -cleanup { + dog destroy +} -result {0} + +test delegateoptionsyntax-1.5 {'delegated-$comp' lists options for the component} -body { + type dog { + delegate option -foo to comp1 + delegate option -bar to comp1 + delegate option -baz to comp2 + + # The * won't show up. + delegate option * to comp2 + } + + list \ + $::dog::Snit_optionInfo(delegated-comp1) \ + $::dog::Snit_optionInfo(delegated-comp2) +} -cleanup { + dog destroy +} -result {{-foo -bar} -baz} + +test delegateoptionsyntax-1.6 {'except' is empty by default} -body { + type dog { + delegate option -foo to comp + } + + set ::dog::Snit_optionInfo(except) +} -cleanup { + dog destroy +} -result {} + +test delegateoptionsyntax-1.7 {'except' lists exceptions} -body { + type dog { + delegate option * to comp except {-foo -bar -baz} + } + + set ::dog::Snit_optionInfo(except) +} -cleanup { + dog destroy +} -result {-foo -bar -baz} + +test delegateoptionsyntax-1.8 {'target-$opt' set with default} -body { + type dog { + delegate option -foo to comp + } + + set ::dog::Snit_optionInfo(target--foo) +} -cleanup { + dog destroy +} -result {comp -foo} + +test delegateoptionsyntax-1.9 {'target-$opt' set explicitly} -body { + type dog { + delegate option -foo to comp as -bar + } + + set ::dog::Snit_optionInfo(target--foo) +} -cleanup { + dog destroy +} -result {comp -bar} + +test delegateoptionsyntax-1.10 {'starcomp' is {} by default} -body { + type dog { + delegate option -foo to comp + } + + set ::dog::Snit_optionInfo(starcomp) +} -cleanup { + dog destroy +} -result {} + +test delegateoptionsyntax-1.11 {'starcomp' set for *} -body { + type dog { + delegate option * to comp + } + + set ::dog::Snit_optionInfo(starcomp) +} -cleanup { + dog destroy +} -result {comp} + +test delegatedoptionsyntax-2.1 {implicit resource and class} -body { + type dog { + delegate option -foo to comp + } + + list \ + $::dog::Snit_optionInfo(resource--foo) \ + $::dog::Snit_optionInfo(class--foo) +} -cleanup { + dog destroy +} -result {foo Foo} + +test delegatedoptionsyntax-2.2 {explicit resource, default class} -body { + type dog { + delegate option {-foo ffoo} to comp + } + + list \ + $::dog::Snit_optionInfo(resource--foo) \ + $::dog::Snit_optionInfo(class--foo) +} -cleanup { + dog destroy +} -result {ffoo Ffoo} + +test delegatedoptionsyntax-2.3 {explicit resource and class} -body { + type dog { + delegate option {-foo ffoo FFoo} to comp + } + + list \ + $::dog::Snit_optionInfo(resource--foo) \ + $::dog::Snit_optionInfo(class--foo) +} -cleanup { + dog destroy +} -result {ffoo FFoo} + +test delegatedoptionsyntax-2.4 {* doesn't get resource and class} -body { + type dog { + delegate option * to comp + } + + list \ + [info exist ::dog::Snit_optionInfo(resource-*)] \ + [info exist ::dog::Snit_optionInfo(class-*)] +} -cleanup { + dog destroy +} -result {0 0} + +#----------------------------------------------------------------------- +# Cget cache + +test cgetcache-1.1 {Instance rename invalidates cache} -body { + type dog { + option -foo -default bar -cgetmethod getfoo + + method getfoo {option} { + return $options($option) + } + } + + dog fido -foo quux + + # Cache the cget command. + fido cget -foo + + rename fido spot + + spot cget -foo +} -cleanup { + dog destroy +} -result {quux} + +test cgetcache-1.2 {Component rename invalidates cache} -body { + type tail { + option -foo bar + } + + type dog { + delegate option -foo to tail + + constructor {args} { + set tail [tail %AUTO%] + $tail configure -foo quux + } + + method retail {} { + set tail [tail %AUTO%] + } + } + + dog fido + + # Cache the cget command. + fido cget -foo + + # Invalidate the cache + fido retail + + fido cget -foo +} -cleanup { + dog destroy + tail destroy +} -result {bar} + +# case 1 +test cgetcache-1.3 {Invalid -cgetmethod causes error} -constraints { + snit1 +} -body { + type dog { + option -foo -default bar -cgetmethod bogus + } + + dog fido -foo quux + + fido cget -foo +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {can't cget -foo, "::fido bogus" is not defined} + +# case 2 +test cgetcache-1.4 {Invalid -cgetmethod causes error} -constraints { + snit2 +} -body { + type dog { + option -foo -default bar -cgetmethod bogus + } + + dog fido -foo quux + + fido cget -foo +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {unknown subcommand "bogus": must be cget, or configurelist} + +test cgetcache-1.5 {hierarchical -cgetmethod} -body { + type dog { + option -foo -default bar -cgetmethod {Get Opt} + + method {Get Opt} {option} { + return Dummy + } + } + + dog fido + + fido cget -foo +} -cleanup { + dog destroy +} -result {Dummy} + +#----------------------------------------------------------------------- +# Configure cache + +test configurecache-1.1 {Instance rename invalidates cache} -body { + type dog { + option -foo -default bar -configuremethod setfoo + + method setfoo {option value} { + $self setoption $option $value + } + + method setoption {option value} { + set options($option) $value + } + } + + # Set the option on creation; this will cache the + # configure command. + dog fido -foo quux + + rename fido spot + + spot configure -foo baz + spot cget -foo +} -cleanup { + dog destroy +} -result {baz} + +test configurecache-1.2 {Component rename invalidates cache} -body { + type tail { + option -foo bar + } + + type dog { + delegate option -foo to tail + + constructor {args} { + set tail [tail thistail] + $self configurelist $args + } + + method retail {} { + # Give it a new component + set tail [tail thattail] + } + } + + # Set the tail's -foo, and cache the command. + dog fido -foo quux + + # Invalidate the cache + fido retail + + # Should recache, and set the new tail's option. + fido configure -foo baz + + fido cget -foo +} -cleanup { + dog destroy + tail destroy +} -result {baz} + +# Case 1 +test configurecache-1.3 {Invalid -configuremethod causes error} -constraints { + snit1 +} -body { + type dog { + option -foo -default bar -configuremethod bogus + } + + dog fido + fido configure -foo quux +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {can't configure -foo, "::fido bogus" is not defined} + +# Case 2 +test configurecache-1.4 {Invalid -configuremethod causes error} -constraints { + snit2 +} -body { + type dog { + option -foo -default bar -configuremethod bogus + } + + dog fido + fido configure -foo quux +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {unknown subcommand "bogus": must be configure, or configurelist} + +test configurecache-1.5 {hierarchical -configuremethod} -body { + type dog { + option -foo -default bar -configuremethod {Set Opt} + + method {Set Opt} {option value} { + set options($option) Dummy + } + } + + dog fido -foo NotDummy + fido cget -foo +} -cleanup { + dog destroy +} -result {Dummy} + + + +#----------------------------------------------------------------------- +# option -validatemethod + +test validatemethod-1.1 {Validate method is called} -body { + type dog { + variable flag 0 + + option -color \ + -default black \ + -validatemethod ValidateColor + + method ValidateColor {option value} { + set flag 1 + } + + method getflag {} { + return $flag + } + } + + dog fido -color brown + fido getflag +} -cleanup { + dog destroy +} -result {1} + +test validatemethod-1.2 {Validate method gets correct arguments} -body { + type dog { + option -color \ + -default black \ + -validatemethod ValidateColor + + method ValidateColor {option value} { + if {![string equal $option "-color"] || + ![string equal $value "brown"]} { + error "Expected '-color brown'" + } + } + } + + dog fido -color brown +} -cleanup { + dog destroy +} -result {::fido} + +# Case 1 +test validatemethod-1.3 {Invalid -validatemethod causes error} -constraints { + snit1 +} -body { + type dog { + option -foo -default bar -validatemethod bogus + } + + dog fido + fido configure -foo quux +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {can't validate -foo, "::fido bogus" is not defined} + +# Case 2 +test validatemethod-1.4 {Invalid -validatemethod causes error} -constraints { + snit2 +} -body { + type dog { + option -foo -default bar -validatemethod bogus + } + + dog fido + fido configure -foo quux +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {unknown subcommand "bogus": must be configure, or configurelist} + +test validatemethod-1.5 {hierarchical -validatemethod} -body { + type dog { + option -foo -default bar -validatemethod {Val Opt} + + method {Val Opt} {option value} { + error "Dummy" + } + } + + dog fido -foo value +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {Error in constructor: Dummy} + + + +#----------------------------------------------------------------------- +# option -readonly semantics + +test optionreadonly-1.1 {Readonly options can be set at creation time} -body { + type dog { + option -color \ + -default black \ + -readonly true + } + + dog fido -color brown + + fido cget -color +} -cleanup { + dog destroy +} -result {brown} + +test optionreadonly-1.2 {Readonly options can't be set after creation} -body { + type dog { + option -color \ + -default black \ + -readonly true + } + + dog fido + + fido configure -color brown +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {option -color can only be set at instance creation} + +test optionreadonly-1.3 {Readonly options can't be set after creation} -body { + type dog { + option -color \ + -default black \ + -readonly true + } + + dog fido -color yellow + + fido configure -color brown +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {option -color can only be set at instance creation} + +#----------------------------------------------------------------------- +# Pragma -hastypeinfo + +test hastypeinfo-1.1 {$type info is defined by default} -body { + type dog { + typevariable foo + } + + dog info typevars +} -cleanup { + dog destroy +} -result {::dog::foo} + +# Case 1 +test hastypeinfo-1.2 {$type info can be disabled} -constraints { + snit1 +} -body { + type dog { + pragma -hastypeinfo no + typevariable foo + } + + dog info typevars +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {"::dog info" is not defined} + +# Case 2 +test hastypeinfo-1.3 {$type info can be disabled} -constraints { + snit2 +} -body { + type dog { + pragma -hastypeinfo no + typevariable foo + } + + dog info typevars +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {unknown subcommand "info": namespace ::dog does not export any commands} + + +#----------------------------------------------------------------------- +# Pragma -hastypedestroy + +test hastypedestroy-1.1 {$type destroy is defined by default} -body { + type dog { + typevariable foo + } + + dog destroy + + ::dog info typevars +} -returnCodes { + error +} -result {invalid command name "::dog"} + +# Case 1 +test hastypedestroy-1.2 {$type destroy can be disabled} -constraints { + snit1 +} -body { + type dog { + pragma -hastypedestroy no + typevariable foo + } + + dog destroy +} -returnCodes { + error +} -cleanup { + rename ::dog "" + namespace delete ::dog +} -result {"::dog destroy" is not defined} + +# Case 2 +test hastypedestroy-1.3 {$type destroy can be disabled} -constraints { + snit2 +} -body { + type dog { + pragma -hastypedestroy no + typevariable foo + } + + dog destroy +} -returnCodes { + error +} -cleanup { + rename ::dog "" + namespace delete ::dog +} -result {unknown subcommand "destroy": namespace ::dog does not export any commands} + +#----------------------------------------------------------------------- +# Pragma -hasinstances + +test hasinstances-1.1 {-hasinstances is true by default} -body { + type dog { + method bark {} { + return "Woof" + } + } + + dog fido + fido bark +} -cleanup { + dog destroy +} -result {Woof} + +# Case 1 +test hasinstances-1.2 {'-hasinstances no' disables explicit object creation} -constraints { + snit1 +} -body { + type dog { + pragma -hasinstances no + } + + dog create fido +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {"::dog create" is not defined} + +# Case 2 +test hasinstances-1.3 {'-hasinstances no' disables explicit object creation} -constraints { + snit2 +} -body { + type dog { + pragma -hasinstances no + } + + dog create fido +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {unknown subcommand "create": namespace ::dog does not export any commands} + +# Case 1 +test hasinstances-1.4 {'-hasinstances no' disables implicit object creation} -constraints { + snit1 +} -body { + type dog { + pragma -hasinstances no + } + + dog fido +} -returnCodes { + error +} -result {"::dog fido" is not defined} + +# Case 2 +test hasinstances-1.5 {'-hasinstances no' disables implicit object creation} -constraints { + snit2 +} -body { + type dog { + pragma -hasinstances no + } + + dog fido +} -returnCodes { + error +} -result {unknown subcommand "fido": namespace ::dog does not export any commands} + +#----------------------------------------------------------------------- +# pragma -canreplace + +test canreplace-1.1 {By default, "-canreplace no"} -body { + type dog { + # ... + } + + dog fido + dog fido +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {command "::fido" already exists} + +test canreplace-1.2 {Can replace commands when "-canreplace yes"} -constraints { + bug8.5a3 +} -body { + type dog { + pragma -canreplace yes + } + + dog fido + dog fido +} -cleanup { + dog destroy +} -result {::fido} + +#----------------------------------------------------------------------- +# pragma -hasinfo + +test hasinfo-1.1 {$obj info is defined by default} -body { + type dog { + variable foo "" + } + + dog spot + spot info vars +} -cleanup { + dog destroy +} -result {::dog::Snit_inst1::foo} + +# Case 1 +test hasinfo-1.2 {$obj info can be disabled} -constraints { + snit1 +} -body { + type dog { + pragma -hasinfo no + variable foo + } + + dog spot + spot info vars +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {"::spot info" is not defined} + +# Case 2 +test hasinfo-1.3 {$obj info can be disabled} -constraints { + snit2 +} -body { + type dog { + pragma -hasinfo no + variable foo + } + + dog spot + spot info vars +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {unknown subcommand "info": namespace ::dog::Snit_inst1 does not export any commands} + +#----------------------------------------------------------------------- +# pragma -hastypemethods +# +# The "-hastypemethods yes" case is tested by the bulk of this file. +# We'll test the "-hastypemethods no" case here. + +test hastypemethods-1.1 {-hastypemethods no, $type foo creates instance.} -body { + type dog { + pragma -hastypemethods no + variable foo + } + + dog spot +} -cleanup { + spot destroy + rename ::dog "" + namespace delete ::dog +} -result {::spot} + +test hastypemethods-1.2 {-hastypemethods no, $type create foo fails.} -body { + type dog { + pragma -hastypemethods no + variable foo + } + + dog create spot +} -returnCodes { + error +} -cleanup { + rename ::dog "" + namespace delete ::dog +} -result "Error in constructor: [tcltest::tooManyArgs ::dog::Snit_constructor {type selfns win self}]" + +test hastypemethods-1.3 {-hastypemethods no, $type info fails.} -body { + type dog { + pragma -hastypemethods no + variable foo + } + + dog info +} -returnCodes { + error +} -cleanup { + rename ::dog "" + namespace delete ::dog +} -result {command "::info" already exists} + +test hastypemethods-1.4 {-hastypemethods no, [$widget] fails.} -constraints { + tk +} -body { + widget dog { + pragma -hastypemethods no + variable foo + } + + dog +} -returnCodes { + error +} -cleanup { + rename ::dog "" + namespace delete ::dog +} -result {wrong # args: should be "::dog name args"} + +test hastypemethods-1.5 {-hastypemethods no, -hasinstances no fails.} -body { + type dog { + pragma -hastypemethods no + pragma -hasinstances no + variable foo + } +} -returnCodes { + error +} -result {type ::dog has neither typemethods nor instances} + +#----------------------------------------------------------------------- +# -simpledispatch yes + +test simpledispatch-1.1 {not allowed with method delegation.} -constraints { + snit1 +} -body { + type dog { + pragma -simpledispatch yes + + delegate method foo to bar + } +} -returnCodes { + error +} -result {type ::dog requests -simpledispatch but delegates methods.} + +test simpledispatch-1.2 {normal methods work with simpledispatch.} -constraints { + snit1 +} -body { + type dog { + pragma -simpledispatch yes + + method barks {how} { + return "$self barks $how." + } + } + + dog spot + spot barks loudly +} -cleanup { + dog destroy +} -result {::spot barks loudly.} + +test simpledispatch-1.3 {option methods work with simpledispatch.} -constraints { + snit1 +} -body { + type dog { + pragma -simpledispatch yes + + option -breed mutt + } + + dog spot + set a [spot cget -breed] + spot configure -breed collie + set b [spot cget -breed] + spot configurelist [list -breed sheltie] + set c [spot cget -breed] + + list $a $b $c +} -cleanup { + dog destroy +} -result {mutt collie sheltie} + +test simpledispatch-1.4 {info method works with simpledispatch.} -constraints { + snit1 +} -body { + type dog { + pragma -simpledispatch yes + + option -breed mutt + } + + dog spot + + spot info options +} -cleanup { + dog destroy +} -result {-breed} + +test simpledispatch-1.5 {destroy method works with simpledispatch.} -constraints { + snit1 +} -body { + type dog { + pragma -simpledispatch yes + + option -breed mutt + } + + dog spot + set a [info commands ::spot] + spot destroy + set b [info commands ::spot] + list $a $b +} -cleanup { + dog destroy +} -result {::spot {}} + +test simpledispatch-1.6 {no hierarchical methods with simpledispatch.} -constraints { + snit1 +} -body { + type dog { + pragma -simpledispatch yes + + method {wag tail} {} {} + } +} -returnCodes { + error +} -result {type ::dog requests -simpledispatch but defines hierarchical methods.} + +#----------------------------------------------------------------------- +# Exotic return codes + +test break-1.1 {Methods can "return -code break"} -body { + snit::type dog { + method bark {} {return -code break "Breaking"} + } + + dog spot + + catch {spot bark} result +} -cleanup { + dog destroy +} -result {3} + +test break-1.2 {Typemethods can "return -code break"} -body { + snit::type dog { + typemethod bark {} {return -code break "Breaking"} + } + + catch {dog bark} result +} -cleanup { + dog destroy +} -result {3} + +test break-1.3 {Methods called via mymethod "return -code break"} -body { + snit::type dog { + method bark {} {return -code break "Breaking"} + + method getbark {} { + return [mymethod bark] + } + } + + dog spot + + catch {uplevel \#0 [spot getbark]} result +} -cleanup { + dog destroy +} -result {3} + +#----------------------------------------------------------------------- +# Namespace path + +test nspath-1.1 {Typemethods call commands from parent namespace} -constraints { + snit2 +} -body { + namespace eval ::snit_test:: { + proc bark {} {return "[namespace current]: Woof"} + } + + snit::type ::snit_test::dog { + typemethod bark {} { + bark + } + } + + ::snit_test::dog bark +} -cleanup { + ::snit_test::dog destroy + namespace forget ::snit_test +} -result {::snit_test: Woof} + +test nspath-1.2 {Methods can call commands from parent namespace} -constraints { + snit2 +} -body { + namespace eval ::snit_test:: { + proc bark {} {return "[namespace current]: Woof"} + } + + snit::type ::snit_test::dog { + method bark {} { + bark + } + } + + ::snit_test::dog spot + spot bark +} -cleanup { + ::snit_test::dog destroy + namespace forget ::snit_test +} -result {::snit_test: Woof} + +#----------------------------------------------------------------------- +# snit::boolean + +test boolean-1.1 {boolean: valid} -body { + snit::boolean validate 1 + snit::boolean validate 0 + snit::boolean validate true + snit::boolean validate false + snit::boolean validate yes + snit::boolean validate no + snit::boolean validate on + snit::boolean validate off +} -result {off} + +test boolean-1.2 {boolean: invalid} -body { + codecatch {snit::boolean validate quux} +} -result {INVALID invalid boolean "quux", should be one of: 1, 0, true, false, yes, no, on, off} + +test boolean-2.1 {boolean subtype: valid} -body { + snit::boolean subtype + subtype validate 1 + subtype validate 0 + subtype validate true + subtype validate false + subtype validate yes + subtype validate no + subtype validate on + subtype validate off +} -cleanup { + subtype destroy +} -result {off} + +test boolean-2.2 {boolean subtype: invalid} -body { + snit::boolean subtype + codecatch {subtype validate quux} +} -cleanup { + subtype destroy +} -result {INVALID invalid boolean "quux", should be one of: 1, 0, true, false, yes, no, on, off} + +#----------------------------------------------------------------------- +# snit::double + +test double-1.1 {double: invalid -min} -body { + snit::double obj -min abc +} -returnCodes { + error +} -result {Error in constructor: invalid -min: "abc"} + +test double-1.2 {double: invalid -max} -body { + snit::double obj -max abc +} -returnCodes { + error +} -result {Error in constructor: invalid -max: "abc"} + +test double-1.3 {double: invalid, max < min} -body { + snit::double obj -min 5 -max 0 +} -returnCodes { + error +} -result {Error in constructor: -max < -min} + +test double-2.1 {double type: valid} -body { + snit::double validate 1.5 +} -result {1.5} + +test double-2.2 {double type: invalid} -body { + codecatch {snit::double validate abc} +} -result {INVALID invalid value "abc", expected double} + +test double-3.1 {double subtype: valid, no range} -body { + snit::double subtype + subtype validate 1.5 +} -cleanup { + subtype destroy +} -result {1.5} + +test double-3.2 {double subtype: valid, min but no max} -body { + snit::double subtype -min 0.5 + subtype validate 1 +} -cleanup { + subtype destroy +} -result {1} + +test double-3.3 {double subtype: valid, min and max} -body { + snit::double subtype -min 0.5 -max 10.5 + subtype validate 1.5 +} -cleanup { + subtype destroy +} -result {1.5} + +test double-4.1 {double subtype: not a number} -body { + snit::double subtype + codecatch {subtype validate quux} +} -cleanup { + subtype destroy +} -result {INVALID invalid value "quux", expected double} + +test double-4.2 {double subtype: less than min, no max} -body { + snit::double subtype -min 0.5 + codecatch {subtype validate -1} +} -cleanup { + subtype destroy +} -result {INVALID invalid value "-1", expected double no less than 0.5} + +test double-4.3 {double subtype: less than min, with max} -body { + snit::double subtype -min 0.5 -max 5.5 + codecatch {subtype validate -1} +} -cleanup { + subtype destroy +} -result {INVALID invalid value "-1", expected double in range 0.5, 5.5} + +test double-4.4 {double subtype: greater than max, no min} -body { + snit::double subtype -max 0.5 + codecatch {subtype validate 1} +} -cleanup { + subtype destroy +} -result {INVALID invalid value "1", expected double no greater than 0.5} + +#----------------------------------------------------------------------- +# snit::enum + +test enum-1.1 {enum: valid} -body { + snit::enum validate foo +} -result {foo} + +test enum-2.1 {enum subtype: missing -values} -body { + snit::enum subtype +} -returnCodes { + error +} -result {Error in constructor: invalid -values: ""} + +test enum-3.1 {enum subtype: valid} -body { + snit::enum subtype -values {foo bar baz} + subtype validate foo + subtype validate bar + subtype validate baz +} -cleanup { + subtype destroy +} -result {baz} + +test enum-3.2 {enum subtype: invalid} -body { + snit::enum subtype -values {foo bar baz} + codecatch {subtype validate quux} +} -cleanup { + subtype destroy +} -result {INVALID invalid value "quux", should be one of: foo, bar, baz} + + +#----------------------------------------------------------------------- +# snit::fpixels + +test fpixels-1.1 {no suffix} -constraints tk -body { + snit::fpixels validate 5 +} -result {5} + +test fpixels-1.2 {suffix} -constraints tk -body { + snit::fpixels validate 5i +} -result {5i} + +test fpixels-1.3 {decimal} -constraints tk -body { + snit::fpixels validate 5.5 +} -result {5.5} + +test fpixels-1.4 {invalid} -constraints tk -body { + codecatch {snit::fpixels validate 5.5abc} +} -result {INVALID invalid value "5.5abc", expected fpixels} + +test fpixels-2.1 {bad -min} -constraints tk -body { + snit::fpixels subtype -min abc +} -returnCodes { + error +} -result {Error in constructor: invalid -min: "abc"} + +test fpixels-2.2 {bad -max} -constraints tk -body { + snit::fpixels subtype -max abc +} -returnCodes { + error +} -result {Error in constructor: invalid -max: "abc"} + +test fpixels-2.3 {-min > -max} -constraints tk -body { + snit::fpixels subtype -min 10 -max 5 +} -returnCodes { + error +} -result {Error in constructor: -max < -min} + +test fpixels-3.1 {subtype, no suffix} -constraints tk -body { + snit::fpixels subtype + subtype validate 5 +} -cleanup { + subtype destroy +} -result {5} + +test fpixels-3.2 {suffix} -constraints tk -body { + snit::fpixels subtype + subtype validate 5i +} -cleanup { + subtype destroy +} -result {5i} + +test fpixels-3.3 {decimal} -constraints tk -body { + snit::fpixels subtype + subtype validate 5.5 +} -cleanup { + subtype destroy +} -result {5.5} + +test fpixels-3.4 {invalid} -constraints tk -body { + snit::fpixels subtype + codecatch {subtype validate 5.5abc} +} -cleanup { + subtype destroy +} -result {INVALID invalid value "5.5abc", expected fpixels} + + +test fpixels-3.5 {subtype -min} -constraints tk -body { + snit::fpixels subtype -min 5 + subtype validate 10 +} -cleanup { + subtype destroy +} -result {10} + +test fpixels-3.6 {min of min, max} -constraints tk -body { + snit::fpixels subtype -min 5 -max 20 + subtype validate 5 +} -cleanup { + subtype destroy +} -result {5} + +test fpixels-3.7 {max of min, max} -constraints tk -body { + snit::fpixels subtype -min 5 -max 20 + subtype validate 20 +} -cleanup { + subtype destroy +} -result {20} + +test fpixels-3.8 {middle of min, max} -constraints tk -body { + snit::fpixels subtype -min 5 -max 20 + subtype validate 15 +} -cleanup { + subtype destroy +} -result {15} + +test fpixels-3.9 {invalid, < min} -constraints tk -body { + snit::fpixels subtype -min 5 + codecatch {subtype validate 4} +} -cleanup { + subtype destroy +} -result {INVALID invalid value "4", expected fpixels no less than 5} + +test fpixels-3.10 {invalid, > max} -constraints tk -body { + snit::fpixels subtype -min 5 -max 20 + codecatch {subtype validate 21} +} -cleanup { + subtype destroy +} -result {INVALID invalid value "21", expected fpixels in range 5, 20} + +test fpixels-3.11 {invalid, > max, range with suffix} -constraints tk -body { + snit::fpixels subtype -min 5i -max 10i + codecatch {subtype validate 11i} +} -cleanup { + subtype destroy +} -result {INVALID invalid value "11i", expected fpixels in range 5i, 10i} + +#----------------------------------------------------------------------- +# snit::integer + +test integer-1.1 {integer: invalid -min} -body { + snit::integer obj -min abc +} -returnCodes { + error +} -result {Error in constructor: invalid -min: "abc"} + +test integer-1.2 {integer: invalid -max} -body { + snit::integer obj -max abc +} -returnCodes { + error +} -result {Error in constructor: invalid -max: "abc"} + +test integer-1.3 {integer: invalid, max < min} -body { + snit::integer obj -min 5 -max 0 +} -returnCodes { + error +} -result {Error in constructor: -max < -min} + +test integer-2.1 {integer type: valid} -body { + snit::integer validate 1 +} -result {1} + +test integer-2.2 {integer type: invalid} -body { + codecatch {snit::integer validate abc} +} -result {INVALID invalid value "abc", expected integer} + +test integer-3.1 {integer subtype: valid, no range} -body { + snit::integer subtype + subtype validate 1 +} -cleanup { + subtype destroy +} -result {1} + +test integer-3.2 {integer subtype: valid, min but no max} -body { + snit::integer subtype -min 0 + subtype validate 1 +} -cleanup { + subtype destroy +} -result {1} + +test integer-3.3 {integer subtype: valid, min and max} -body { + snit::integer subtype -min 0 -max 10 + subtype validate 1 +} -cleanup { + subtype destroy +} -result {1} + +test integer-4.1 {integer subtype: not a number} -body { + snit::integer subtype + codecatch {subtype validate quux} +} -cleanup { + subtype destroy +} -result {INVALID invalid value "quux", expected integer} + +test integer-4.2 {integer subtype: less than min, no max} -body { + snit::integer subtype -min 0 + codecatch {subtype validate -1} +} -cleanup { + subtype destroy +} -result {INVALID invalid value "-1", expected integer no less than 0} + +test integer-4.3 {integer subtype: less than min, with max} -body { + snit::integer subtype -min 0 -max 5 + codecatch {subtype validate -1} +} -cleanup { + subtype destroy +} -result {INVALID invalid value "-1", expected integer in range 0, 5} + +#----------------------------------------------------------------------- +# snit::listtype + +test listtype-1.1 {listtype, length 0; valid} -body { + snit::listtype validate "" +} -result {} + +test listtype-1.2 {listtype, length 1; valid} -body { + snit::listtype validate a +} -result {a} + +test listtype-1.3 {listtype, length 2; valid} -body { + snit::listtype validate {a b} +} -result {a b} + +test listtype-2.1 {listtype subtype, length 0; valid} -body { + snit::listtype subtype + subtype validate "" +} -cleanup { + subtype destroy +} -result {} + +test listtype-2.2 {listtype, length 1; valid} -body { + snit::listtype subtype + subtype validate a +} -cleanup { + subtype destroy +} -result {a} + +test listtype-2.3 {listtype, length 2; valid} -body { + snit::listtype subtype + subtype validate {a b} +} -cleanup { + subtype destroy +} -result {a b} + +test listtype-2.4 {listtype, invalid -minlen} -body { + snit::listtype subtype -minlen abc +} -returnCodes { + error +} -result {Error in constructor: invalid -minlen: "abc"} + +test listtype-2.5 {listtype, negative -minlen} -body { + snit::listtype subtype -minlen -1 +} -returnCodes { + error +} -result {Error in constructor: invalid -minlen: "-1"} + +test listtype-2.6 {listtype, invalid -maxlen} -body { + snit::listtype subtype -maxlen abc +} -returnCodes { + error +} -result {Error in constructor: invalid -maxlen: "abc"} + +test listtype-2.7 {listtype, -maxlen < -minlen} -body { + snit::listtype subtype -minlen 10 -maxlen 9 +} -returnCodes { + error +} -result {Error in constructor: -maxlen < -minlen} + +test listtype-3.1 {-minlen 2, length 2; valid} -body { + snit::listtype subtype -minlen 2 + subtype validate {a b} +} -cleanup { + subtype destroy +} -result {a b} + +test listtype-3.2 {-minlen 2, length 3; valid} -body { + snit::listtype subtype -minlen 2 + subtype validate {a b c} +} -cleanup { + subtype destroy +} -result {a b c} + +test listtype-3.3 {-minlen 2, length 1; invalid} -body { + snit::listtype subtype -minlen 2 + codecatch {subtype validate a} +} -cleanup { + subtype destroy +} -result {INVALID value has too few elements; at least 2 expected} + +test listtype-3.4 {range 1 to 3, length 1; valid} -body { + snit::listtype subtype -minlen 1 -maxlen 3 + subtype validate a +} -cleanup { + subtype destroy +} -result {a} + +test listtype-3.5 {range 1 to 3, length 3; valid} -body { + snit::listtype subtype -minlen 1 -maxlen 3 + subtype validate {a b c} +} -cleanup { + subtype destroy +} -result {a b c} + +test listtype-3.6 {range 1 to 3, length 0; invalid} -body { + snit::listtype subtype -minlen 1 -maxlen 3 + codecatch {subtype validate {}} +} -cleanup { + subtype destroy +} -result {INVALID value has too few elements; at least 1 expected} + +test listtype-3.7 {range 1 to 3, length 4; invalid} -body { + snit::listtype subtype -minlen 1 -maxlen 3 + codecatch {subtype validate {a b c d}} +} -cleanup { + subtype destroy +} -result {INVALID value has too many elements; no more than 3 expected} + +test listtype-4.1 {boolean list, valid} -body { + snit::listtype subtype -type snit::boolean + subtype validate {yes 1 true} +} -cleanup { + subtype destroy +} -result {yes 1 true} + +test listtype-4.2 {boolean list, invalid} -body { + snit::listtype subtype -type snit::boolean + codecatch {subtype validate {yes 1 abc no}} +} -cleanup { + subtype destroy +} -result {INVALID invalid boolean "abc", should be one of: 1, 0, true, false, yes, no, on, off} + +#----------------------------------------------------------------------- +# snit::pixels + +test pixels-1.1 {no suffix} -constraints tk -body { + snit::pixels validate 5 +} -result {5} + +test pixels-1.2 {suffix} -constraints tk -body { + snit::pixels validate 5i +} -result {5i} + +test pixels-1.3 {decimal} -constraints tk -body { + snit::pixels validate 5.5 +} -result {5.5} + +test pixels-1.4 {invalid} -constraints tk -body { + codecatch {snit::pixels validate 5.5abc} +} -result {INVALID invalid value "5.5abc", expected pixels} + +test pixels-2.1 {bad -min} -constraints tk -body { + snit::pixels subtype -min abc +} -returnCodes { + error +} -result {Error in constructor: invalid -min: "abc"} + +test pixels-2.2 {bad -max} -constraints tk -body { + snit::pixels subtype -max abc +} -returnCodes { + error +} -result {Error in constructor: invalid -max: "abc"} + +test pixels-2.3 {-min > -max} -constraints tk -body { + snit::pixels subtype -min 10 -max 5 +} -returnCodes { + error +} -result {Error in constructor: -max < -min} + +test pixels-3.1 {subtype, no suffix} -constraints tk -body { + snit::pixels subtype + subtype validate 5 +} -cleanup { + subtype destroy +} -result {5} + +test pixels-3.2 {suffix} -constraints tk -body { + snit::pixels subtype + subtype validate 5i +} -cleanup { + subtype destroy +} -result {5i} + +test pixels-3.3 {decimal} -constraints tk -body { + snit::pixels subtype + subtype validate 5.5 +} -cleanup { + subtype destroy +} -result {5.5} + +test pixels-3.4 {invalid} -constraints tk -body { + snit::pixels subtype + codecatch {subtype validate 5.5abc} +} -cleanup { + subtype destroy +} -result {INVALID invalid value "5.5abc", expected pixels} + + +test pixels-3.5 {subtype -min} -constraints tk -body { + snit::pixels subtype -min 5 + subtype validate 10 +} -cleanup { + subtype destroy +} -result {10} + +test pixels-3.6 {min of min, max} -constraints tk -body { + snit::pixels subtype -min 5 -max 20 + subtype validate 5 +} -cleanup { + subtype destroy +} -result {5} + +test pixels-3.7 {max of min, max} -constraints tk -body { + snit::pixels subtype -min 5 -max 20 + subtype validate 20 +} -cleanup { + subtype destroy +} -result {20} + +test pixels-3.8 {middle of min, max} -constraints tk -body { + snit::pixels subtype -min 5 -max 20 + subtype validate 15 +} -cleanup { + subtype destroy +} -result {15} + +test pixels-3.9 {invalid, < min} -constraints tk -body { + snit::pixels subtype -min 5 + codecatch {subtype validate 4} +} -cleanup { + subtype destroy +} -result {INVALID invalid value "4", expected pixels no less than 5} + +test pixels-3.10 {invalid, > max} -constraints tk -body { + snit::pixels subtype -min 5 -max 20 + codecatch {subtype validate 21} +} -cleanup { + subtype destroy +} -result {INVALID invalid value "21", expected pixels in range 5, 20} + +test pixels-3.11 {invalid, > max, range with suffix} -constraints tk -body { + snit::pixels subtype -min 5i -max 10i + codecatch {subtype validate 11i} +} -cleanup { + subtype destroy +} -result {INVALID invalid value "11i", expected pixels in range 5i, 10i} + +#----------------------------------------------------------------------- +# snit::stringtype + +test stringtype-1.1 {stringtype, valid string} -body { + snit::stringtype validate "" +} -result {} + +test stringtype-2.1 {stringtype subtype: invalid -regexp} -body { + snit::stringtype subtype -regexp "\[A-Z" +} -returnCodes { + error +} -result {Error in constructor: invalid -regexp: "[A-Z"} + +test stringtype-2.2 {stringtype subtype: invalid -minlen} -body { + snit::stringtype subtype -minlen foo +} -returnCodes { + error +} -result {Error in constructor: invalid -minlen: "foo"} + +test stringtype-2.3 {stringtype subtype: invalid -maxlen} -body { + snit::stringtype subtype -maxlen foo +} -returnCodes { + error +} -result {Error in constructor: invalid -maxlen: "foo"} + +test stringtype-2.4 {stringtype subtype: -maxlen < -minlen} -body { + snit::stringtype subtype -maxlen 1 -minlen 5 +} -returnCodes { + error +} -result {Error in constructor: -maxlen < -minlen} + +test stringtype-2.5 {stringtype subtype: -minlen < 0} -body { + snit::stringtype subtype -minlen -1 +} -returnCodes { + error +} -result {Error in constructor: invalid -minlen: "-1"} + +test stringtype-2.6 {stringtype subtype: -maxlen < 0} -body { + snit::stringtype subtype -maxlen -1 +} -returnCodes { + error +} -result {Error in constructor: -maxlen < -minlen} + +test stringtype-3.1 {stringtype subtype: -glob, valid} -body { + snit::stringtype subtype -glob "*FOO*" + subtype validate 1FOO2 +} -cleanup { + subtype destroy +} -result {1FOO2} + +test stringtype-3.2 {stringtype subtype: -glob, case-insensitive} -body { + snit::stringtype subtype -nocase yes -glob "*FOO*" + subtype validate 1foo2 +} -cleanup { + subtype destroy +} -result {1foo2} + +test stringtype-3.3 {stringtype subtype: -glob invalid, case-sensitive} -body { + snit::stringtype subtype -glob "*FOO*" + codecatch {subtype validate 1foo2} +} -cleanup { + subtype destroy +} -result {INVALID invalid value "1foo2"} + +test stringtype-5.4 {stringtype subtype: -glob invalid, case-insensitive} -body { + snit::stringtype subtype -nocase yes -glob "*FOO*" + codecatch {subtype validate bar} +} -cleanup { + subtype destroy +} -result {INVALID invalid value "bar"} + +test stringtype-5.5 {stringtype subtype: -regexp valid, case-sensitive} -body { + snit::stringtype subtype -regexp {^[A-Z]+$} + subtype validate FOO +} -cleanup { + subtype destroy +} -result {FOO} + +test stringtype-5.6 {stringtype subtype: -regexp valid, case-insensitive} -body { + snit::stringtype subtype -nocase yes -regexp {^[A-Z]+$} + subtype validate foo +} -cleanup { + subtype destroy +} -result {foo} + +test stringtype-5.7 {stringtype subtype: -regexp invalid, case-sensitive} -body { + snit::stringtype subtype -regexp {^[A-Z]+$} + codecatch {subtype validate foo} +} -cleanup { + subtype destroy +} -result {INVALID invalid value "foo"} + +test stringtype-5.8 {stringtype subtype: -regexp invalid, case-insensitive} -body { + snit::stringtype subtype -nocase yes -regexp {^[A-Z]+$} + codecatch {subtype validate foo1} +} -cleanup { + subtype destroy +} -result {INVALID invalid value "foo1"} + +#----------------------------------------------------------------------- +# snit::window + +test window-1.1 {window: valid} -constraints tk -body { + snit::window validate . +} -result {.} + +test window-1.2 {window: invalid} -constraints tk -body { + codecatch {snit::window validate .nonesuch} +} -result {INVALID invalid value ".nonesuch", value is not a window} + +test window-2.1 {window subtype: valid} -constraints tk -body { + snit::window subtype + subtype validate . +} -cleanup { + subtype destroy +} -result {.} + +test window-2.2 {window subtype: invalid} -constraints tk -body { + snit::window subtype + codecatch {subtype validate .nonesuch} +} -cleanup { + subtype destroy +} -result {INVALID invalid value ".nonesuch", value is not a window} + +#----------------------------------------------------------------------- +# option -type specifications + +test optiontype-1.1 {-type is type object name} -body { + type dog { + option -akcflag -default no -type snit::boolean + } + + dog create spot + + # Set -akcflag to a boolean value + spot configure -akcflag yes + spot configure -akcflag 1 + spot configure -akcflag on + spot configure -akcflag off + + # Set -akcflag to an invalid value + spot configure -akcflag offf +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {invalid -akcflag value: invalid boolean "offf", should be one of: 1, 0, true, false, yes, no, on, off} + +test optiontype-1.2 {-type is type specification} -body { + type dog { + option -color -default brown \ + -type {snit::enum -values {brown black white golden}} + } + + dog create spot + + # Set -color to a valid value + spot configure -color brown + spot configure -color black + spot configure -color white + spot configure -color golden + + # Set -color to an invalid value + spot configure -color green +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {invalid -color value: invalid value "green", should be one of: brown, black, white, golden} + +test optiontype-1.3 {-type catches invalid defaults} -body { + type dog { + option -color -default green \ + -type {snit::enum -values {brown black white golden}} + } + + dog spot +} -returnCodes { + error +} -cleanup { + dog destroy +} -result {Error in constructor: invalid -color default: invalid value "green", should be one of: brown, black, white, golden} + + +#----------------------------------------------------------------------- +# Bug Fixes + +test bug-1.1 {Bug 1161779: destructor can't precede constructor} -body { + type dummy { + destructor { + # No content + } + + constructor {args} { + $self configurelist $args + } + + } +} -cleanup { + rename ::dummy "" +} -result ::dummy + +test bug-2.1 {Bug 1106375: Widget Error on failed object's construction} -constraints { + tk +} -body { + ::snit::widgetadaptor mylabel { + delegate method * to hull + delegate option * to hull + + constructor {args} { + installhull using label + error "simulated error" + } + } + + catch {mylabel .lab} result + list [info commands .lab] $result + +} -cleanup { + ::mylabel destroy +} -result {{} {Error in constructor: simulated error}} + +test bug-2.2 {Bug 1106375: Widget Error on failed object's construction} -constraints { + tk +} -body { + ::snit::widget myframe { + delegate method * to hull + delegate option * to hull + + constructor {args} { + error "simulated error" + } + } + + catch {myframe .frm} result + list [info commands .frm] $result + } -cleanup { + ::myframe destroy +} -result {{} {Error in constructor: simulated error}} + +test bug-3.1 {Bug 1532791: snit2, snit::widget problem} -constraints { + tk +} -body { + snit::widget mywidget { + delegate method * to mylabel + delegate option * to mylabel + + variable mylabel {} + } + + mywidget .mylabel +} -cleanup { + destroy .mylabel +} -result {.mylabel} + + +#--------------------------------------------------------------------- +# Clean up + +rename expect {} +testsuiteCleanup |