2 #---------------------------------------------------------------------
10 # Test cases for snit.tcl. Uses the ::tcltest:: harness.
12 # If Tcl is 8.5, Snit 2.0 is loaded.
13 # If Tcl is 8.4, Snit 1.2 is loaded.
14 # If Tcl is 8.3, Snit 1.2 is loaded. (Kenneth Green's backport).
16 # Tests back-ported to Tcl 8.3 for snit 1.2 backport by kmg
17 # Backport of test made general by Andreas Kupries.
19 # The tests assume tcltest 2.2
21 #-----------------------------------------------------------------------
22 # Back-port to Tcl8.3 by Kenneth Green (kmg)
25 # " eq " => "string equal"
26 # " ne " -> "!string equal"
27 #-----------------------------------------------------------------------
30 [file dirname [file dirname [file join [pwd] [info script]]]] \
31 devtools testutilities.tcl]
36 #---------------------------------------------------------------------
37 # Set up a number of constraints. This also determines which
38 # implementation of snit is loaded and tested.
40 # WHD: Work around bugs in 8.5a3
41 tcltest::testConstraint bug8.5a3 [expr {![string equal [info patchlevel] "8.5a3"]}]
43 # Marks tests which are only for Tk.
44 tcltest::testConstraint tk [info exists tk_version]
46 # If Tk is available, require BWidget
47 tcltest::testConstraint bwidget [expr {
48 [tcltest::testConstraint tk] &&
49 ![catch {package require BWidget}]
52 # Determine which Snit version to load. If Tcl 8.5, use 2.x.
53 # Otherwise, use 1.x. (Different variants depending on 8.3 vs 8.4)
54 if {[package vsatisfies [package present Tcl] 8.5]} {
56 set snitFile snit2.tcl
62 # Marks tests which are only for Snit 1
63 tcltest::testConstraint snit1 [expr {$snitVersion == 1}]
65 # Marks tests which are only for Snit 2
66 tcltest::testConstraint snit2 [expr {$snitVersion == 2}]
68 # Marks tests which are only for Snit 1 with Tcl 8.3
69 tcltest::testConstraint tcl83 [string equal [info tclversion] "8.3"]
70 tcltest::testConstraint tcl84 [package vsatisfies [package present Tcl] 8.4]
72 if {[package vsatisfies [package provide Tcl] 8.6]} {
74 proc expect {six default} { return $six }
77 proc expect {six default} { return $default }
80 #---------------------------------------------------------------------
81 # Load the snit package.
84 useLocal $snitFile snit
87 #---------------------------------------------------------------------
89 namespace import ::snit::*
91 # Set up for Tk tests: Repeat background errors
95 set ::bideErrorInfo $errorInfo
98 # Set up for Tk tests: enter the event loop long enough to catch
100 proc tkbide {{msg "tkbide"} {msec 500}} {
103 set ::bideErrorInfo ""
104 # It looks like update idletasks does the job.
106 after $msec {set ::bideVar 1}
107 tkwait variable ::bideVar
110 if {"" != $::bideError} {
111 error "$msg: $::bideError" $::bideErrorInfo
116 proc cleanupType {name} {
117 if {[namespace exists $name]} {
118 if {[catch {$name destroy} result]} {
121 error "Could not cleanup $name!"
124 tkbide "cleanupType $name"
127 # cleanup before each test
133 cleanupType ::mylabel
134 cleanupType ::myframe
140 cleanupType ::confused-dog
143 if {![string equal [info commands "spot"] ""]} {
144 puts "spot not erased!"
145 error "spot not erased!"
148 if {![string equal [info commands "fido"] ""]} {
149 puts "fido not erased!"
150 error "fido not erased!"
154 # catch error code and error
156 proc codecatch {command} {
157 if {![catch {uplevel 1 $command} result]} {
158 error "expected error, got OK"
161 return "$::errorCode $result"
165 #-----------------------------------------------------------------------
166 # Internals: tests for Snit utility functions
168 test Expand-1.1 {template, no arguments} -body {
169 snit::Expand "My %TEMPLATE%"
170 } -result {My %TEMPLATE%}
172 test Expand-1.2 {template, no matching arguments} -body {
173 snit::Expand "My %TEMPLATE%" %FOO% foo
174 } -result {My %TEMPLATE%}
176 test Expand-1.3 {template with matching arguments} -body {
177 snit::Expand "%FOO% %BAR% %FOO%" %FOO% bar %BAR% foo
178 } -result {bar foo bar}
180 test Expand-1.4 {template with odd number of arguments} -body {
181 snit::Expand "%FOO% %BAR% %FOO%" %FOO%
182 } -result {char map list unbalanced} -returnCodes error
184 test Mappend-1.1 {template, no arguments} -body {
186 snit::Mappend text "My %TEMPLATE%"
189 } -result {Prefix: My %TEMPLATE%}
191 test Mappend-1.2 {template, no matching arguments} -body {
193 snit::Mappend text "My %TEMPLATE%" %FOO% foo
196 } -result {Prefix: My %TEMPLATE%}
198 test Mappend-1.3 {template with matching arguments} -body {
200 snit::Mappend text "%FOO% %BAR% %FOO%" %FOO% bar %BAR% foo
203 } -result {Prefix: bar foo bar}
205 test Mappend-1.4 {template with odd number of arguments} -body {
207 snit::Mappend text "%FOO% %BAR% %FOO%" %FOO%
210 } -returnCodes error -result {char map list unbalanced}
212 test RT.UniqueName-1.1 {no name collision} -body {
215 # Standard qualified type name.
216 set n1 [snit::RT.UniqueName counter ::mytype ::my::%AUTO%]
218 # Standard qualified widget name.
219 set n2 [snit::RT.UniqueName counter ::mytype .my.%AUTO%]
222 } -result {::my::mytype1 .my.mytype2} -cleanup {
226 test RT.UniqueName-1.2 {name collision} -body {
229 # Create the first two equivalent procs.
233 # Create a new name; it should skip to 3.
234 snit::RT.UniqueName counter ::mytype ::%AUTO%
239 } -result {::mytype3}
241 test RT.UniqueName-1.3 {nested type name} -body {
244 snit::RT.UniqueName counter ::thisis::yourtype ::your::%AUTO%
247 } -result {::your::yourtype1}
249 test RT.UniqueInstanceNamespace-1.1 {no name collision} -setup {
250 namespace eval ::mytype:: {}
253 snit::RT.UniqueInstanceNamespace counter ::mytype
256 namespace delete ::mytype::
257 } -result {::mytype::Snit_inst1}
259 test RT.UniqueInstanceNamespace-1.2 {name collision} -setup {
260 namespace eval ::mytype:: {}
261 namespace eval ::mytype::Snit_inst1:: {}
262 namespace eval ::mytype::Snit_inst2:: {}
267 snit::RT.UniqueInstanceNamespace counter ::mytype
270 namespace delete ::mytype::
271 } -result {::mytype::Snit_inst3}
273 test Contains-1.1 {contains element} -constraints {
276 set mylist {foo bar baz}
278 snit::Contains baz $mylist
283 test Contains-1.2 {does not contain element} -constraints {
286 set mylist {foo bar baz}
288 snit::Contains quux $mylist
293 #-----------------------------------------------------------------------
296 # snit::compile returns two values, the qualified type name
297 # and the script to execute to define the type. This section
298 # only checks the length of the list and the type name;
299 # the content of the script is validated by the remainder
300 # of this test suite.
302 test compile-1.1 {compile returns qualified type} -body {
303 set compResult [compile type dog { }]
305 list [llength $compResult] [lindex $compResult 0]
308 #-----------------------------------------------------------------------
311 test typedestruction-1.1 {type command is deleted} -body {
317 test typedestruction-1.2 {instance commands are deleted} -body {
325 test typedestruction-1.3 {type namespace is deleted} -body {
328 namespace exists ::dog
331 test typedestruction-1.4 {type proc is destroyed on error} -body {
333 error "Error creating dog"
336 list [namespace exists ::dog] [info command ::dog]
339 test typedestruction-1.5 {unrelated namespaces are deleted, bug 2898640} -body {
341 namespace eval dog::unrelated {}
345 #-----------------------------------------------------------------------
346 # type and typemethods
348 test type-1.1 {type names get qualified} -body {
354 test type-1.2 {typemethods can be defined} -body {
356 typemethod foo {a b} {
366 test type-1.3 {upvar works in typemethods} -body {
368 typemethod goodname {varname} {
382 test type-1.4 {typemethod args can't include type} -body {
384 typemethod foo {a type b} { }
386 } -returnCodes error -result {typemethod foo's arglist may not contain "type" explicitly}
388 test type-1.5 {typemethod args can't include self} -body {
390 typemethod foo {a self b} { }
392 } -returnCodes error -result {typemethod foo's arglist may not contain "self" explicitly}
394 test type-1.6 {typemethod args can span multiple lines} -body {
395 # This case caused an error at definition time in 0.9 because the
396 # arguments were included in a comment in the compile script, and
397 # the subsequent lines weren't commented.
409 #-----------------------------------------------------------------------
412 test typeconstructor-1.1 {a typeconstructor can be defined} -body {
430 test typeconstructor-1.2 {only one typeconstructor can be defined} -body {
442 } -returnCodes error -result {too many typeconstructors}
444 test typeconstructor-1.3 {type proc is destroyed on error} -body {
448 error "Error creating dog"
453 list [namespace exists ::dog] [info command ::dog]
456 #-----------------------------------------------------------------------
459 test typecomponent-1.1 {typecomponent defines typevariable} -body {
473 test typecomponent-1.2 {typecomponent trace executes} -body {
478 typevariable Snit_typecomponents
480 return $Snit_typecomponents(mycomp)
489 test typecomponent-1.3 {typecomponent -public works} -body {
491 typecomponent mycomp -public string
498 dog string length foo
503 test typecomponent-1.4 {typecomponent -inherit yes} -body {
505 typecomponent mycomp -inherit yes
518 #-----------------------------------------------------------------------
519 # hierarchical type methods
521 test htypemethod-1.1 {hierarchical method, two tokens} -body {
523 typemethod {wag tail} {} {
531 } -result {wags tail}
533 test htypemethod-1.2 {hierarchical method, three tokens} -body {
535 typemethod {wag tail proudly} {} {
536 return "wags tail proudly"
543 } -result {wags tail proudly}
545 test htypemethod-1.3 {hierarchical method, four tokens} -body {
547 typemethod {wag tail really high} {} {
548 return "wags tail really high"
552 dog wag tail really high
555 } -result {wags tail really high}
557 test htypemethod-1.4 {redefinition is OK} -body {
559 typemethod {wag tail} {} {
562 typemethod {wag tail} {} {
563 return "wags tail briskly"
570 } -result {wags tail briskly}
573 test htypemethod-1.5 {proper error on missing submethod} -constraints {
579 typemethod {wag tail} {} { }
587 } -result {wrong number args: should be "::dog wag method args"}
590 test htypemethod-1.6 {proper error on missing submethod} -constraints {
596 typemethod {wag tail} {} { }
605 {wrong # args: should be "dog wag subcommand ?arg ...?"} \
606 {wrong # args: should be "dog wag subcommand ?argument ...?"}]
609 test htypemethod-1.7 {proper error on bogus submethod} -constraints {
615 typemethod {wag tail} {} { }
623 } -result {"::dog wag ears" is not defined}
626 test htypemethod-1.8 {proper error on bogus submethod} -constraints {
632 typemethod {wag tail} {} { }
640 } -result {unknown subcommand "ears": namespace ::dog does not export any commands}
642 test htypemethod-2.1 {prefix/method collision, level 1, order 1} -body {
645 typemethod {wag tail} {} {}
649 } -result {Error in "typemethod {wag tail}...", "wag" has no submethods.}
651 test htypemethod-2.2 {prefix/method collision, level 1, order 2} -body {
653 typemethod {wag tail} {} {}
658 } -result {Error in "typemethod wag...", "wag" has submethods.}
660 test htypemethod-2.3 {prefix/method collision, level 2, order 1} -body {
662 typemethod {wag tail} {} {}
663 typemethod {wag tail proudly} {} {}
667 } -result {Error in "typemethod {wag tail proudly}...", "wag tail" has no submethods.}
669 test htypemethod-2.4 {prefix/method collision, level 2, order 2} -body {
671 typemethod {wag tail proudly} {} {}
672 typemethod {wag tail} {} {}
676 } -result {Error in "typemethod {wag tail}...", "wag tail" has submethods.}
678 #-----------------------------------------------------------------------
679 # Typemethod delegation
681 test dtypemethod-1.1 {delegate typemethod to non-existent component} -body {
685 delegate typemethod foo to bar
691 } -result {::dog delegates typemethod "foo" to undefined typecomponent "bar"}
693 test dtypemethod-1.2 {delegating to existing typecomponent} -body {
695 delegate typemethod length to string
708 test dtypemethod-1.3 {delegating to existing typecomponent with error} -constraints {
712 delegate typemethod length to string
722 } -result {wrong # args: should be "string length string"}
725 test dtypemethod-1.4 {delegating to existing typecomponent with error} -constraints {
729 delegate typemethod length to string
739 } -result {wrong # args: should be "dog length string"}
741 test dtypemethod-1.5 {delegating unknown typemethods to existing typecomponent} -body {
743 delegate typemethod * to string
756 test dtypemethod-1.6 {delegating unknown typemethod to existing typecomponent with error} -body {
758 delegate typemethod * to stringhandler
761 set stringhandler string
770 } -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}
772 test dtypemethod-1.6a {delegating unknown typemethod to existing typecomponent with error} -body {
774 delegate typemethod * to stringhandler
777 set stringhandler string
786 } -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}
788 test dtypemethod-1.7 {can't delegate local typemethod: order 1} -body {
791 delegate typemethod foo to bar
795 } -result {Error in "delegate typemethod foo...", "foo" has been defined locally.}
797 test dtypemethod-1.8 {can't delegate local typemethod: order 2} -body {
799 delegate typemethod foo to bar
804 } -result {Error in "typemethod foo...", "foo" has been delegated}
807 test dtypemethod-1.9 {excepted methods are caught properly} -constraints {
811 delegate typemethod * to string except {match index}
818 catch {dog length foo} a
819 catch {dog match foo} b
820 catch {dog index foo} c
825 } -result {3 {"::dog match" is not defined} {"::dog index" is not defined}}
828 test dtypemethod-1.10 {excepted methods are caught properly} -constraints {
832 delegate typemethod * to string except {match index}
839 catch {dog length foo} a
840 catch {dog match foo} b
841 catch {dog index foo} c
846 } -result {3 {unknown subcommand "match": must be length} {unknown subcommand "index": must be length}}
848 test dtypemethod-1.11 {as clause can include arguments} -body {
854 delegate typemethod wag to tail as {wag briskly}
865 } -result {<wag briskly>}
867 test dtypemethod-2.1 {'using "%c %m"' gets normal behavior} -body {
869 delegate typemethod length to string using {%c %m}
881 test dtypemethod-2.2 {All relevant 'using' conversions are converted} -body {
887 delegate typemethod {tail wag} using {echo %% %t %M %m %j %n %w %s %c}
894 } -result {% ::dog {tail wag} wag tail_wag %n %w %s %c}
896 test dtypemethod-2.3 {"%%" is handled properly} -body {
897 proc echo {args} { join $args "|" }
900 delegate typemethod wag using {echo %%m %%%m}
909 test dtypemethod-2.4 {Method "*" and "using"} -body {
910 proc echo {args} { join $args "|" }
913 delegate typemethod * using {echo %m}
916 list [dog wag] [dog bark loudly]
920 } -result {wag bark|loudly}
922 test dtypemethod-3.1 {typecomponent names can be changed dynamically} -body {
923 proc echo {args} { join $args "|" }
926 delegate typemethod length to mycomp
932 typemethod switchit {} {
937 set a [dog length foo]
939 set b [dog length foo]
945 } -result {3 length|foo}
947 test dtypemethod-4.1 {hierarchical typemethod, two tokens} -body {
949 method wag {} {return "wags tail"}
954 set tail [tail %AUTO%]
956 delegate typemethod {wag tail} to tail as wag
963 } -result {wags tail}
965 test dtypemethod-4.2 {hierarchical typemethod, three tokens} -body {
967 method wag {} {return "wags tail"}
972 set tail [tail %AUTO%]
974 delegate typemethod {wag tail proudly} to tail as wag
981 } -result {wags tail}
983 test dtypemethod-4.3 {hierarchical typemethod, four tokens} -body {
985 method wag {} {return "wags tail"}
990 set tail [tail %AUTO%]
992 delegate typemethod {wag tail really high} to tail as wag
995 dog wag tail really high
999 } -result {wags tail}
1001 test dtypemethod-4.4 {redefinition is OK} -body {
1003 method {wag tail} {} {return "wags tail"}
1004 method {wag briskly} {} {return "wags tail briskly"}
1009 set tail [tail %AUTO%]
1011 delegate typemethod {wag tail} to tail as {wag tail}
1012 delegate typemethod {wag tail} to tail as {wag briskly}
1019 } -result {wags tail briskly}
1021 test dtypemethod-4.5 {last token is used by default} -body {
1023 method wag {} {return "wags tail"}
1028 set tail [tail %AUTO%]
1030 delegate typemethod {tail wag} to tail
1037 } -result {wags tail}
1039 test dtypemethod-4.6 {last token can be *} -body {
1041 method wag {} {return "wags"}
1042 method droop {} {return "droops"}
1047 set tail [tail %AUTO%]
1049 delegate typemethod {tail *} to tail
1052 list [dog tail wag] [dog tail droop]
1056 } -result {wags droops}
1059 test dtypemethod-4.7 {except with multiple tokens} -constraints {
1063 method wag {} {return "wags"}
1064 method droop {} {return "droops"}
1069 set tail [tail %AUTO%]
1071 delegate typemethod {tail *} to tail except droop
1074 catch {dog tail droop} result
1076 list [dog tail wag] $result
1080 } -result {wags {"::dog tail droop" is not defined}}
1083 test dtypemethod-4.8 {except with multiple tokens} -constraints {
1087 method wag {} {return "wags"}
1088 method droop {} {return "droops"}
1093 set tail [tail %AUTO%]
1095 delegate typemethod {tail *} to tail except droop
1098 catch {dog tail droop} result
1100 list [dog tail wag] $result
1104 } -result {wags {unknown subcommand "droop": namespace ::dog does not export any commands}}
1106 test dtypemethod-4.9 {"*" in the wrong spot} -body {
1108 delegate typemethod {tail * wag} to tail
1112 } -result {Error in "delegate typemethod {tail * wag}...", "*" must be the last token.}
1114 test dtypemethod-5.1 {prefix/typemethod collision} -body {
1116 delegate typemethod wag to tail
1117 delegate typemethod {wag tail} to tail as wag
1121 } -result {Error in "delegate typemethod {wag tail}...", "wag" has no submethods.}
1123 test dtypemethod-5.2 {prefix/typemethod collision} -body {
1125 delegate typemethod {wag tail} to tail as wag
1126 delegate typemethod wag to tail
1130 } -result {Error in "delegate typemethod wag...", "wag" has submethods.}
1132 test dtypemethod-5.3 {prefix/typemethod collision} -body {
1134 delegate typemethod {wag tail} to tail
1135 delegate typemethod {wag tail proudly} to tail as wag
1139 } -result {Error in "delegate typemethod {wag tail proudly}...", "wag tail" has no submethods.}
1141 test dtypemethod-5.4 {prefix/typemethod collision} -body {
1143 delegate typemethod {wag tail proudly} to tail as wag
1144 delegate typemethod {wag tail} to tail
1148 } -result {Error in "delegate typemethod {wag tail}...", "wag tail" has submethods.}
1150 #-----------------------------------------------------------------------
1153 test creation-1.1 {type instance names get qualified} -body {
1161 test creation-1.2 {type instance names can be generated} -body {
1167 } -result {::mydog1}
1169 test creation-1.3 {"create" method is optional} -body {
1177 test creation-1.4 {constructor arg can't be type} -body {
1179 constructor {type} { }
1183 } -result {constructor's arglist may not contain "type" explicitly}
1185 test creation-1.5 {constructor arg can't be self} -body {
1187 constructor {self} { }
1191 } -result {constructor's arglist may not contain "self" explicitly}
1193 test creation-1.6 {weird names are OK} -body {
1194 # I.e., names with non-identifier characters
1197 return "$self meows."
1204 confused-dog destroy
1205 } -result {::spot meows.}
1208 test creation-1.7 {If -hasinstances yes, [$type] == [$type create %AUTO%]} -constraints {
1222 test creation-1.8 {If -hasinstances yes, [$type] == [$type create %AUTO%]} -constraints {
1226 # WHD: In Snit 1.0, this pragma was not needed.
1227 pragma -hastypemethods no
1233 # [dog destroy] doesn't exist
1235 namespace delete ::dog
1239 test creation-1.9 {If -hasinstances no, [$type] != [$type create %AUTO%]} -constraints {
1243 pragma -hasinstances no
1251 } -result {wrong # args: should be "::dog method args"}
1254 test creation-1.10 {If -hasinstances no, [$type] != [$type create %AUTO%]} -constraints {
1258 pragma -hasinstances no
1267 {wrong # args: should be "dog subcommand ?arg ...?"} \
1268 {wrong # args: should be "dog subcommand ?argument ...?"}]
1271 test creation-1.11 {If widget, [$type] != [$type create %AUTO%]} -constraints {
1283 } -result {wrong # args: should be "::dog method args"}
1286 test creation-1.12 {If widget, [$type] != [$type create %AUTO%]} -constraints {
1299 {wrong # args: should be "dog subcommand ?arg ...?"} \
1300 {wrong # args: should be "dog subcommand ?argument ...?"}]
1302 test creation-1.13 {If -hastypemethods yes, [$type] == [$type create %AUTO%]} -constraints {
1314 test creation-1.14 {If -hastypemethods yes, [$type] != [$type create %AUTO%]} -constraints {
1327 {wrong # args: should be "dog subcommand ?arg ...?"} \
1328 {wrong # args: should be "dog subcommand ?argument ...?"}]
1330 test creation-2.1 {Can't call "destroy" in constructor} -body {
1342 } -result {Error in constructor: Called 'destroy' method in constructor}
1344 #-----------------------------------------------------------------------
1347 test proc-1.1 {proc args can span multiple lines} -body {
1348 # This case caused an error at definition time in 0.9 because the
1349 # arguments were included in a comment in the compile script, and
1350 # the subsequent lines weren't commented.
1362 #-----------------------------------------------------------------------
1365 test method-1.1 {methods get called} -body {
1368 return "$self barks"
1376 } -result {::spot barks}
1378 test method-1.2 {methods can call other methods} -body {
1381 return "$self barks."
1384 method chase {quarry} {
1385 return "$self chases $quarry; [$self bark]"
1393 } -result {::spot chases cat; ::spot barks.}
1395 test method-1.3 {instances can call one another} -body {
1398 return "$self barks."
1401 method chase {quarry} {
1402 return "$self chases $quarry; [$quarry bark] [$self bark]"
1411 } -result {::spot chases ::fido; ::fido barks. ::spot barks.}
1413 test method-1.4 {upvar works in methods} -body {
1415 method goodname {varname} {
1416 upvar $varname myvar
1423 fido goodname thename
1430 test method-1.5 {unknown methods get an error} -constraints {
1442 } -result {"::spot chase" is not defined}
1445 test method-1.6 {unknown methods get an error} -constraints {
1457 } -result {unknown subcommand "chase": namespace ::dog::Snit_inst1 does not export any commands}
1459 test method-1.7 {info type method returns the object's type} -body {
1468 test method-1.8 {instance method can call type method} -body {
1470 typemethod hello {} {
1473 method helloworld {} {
1474 return "[$type hello], World!"
1482 } -result {Hello, World!}
1484 test method-1.9 {type methods must be qualified} -body {
1486 typemethod hello {} {
1489 method helloworld {} {
1490 return "[hello], World!"
1500 } -result {invalid command name "hello"}
1503 test method-1.10 {too few arguments} -constraints {
1507 method bark {volume} { }
1516 } -result [tcltest::wrongNumArgs ::dog::Snit_methodbark {type selfns win self volume} 4]
1519 test method-1.11 {too few arguments} -constraints {
1523 method bark {volume} { }
1532 } -result {wrong # args: should be "spot bark volume"}
1535 test method-1.12 {too many arguments} -constraints {
1539 method bark {volume} { }
1544 spot bark really loud
1547 } -result [tcltest::tooManyArgs ::dog::Snit_methodbark {type selfns win self volume}]
1550 test method-1.13 {too many arguments} -constraints {
1554 method bark {volume} { }
1559 spot bark really loud
1564 } -result {wrong # args: should be "spot bark volume"}
1566 test method-1.14 {method args can't include type} -body {
1568 method foo {a type b} { }
1572 } -result {method foo's arglist may not contain "type" explicitly}
1574 test method-1.15 {method args can't include self} -body {
1576 method foo {a self b} { }
1580 } -result {method foo's arglist may not contain "self" explicitly}
1582 test method-1.16 {method args can span multiple lines} -body {
1583 # This case caused an error at definition time in 0.9 because the
1584 # arguments were included in a comment in the compile script, and
1585 # the subsequent lines weren't commented.
1596 #-----------------------------------------------------------------------
1597 # hierarchical methods
1599 test hmethod-1.1 {hierarchical method, two tokens} -body {
1601 method {wag tail} {} {
1602 return "$self wags tail."
1610 } -result {::spot wags tail.}
1612 test hmethod-1.2 {hierarchical method, three tokens} -body {
1614 method {wag tail proudly} {} {
1615 return "$self wags tail proudly."
1620 spot wag tail proudly
1623 } -result {::spot wags tail proudly.}
1625 test hmethod-1.3 {hierarchical method, three tokens} -body {
1627 method {wag tail really high} {} {
1628 return "$self wags tail really high."
1633 spot wag tail really high
1636 } -result {::spot wags tail really high.}
1638 test hmethod-1.4 {redefinition is OK} -body {
1640 method {wag tail} {} {
1641 return "$self wags tail."
1643 method {wag tail} {} {
1644 return "$self wags tail briskly."
1652 } -result {::spot wags tail briskly.}
1655 test hmethod-1.5 {proper error on missing submethod} -constraints {
1659 method {wag tail} {} { }
1668 } -result {wrong number args: should be "::spot wag method args"}
1671 test hmethod-1.6 {proper error on missing submethod} -constraints {
1675 method {wag tail} {} { }
1685 {wrong # args: should be "spot wag subcommand ?arg ...?"} \
1686 {wrong # args: should be "spot wag subcommand ?argument ...?"}]
1688 test hmethod-1.7 {submethods called in proper objects} -body {
1689 # NOTE: This test was added in response to a bug report by
1690 # Anton Kovalenko. In Snit 2.0, submethod ensembles were
1691 # created in the type namespace. If a type defines a submethod
1692 # ensemble, then all objects of that type would end up sharing
1693 # a single ensemble. Ensembles are created lazily, so in this
1694 # test, the first call to "fido this tail wag" and "spot this tail wag"
1695 # will yield the correct result, but the second call to
1696 # "fido this tail wag" will yield the same as the call to
1697 # "spot this tail wag", because spot's submethod ensemble has
1698 # displaced fido's. Until the bug is fixed, that is.
1700 # Fortunately, Anton provided the fix as well.
1705 return "wags tail $options(-manner)"
1710 delegate option -manner to tail
1711 delegate method {this tail wag} to tail
1713 constructor {args} {
1714 set tail [tail %AUTO%]
1715 $self configurelist $args
1719 dog fido -manner briskly
1720 dog spot -manner slowly
1722 list [fido this tail wag] [spot this tail wag] [fido this tail wag]
1726 } -result {{wags tail briskly} {wags tail slowly} {wags tail briskly}}
1728 test hmethod-2.1 {prefix/method collision} -body {
1731 method {wag tail} {} {
1732 return "$self wags tail."
1737 } -result {Error in "method {wag tail}...", "wag" has no submethods.}
1739 test hmethod-2.2 {prefix/method collision} -body {
1741 method {wag tail} {} {
1742 return "$self wags tail."
1748 } -result {Error in "method wag...", "wag" has submethods.}
1750 test hmethod-2.3 {prefix/method collision} -body {
1752 method {wag tail} {} {}
1753 method {wag tail proudly} {} {
1754 return "$self wags tail."
1759 } -result {Error in "method {wag tail proudly}...", "wag tail" has no submethods.}
1761 test hmethod-2.4 {prefix/method collision} -body {
1763 method {wag tail proudly} {} {
1764 return "$self wags tail."
1766 method {wag tail} {} {}
1770 } -result {Error in "method {wag tail}...", "wag tail" has submethods.}
1772 #-----------------------------------------------------------------------
1773 # mymethod and renaming
1775 test rename-1.1 {mymethod uses name of instance name variable} -body {
1777 method mymethod {} {
1778 list [mymethod] [mymethod "A B"] [mymethod A B]
1786 } -result {{::snit::RT.CallInstance ::dog::Snit_inst1} {::snit::RT.CallInstance ::dog::Snit_inst1 {A B}} {::snit::RT.CallInstance ::dog::Snit_inst1 A B}}
1788 test rename-1.2 {instances can be renamed} -body {
1791 list [mymethod] $selfns $win $self
1803 } -result {{::snit::RT.CallInstance ::dog::Snit_inst1} ::dog::Snit_inst1 ::fido ::fido {::snit::RT.CallInstance ::dog::Snit_inst1} ::dog::Snit_inst1 ::fido ::spot}
1805 test rename-1.3 {rename to "" deletes an instance} -constraints {
1812 namespace children ::dog
1817 test rename-1.4 {rename to "" deletes an instance even after a rename} -constraints {
1825 namespace children ::dog
1830 test rename-1.5 {creating an object twice destroys the first instance} -constraints {
1834 # Can't even test this normally.
1835 pragma -canreplace yes
1839 set a [namespace children ::dog]
1841 set b [namespace children ::dog]
1843 set c [namespace children ::dog]
1848 } -result {::dog::Snit_inst1 ::dog::Snit_inst2 {}}
1850 #-----------------------------------------------------------------------
1851 # mymethod actually works
1853 test mymethod-1.1 {run mymethod handler} -body {
1857 eval [linsert $options(-command) end $self snarf]
1863 constructor {args} {
1864 set sub [foo fubar -command [mymethod Handler]]
1868 method Handler {args} {
1885 } -result {::bar::fubar snarf}
1887 #-----------------------------------------------------------------------
1890 test myproc-1.1 {myproc qualifies proc names} -body {
1894 typemethod getit {} {
1902 } -result {::dog::foo}
1904 test myproc-1.2 {myproc adds arguments} -body {
1908 typemethod getit {} {
1909 return [myproc foo "a b"]
1916 } -result {::dog::foo {a b}}
1918 test myproc-1.3 {myproc adds arguments} -body {
1922 typemethod getit {} {
1923 return [myproc foo "a b" c d]
1930 } -result {::dog::foo {a b} c d}
1932 test myproc-1.4 {procs with selfns work} -body {
1937 return [myproc getdatum $selfns]
1939 proc getdatum {selfns} {
1950 #-----------------------------------------------------------------------
1953 test mytypemethod-1.1 {mytypemethod qualifies typemethods} -body {
1955 typemethod this {} {}
1958 return [mytypemethod this]
1961 return [mytypemethod this x]
1964 return [mytypemethod this "x y"]
1967 return [mytypemethod this x y]
1971 list [dog a] [dog b] [dog c] [dog d]
1974 } -result {{::dog this} {::dog this x} {::dog this {x y}} {::dog this x y}}
1976 #-----------------------------------------------------------------------
1979 test typevariable-1.1 {typevarname qualifies typevariables} -body {
1980 # Note: typevarname is DEPRECATED. Real code should use
1981 # mytypevar instead.
1983 method tvname {name} {
1992 } -result {::dog::myvar}
1994 test typevariable-1.2 {undefined typevariables are OK} -body {
1996 method tset {value} {
1997 typevariable theValue
2003 typevariable theValue
2013 list [spot tget] [fido tget] [set ::dog::theValue]
2016 } -result {Howdy Howdy Howdy}
2018 test typevariable-1.3 {predefined typevariables are OK} -body {
2020 typevariable greeting Hello
2030 list [spot tget] [fido tget] [set ::dog::greeting]
2033 } -result {Hello Hello Hello}
2035 test typevariable-1.4 {typevariables can be arrays} -body {
2037 typevariable greetings
2041 set greetings(b) Howdy
2047 list $::dog::greetings(a) $::dog::greetings(b)
2050 } -result {Hi Howdy}
2052 test typevariable-1.5 {typevariables can used in typemethods} -body {
2054 typevariable greetings Howdy
2056 typemethod greet {} {
2066 test typevariable-1.6 {typevariables can used in procs} -body {
2068 typevariable greetings Howdy
2085 test typevariable-1.7 {mytypevar qualifies typevariables} -body {
2087 method tvname {name} {
2096 } -result {::dog::myvar}
2098 test typevariable-1.8 {typevariable with too many initializers throws an error} -body {
2100 typevariable color dark brown
2104 } -result {Error in "typevariable color...", too many initializers}
2106 test typevariable-1.9 {typevariable with too many initializers throws an error} -body {
2108 typevariable color -array dark brown
2114 } -result {Error in "typevariable color...", too many initializers}
2116 test typevariable-1.10 {typevariable can initialize array variables} -body {
2118 typevariable data -array {
2123 typemethod getdata {item} {
2128 list [dog getdata family] [dog getdata color]
2131 } -result {jones brown}
2133 #-----------------------------------------------------------------------
2136 test ivariable-1.1 {myvar qualifies instance variables} -body {
2138 method vname {name} {
2147 } -result {::dog::Snit_inst1::somevar}
2149 test ivariable-1.2 {undefined instance variables are OK} -body {
2151 method setgreeting {value} {
2157 method getgreeting {} {
2164 set spot [dog create spot]
2165 spot setgreeting Hey
2168 fido setgreeting Howdy
2170 list [spot getgreeting] [fido getgreeting] [set ::dog::Snit_inst1::greeting]
2173 } -result {Hey Howdy Hey}
2175 test ivariable-1.3 {instance variables are destroyed automatically} -body {
2177 constructor {args} {
2185 set g1 $::dog::Snit_inst1::greeting
2188 list $g1 [info exists ::dog::Snit_inst1::greeting]
2193 test ivariable-1.4 {defined instance variables need not be declared} -body {
2213 test ivariable-1.5 {instance variables can be arrays} -body {
2219 set greetings(b) Howdy
2223 return [myvar greetings]
2229 list [set [spot vname](a)] [set [spot vname](b)]
2232 } -result {Hi Howdy}
2234 test ivariable-1.6 {instance variables can be initialized in the definition} -body {
2236 variable greetings {Hi Howdy}
2240 list $greetings $empty
2248 } -result {{Hi Howdy} {}}
2250 test ivariable-1.7 {variable is illegal when selfns is undefined} -body {
2267 } -result {can't read "selfns": no such variable}
2269 test ivariable-1.8 {myvar is illegal when selfns is undefined} -body {
2286 } -result {can't read "selfns": no such variable}
2288 test ivariable-1.9 {procs which define selfns see instance variables} -body {
2290 variable greeting Howdy
2293 return [callee $selfns]
2296 proc callee {selfns} {
2308 test ivariable-1.10 {in methods, variable works with fully qualified names} -body {
2309 namespace eval ::somenamespace:: {
2310 set somevar somevalue
2315 variable ::somenamespace::somevar
2325 } -result {somevalue}
2327 test ivariable-1.11 {variable with too many initializers throws an error} -body {
2329 variable color dark brown
2333 } -result {Error in "variable color...", too many initializers}
2335 test ivariable-1.12 {variable with too many initializers throws an error} -body {
2337 variable color -array dark brown
2341 } -result {Error in "variable color...", too many initializers}
2343 test ivariable-1.13 {variable can initialize array variables} -body {
2345 variable data -array {
2350 method getdata {item} {
2356 list [spot getdata family] [spot getdata color]
2359 } -result {jones brown}
2361 #-----------------------------------------------------------------------
2364 # NOTE: codename is deprecated; myproc should be used instead.
2366 test codename-1.1 {codename qualifies procs} -body {
2369 return [codename myproc]
2377 } -result {::dog::myproc}
2379 test codename-1.2 {procs with selfns work} -body {
2384 return [list [codename getdatum] $selfns]
2386 proc getdatum {selfns} {
2396 #-----------------------------------------------------------------------
2399 test option-1.1 {options get default values} -body {
2401 option -color golden
2410 test option-1.2 {options can be set} -body {
2412 option -color golden
2416 spot configure -color black
2422 test option-1.3 {multiple options can be set} -body {
2424 option -color golden
2429 spot configure -color brown -akc 1
2430 list [spot cget -color] [spot cget -akc]
2435 test option-1.4 {options can be retrieved as instance variable} -body {
2437 option -color golden
2440 method listopts {} {
2441 list $options(-color) $options(-akc)
2446 spot configure -color black -akc 1
2452 test option-1.5 {options can be set as an instance variable} -body {
2454 option -color golden
2458 set options(-color) black
2465 list [spot cget -color] [spot cget -akc]
2470 test option-1.6 {options can be set at creation time} -body {
2472 option -color golden
2476 dog create spot -color white -akc 1
2477 list [spot cget -color] [spot cget -akc]
2482 test option-1.7 {undefined option: cget} -body {
2484 option -color golden
2494 } -result {unknown option "-colour"}
2496 test option-1.8 {undefined option: configure} -body {
2498 option -color golden
2503 spot configure -colour blue
2508 } -result {unknown option "-colour"}
2510 test option-1.9 {options default to ""} -body {
2521 test option-1.10 {spaces allowed in option defaults} -body {
2523 option -breed "golden retriever"
2529 } -result {golden retriever}
2531 test option-1.11 {brackets allowed in option defaults} -body {
2533 option -regexp {[a-z]+}
2542 test option-2.1 {configure returns info, local options only} -body {
2549 spot configure -color red
2550 spot configure -akc 0
2554 } -result {{-color color Color black red} {-akc akc Akc 1 0}}
2556 test option-2.2 {configure -opt returns info, local options only} -body {
2563 spot configure -color red
2564 spot configure -color
2567 } -result {-color color Color black red}
2569 test option-2.3 {configure -opt returns info, explicit options} -body {
2576 delegate option -akc to papers as -akcflag
2577 constructor {args} {
2578 set papers [papers create $self.papers]
2582 catch {$self.papers destroy}
2587 spot configure -akc 0
2591 } -result {-akc akc Akc 1 0}
2593 test option-2.4 {configure -unknownopt} -body {
2600 delegate option -akc to papers as -akcflag
2601 constructor {args} {
2602 set papers [papers create $self.papers]
2606 catch {$self.papers destroy}
2617 } -result {unknown option "-foo"}
2619 test option-2.5 {configure returns info, unknown options} -constraints {
2622 widgetadaptor myframe {
2624 delegate option -width to hull
2625 delegate option * to hull
2626 constructor {args} {
2627 installhull [frame $self]
2632 set a [.frm configure -foo]
2633 set b [.frm configure -width]
2634 set c [.frm configure -height]
2642 } -result {{-foo foo Foo a a} {-width width Width 0 0} {-height height Height 0 0}}
2644 test option-2.6 {configure -opt unknown to implicit component} -constraints {
2647 widgetadaptor myframe {
2648 delegate option * to hull
2649 constructor {args} {
2650 installhull [frame $self]
2654 catch {.frm configure -quux} result
2660 } -result {unknown option "-quux"}
2662 test option-3.1 {set option resource name explicitly} -body {
2664 option {-tailcolor tailColor} black
2669 fido configure -tailcolor
2672 } -result {-tailcolor tailColor TailColor black black}
2674 test option-3.2 {set option class name explicitly} -body {
2676 option {-tailcolor tailcolor TailColor} black
2681 fido configure -tailcolor
2684 } -result {-tailcolor tailcolor TailColor black black}
2686 test option-3.3 {delegated option's names come from owner} -body {
2692 delegate option -tailcolor to tail as -color
2694 constructor {args} {
2695 set tail [tail fidotail]
2701 fido configure -tailcolor
2705 } -result {-tailcolor tailcolor Tailcolor black black}
2707 test option-3.4 {delegated option's resource name set explicitly} -body {
2713 delegate option {-tailcolor tailColor} to tail as -color
2715 constructor {args} {
2716 set tail [tail fidotail]
2722 fido configure -tailcolor
2726 } -result {-tailcolor tailColor TailColor black black}
2728 test option-3.5 {delegated option's class name set explicitly} -body {
2734 delegate option {-tailcolor tailcolor TailColor} to tail as -color
2736 constructor {args} {
2737 set tail [tail fidotail]
2743 fido configure -tailcolor
2747 } -result {-tailcolor tailcolor TailColor black black}
2749 test option-3.6 {delegated option's default comes from component} -body {
2755 delegate option -tailcolor to tail as -color
2757 constructor {args} {
2758 set tail [tail fidotail -color red]
2764 fido configure -tailcolor
2768 } -result {-tailcolor tailcolor Tailcolor black red}
2770 test option-4.1 {local option name must begin with hyphen} -body {
2776 } -result {Error in "option nohyphen...", badly named option "nohyphen"}
2778 test option-4.2 {local option name must be lower case} -body {
2784 } -result {Error in "option -Upper...", badly named option "-Upper"}
2786 test option-4.3 {local option name may not contain spaces} -body {
2788 option {"-with space"}
2792 } -result {Error in "option {"-with space"}...", badly named option "-with space"}
2794 test option-4.4 {delegated option name must begin with hyphen} -body {
2796 delegate option nohyphen to tail
2800 } -result {Error in "delegate option nohyphen...", badly named option "nohyphen"}
2802 test option-4.5 {delegated option name must be lower case} -body {
2804 delegate option -Upper to tail
2808 } -result {Error in "delegate option -Upper...", badly named option "-Upper"}
2810 test option-4.6 {delegated option name may not contain spaces} -body {
2812 delegate option {"-with space"} to tail
2816 } -result {Error in "delegate option {"-with space"}...", badly named option "-with space"}
2818 test option-5.1 {local widget options read from option database} -constraints {
2826 option add *Dog.bar bb
2831 set a [.fido cget -foo]
2832 set b [.fido cget -bar]
2842 test option-5.2 {local option database values available in constructor} -constraints {
2850 option add *Dog.bar bb
2853 constructor {args} {
2854 set saveit $options(-bar)
2863 set result [.fido getit]
2872 test option-6.1 {if no options, no options variable} -body {
2878 spot info vars options
2883 test option-6.2 {if no options, no options methods} -body {
2889 spot info methods c*
2894 #-----------------------------------------------------------------------
2897 test onconfigure-1.1 {invalid onconfigure methods are caught} -body {
2899 onconfigure -color {value} { }
2903 } -result {onconfigure -color: option "-color" unknown}
2905 test onconfigure-1.2 {onconfigure methods take one argument} -body {
2907 option -color golden
2909 onconfigure -color {value badarg} { }
2913 } -result {onconfigure -color handler should have one argument, got "value badarg"}
2915 test onconfigure-1.3 {onconfigure methods work} -body {
2917 option -color golden
2919 onconfigure -color {value} {
2920 set options(-color) "*$value*"
2925 spot configure -color brown
2931 test onconfigure-1.4 {onconfigure arg can't be type} -body {
2934 onconfigure -color {type} { }
2938 } -result {onconfigure -color's arglist may not contain "type" explicitly}
2940 test onconfigure-1.5 {onconfigure arg can't be self} -body {
2943 onconfigure -color {self} { }
2947 } -result {onconfigure -color's arglist may not contain "self" explicitly}
2949 #-----------------------------------------------------------------------
2952 test oncget-1.1 {invalid oncget methods are caught} -body {
2958 } -result {Error in "oncget -color...", option "-color" unknown}
2960 test oncget-1.2 {oncget methods work} -body {
2964 option -color golden
2967 return "*$options(-color)*"
2972 spot configure -color brown
2978 #-----------------------------------------------------------------------
2982 test constructor-1.1 {constructor can do things} -body {
2986 constructor {args} {
3001 test constructor-1.2 {constructor with no configurelist ignores args} -body {
3003 constructor {args} { }
3004 option -color golden
3008 dog create spot -color white -akc 1
3009 list [spot cget -color] [spot cget -akc]
3012 } -result {golden 0}
3014 test constructor-1.3 {constructor with configurelist gets args} -body {
3016 constructor {args} {
3017 $self configurelist $args
3019 option -color golden
3023 dog create spot -color white -akc 1
3024 list [spot cget -color] [spot cget -akc]
3029 test constructor-1.4 {constructor with specific args} -body {
3032 constructor {a b args} {
3033 set options(-value) [list $a $b $args]
3037 dog spot retriever golden -akc 1
3041 } -result {retriever golden {-akc 1}}
3043 test constructor-1.5 {constructor with list as one list arg} -body {
3046 constructor {args} {
3047 set options(-value) $args
3051 dog spot {retriever golden}
3055 } -result {{retriever golden}}
3057 test constructor-1.6 {default constructor configures options} -body {
3063 dog spot -color golden -breed retriever
3064 list [spot cget -color] [spot cget -breed]
3067 } -result {golden retriever}
3069 test constructor-1.7 {default constructor takes no args if no options} -body {
3074 dog spot -color golden
3077 } -result "Error in constructor: [tcltest::tooManyArgs ::dog::Snit_constructor {type selfns win self}]"
3079 #-----------------------------------------------------------------------
3082 test destroy-1.1 {destroy cleans up the instance} -body {
3084 option -color golden
3087 set a [namespace children ::dog::]
3089 set b [namespace children ::dog::]
3091 set c [namespace children ::dog::]
3092 list $a $b $c [info commands ::dog::spot]
3095 } -result {{} ::dog::Snit_inst1 {} {}}
3097 test destroy-1.2 {incomplete objects are destroyed} -body {
3098 array unset ::dog::snit_ivars
3101 option -color golden
3103 constructor {args} {
3104 $self configurelist $args
3106 if {"red" == [$self cget -color]} {
3107 error "No Red Dogs!"
3112 catch {dog create spot -color red} result
3113 set names [array names ::dog::snit_ivars]
3114 list $result $names [info commands ::dog::spot]
3117 } -result {{Error in constructor: No Red Dogs!} {} {}}
3119 test destroy-1.3 {user-defined destructors are called} -body {
3121 typevariable flag ""
3123 constructor {args} {
3124 set flag "created $self"
3128 set flag "destroyed $self"
3131 typemethod getflag {} {
3139 list $a [dog getflag]
3142 } -result {{created ::spot} {destroyed ::spot}}
3144 #-----------------------------------------------------------------------
3145 # delegate: general syntax tests
3147 test delegate-1.1 {can only delegate methods or options} -body {
3149 delegate foo bar to baz
3153 } -result {Error in "delegate foo bar...", "foo"?}
3155 test delegate-1.2 {"to" must appear in the right place} -body {
3157 delegate method foo from bar
3161 } -result {Error in "delegate method foo...", unknown delegation option "from"}
3163 test delegate-1.3 {"as" must have a target} -body {
3165 delegate method foo to bar as
3169 } -result {Error in "delegate method foo...", invalid syntax}
3171 test delegate-1.4 {"as" must have a single target} -body {
3173 delegate method foo to bar as baz quux
3177 } -result {Error in "delegate method foo...", unknown delegation option "quux"}
3179 test delegate-1.5 {"as" doesn't work with "*"} -body {
3181 delegate method * to hull as foo
3185 } -result {Error in "delegate method *...", cannot specify "as" with "*"}
3187 test delegate-1.6 {"except" must have a target} -body {
3189 delegate method * to bar except
3193 } -result {Error in "delegate method *...", invalid syntax}
3195 test delegate-1.7 {"except" must have a single target} -body {
3197 delegate method * to bar except baz quux
3201 } -result {Error in "delegate method *...", unknown delegation option "quux"}
3203 test delegate-1.8 {"except" works only with "*"} -body {
3205 delegate method foo to hull except bar
3209 } -result {Error in "delegate method foo...", can only specify "except" with "*"}
3211 test delegate-1.9 {only "as" or "except"} -body {
3213 delegate method foo to bar with quux
3217 } -result {Error in "delegate method foo...", unknown delegation option "with"}
3220 #-----------------------------------------------------------------------
3223 test dmethod-1.1 {delegate method to non-existent component} -body {
3225 delegate method foo to bar
3234 } -result {::dog ::spot delegates method "foo" to undefined component "bar"}
3236 test dmethod-1.2 {delegating to existing component} -body {
3238 constructor {args} {
3242 delegate method length to string
3252 test dmethod-1.3 {delegating to existing component with error} -constraints {
3256 constructor {args} {
3260 delegate method length to string
3269 } -result {wrong # args: should be "string length string"}
3272 test dmethod-1.4 {delegating to existing component with error} -constraints {
3276 constructor {args} {
3280 delegate method length to string
3289 } -result {wrong # args: should be "spot length string"}
3291 test dmethod-1.5 {delegating unknown methods to existing component} -body {
3293 constructor {args} {
3297 delegate method * to string
3306 test dmethod-1.6 {delegating unknown method to existing component with error} -body {
3308 constructor {args} {
3309 set stringhandler string
3312 delegate method * to stringhandler
3323 } -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}
3325 test dmethod-1.6a {delegating unknown method to existing component with error} -body {
3327 constructor {args} {
3328 set stringhandler string
3331 delegate method * to stringhandler
3342 } -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}
3344 test dmethod-1.7 {can't delegate local method: order 1} -body {
3347 delegate method foo to hull
3351 } -result {Error in "delegate method foo...", "foo" has been defined locally.}
3353 test dmethod-1.8 {can't delegate local method: order 2} -body {
3355 delegate method foo to hull
3360 } -result {Error in "method foo...", "foo" has been delegated}
3363 test dmethod-1.9 {excepted methods are caught properly} -constraints {
3367 method wag {} {return "wagged"}
3368 method flaunt {} {return "flaunted"}
3369 method tuck {} {return "tuck"}
3374 delegate method * to tail except {wag tuck}
3376 constructor {args} {
3377 set tail [tail %AUTO%]
3383 catch {fifi flaunt} a
3391 } -result {flaunted {"::fifi wag" is not defined} {"::fifi tuck" is not defined}}
3394 test dmethod-1.10 {excepted methods are caught properly} -constraints {
3398 method wag {} {return "wagged"}
3399 method flaunt {} {return "flaunted"}
3400 method tuck {} {return "tuck"}
3405 delegate method * to tail except {wag tuck}
3407 constructor {args} {
3408 set tail [tail %AUTO%]
3414 catch {fifi flaunt} a
3422 } -result {flaunted {unknown subcommand "wag": must be flaunt} {unknown subcommand "tuck": must be flaunt}}
3424 test dmethod-1.11 {as clause can include arguments} -body {
3426 method wag {adverb} {return "wagged $adverb"}
3430 delegate method wag to tail as {wag briskly}
3432 constructor {args} {
3433 set tail [tail %AUTO%]
3443 } -result {wagged briskly}
3445 test dmethod-2.1 {'using "%c %m"' gets normal behavior} -body {
3447 method wag {adverb} {return "wagged $adverb"}
3451 delegate method wag to tail using {%c %m}
3453 constructor {args} {
3454 set tail [tail %AUTO%]
3464 } -result {wagged briskly}
3466 test dmethod-2.2 {All 'using' conversions are converted} -body {
3467 proc echo {args} { return $args }
3470 delegate method {tail wag} using {echo %% %t %M %m %j %n %w %s %c}
3479 } -result {% ::dog {tail wag} wag tail_wag ::dog::Snit_inst1 ::spot ::spot %c}
3481 test dmethod-2.3 {"%%" is handled properly} -body {
3482 proc echo {args} { join $args "|" }
3485 delegate method wag using {echo %%m %%%m}
3496 test dmethod-2.4 {Method "*" and "using"} -body {
3497 proc echo {args} { join $args "|" }
3500 delegate method * using {echo %m}
3505 list [spot wag] [spot bark loudly]
3509 } -result {wag bark|loudly}
3512 test dmethod-3.1 {component names can be changed dynamically} -body {
3514 method wag {} {return "wagged"}
3518 method wag {} {return "drooped"}
3522 delegate method wag to tail
3524 constructor {args} {
3525 set tail [tail1 %AUTO%]
3528 method switchit {} {
3529 set tail [tail2 %AUTO%]
3544 } -result {wagged drooped}
3546 test dmethod-4.1 {hierarchical method, two tokens} -body {
3548 method wag {} {return "wags tail"}
3553 set tail [tail %AUTO%]
3555 delegate method {wag tail} to tail as wag
3563 } -result {wags tail}
3565 test dmethod-4.2 {hierarchical method, three tokens} -body {
3567 method wag {} {return "wags tail"}
3572 set tail [tail %AUTO%]
3574 delegate method {wag tail proudly} to tail as wag
3578 spot wag tail proudly
3582 } -result {wags tail}
3584 test dmethod-4.3 {hierarchical method, three tokens} -body {
3586 method wag {} {return "wags tail"}
3591 set tail [tail %AUTO%]
3593 delegate method {wag tail really high} to tail as wag
3597 spot wag tail really high
3601 } -result {wags tail}
3603 test dmethod-4.4 {redefinition is OK} -body {
3605 method {wag tail} {} {return "wags tail"}
3606 method {wag briskly} {} {return "wags tail briskly"}
3611 set tail [tail %AUTO%]
3613 delegate method {wag tail} to tail as {wag tail}
3614 delegate method {wag tail} to tail as {wag briskly}
3622 } -result {wags tail briskly}
3624 test dmethod-4.5 {all tokens are used by default} -body {
3626 method wag {} {return "wags tail"}
3631 set tail [tail %AUTO%]
3633 delegate method {tail wag} to tail
3641 } -result {wags tail}
3643 test dmethod-4.6 {last token can be *} -body {
3645 method wag {} {return "wags"}
3646 method droop {} {return "droops"}
3651 set tail [tail %AUTO%]
3653 delegate method {tail *} to tail
3658 list [spot tail wag] [spot tail droop]
3662 } -result {wags droops}
3665 test dmethod-4.7 {except with multiple tokens} -constraints {
3669 method wag {} {return "wags"}
3670 method droop {} {return "droops"}
3675 set tail [tail %AUTO%]
3677 delegate method {tail *} to tail except droop
3682 catch {spot tail droop} result
3684 list [spot tail wag] $result
3688 } -result {wags {"::spot tail droop" is not defined}}
3691 test dmethod-4.8 {except with multiple tokens} -constraints {
3695 method wag {} {return "wags"}
3696 method droop {} {return "droops"}
3701 set tail [tail %AUTO%]
3703 delegate method {tail *} to tail except droop
3708 catch {spot tail droop} result
3710 list [spot tail wag] $result
3714 } -result {wags {unknown subcommand "droop": namespace ::dog::Snit_inst1 does not export any commands}}
3716 test dmethod-4.9 {"*" in the wrong spot} -body {
3718 delegate method {tail * wag} to tail
3722 } -result {Error in "delegate method {tail * wag}...", "*" must be the last token.}
3724 test dmethod-5.1 {prefix/method collision} -body {
3726 delegate method wag to tail
3727 delegate method {wag tail} to tail as wag
3731 } -result {Error in "delegate method {wag tail}...", "wag" has no submethods.}
3733 test dmethod-5.2 {prefix/method collision} -body {
3735 delegate method {wag tail} to tail as wag
3736 delegate method wag to tail
3740 } -result {Error in "delegate method wag...", "wag" has submethods.}
3742 test dmethod-5.3 {prefix/method collision} -body {
3744 delegate method {wag tail} to tail
3745 delegate method {wag tail proudly} to tail as wag
3749 } -result {Error in "delegate method {wag tail proudly}...", "wag tail" has no submethods.}
3751 test dmethod-5.4 {prefix/method collision} -body {
3753 delegate method {wag tail proudly} to tail as wag
3754 delegate method {wag tail} to tail
3758 } -result {Error in "delegate method {wag tail}...", "wag tail" has submethods.}
3760 #-----------------------------------------------------------------------
3763 test doption-1.1 {delegate option to non-existent component} -body {
3765 delegate option -foo to bar
3774 } -result {component "bar" is undefined in ::dog ::spot}
3776 test doption-1.2 {delegating option to existing component: cget} -body {
3778 option -color "black"
3784 constructor {args} {
3785 set catthing ::hershey
3788 delegate option -color to catthing
3798 test doption-1.3 {delegating option to existing component: configure} -body {
3800 option -color "black"
3806 constructor {args} {
3807 set catthing ::hershey
3808 $self configurelist $args
3811 delegate option -color to catthing
3814 dog create spot -color blue
3815 list [spot cget -color] [hershey cget -color]
3819 } -result {blue blue}
3821 test doption-1.4 {delegating unknown options to existing component} -body {
3823 option -color "black"
3829 constructor {args} {
3830 set catthing ::hershey
3832 # Note: must do this after components are defined; this
3834 $self configurelist $args
3837 delegate option * to catthing
3840 dog create spot -color blue
3841 list [spot cget -color] [hershey cget -color]
3845 } -result {blue blue}
3847 test doption-1.5 {can't oncget for delegated option} -body {
3849 delegate option -color to catthing
3855 } -result {Error in "oncget -color...", option "-color" is delegated}
3857 test doption-1.6 {can't onconfigure for delegated option} -body {
3859 delegate option -color to catthing
3861 onconfigure -color {value} { }
3865 } -result {onconfigure -color: option "-color" is delegated}
3867 test doption-1.7 {delegating unknown options to existing component: error} -body {
3869 option -color "black"
3875 constructor {args} {
3876 set catthing ::hershey
3877 $self configurelist $args
3880 delegate option * to catthing
3883 dog create spot -colour blue
3889 } -result {Error in constructor: unknown option "-colour"}
3891 test doption-1.8 {can't delegate local option: order 1} -body {
3893 option -color "black"
3894 delegate option -color to hull
3898 } -result {Error in "delegate option -color...", "-color" has been defined locally}
3900 test doption-1.9 {can't delegate local option: order 2} -body {
3902 delegate option -color to hull
3903 option -color "black"
3907 } -result {Error in "option -color...", cannot define "-color" locally, it has been delegated}
3909 test doption-1.10 {excepted options are caught properly on cget} -body {
3917 delegate option * to tail except {-b -c}
3919 constructor {args} {
3920 set tail [tail %AUTO%]
3926 catch {fifi cget -a} a
3927 catch {fifi cget -b} b
3928 catch {fifi cget -c} c
3934 } -result {a {unknown option "-b"} {unknown option "-c"}}
3936 test doption-1.11 {excepted options are caught properly on configurelist} -body {
3944 delegate option * to tail except {-b -c}
3946 constructor {args} {
3947 set tail [tail %AUTO%]
3953 catch {fifi configurelist {-a 1}} a
3954 catch {fifi configurelist {-b 1}} b
3955 catch {fifi configurelist {-c 1}} c
3961 } -result {{} {unknown option "-b"} {unknown option "-c"}}
3963 test doption-1.12 {excepted options are caught properly on configure, 1} -body {
3971 delegate option * to tail except {-b -c}
3973 constructor {args} {
3974 set tail [tail %AUTO%]
3980 catch {fifi configure -a 1} a
3981 catch {fifi configure -b 1} b
3982 catch {fifi configure -c 1} c
3988 } -result {{} {unknown option "-b"} {unknown option "-c"}}
3990 test doption-1.13 {excepted options are caught properly on configure, 2} -body {
3998 delegate option * to tail except {-b -c}
4000 constructor {args} {
4001 set tail [tail %AUTO%]
4007 catch {fifi configure -a} a
4008 catch {fifi configure -b} b
4009 catch {fifi configure -c} c
4015 } -result {{-a a A a a} {unknown option "-b"} {unknown option "-c"}}
4017 test doption-1.14 {configure query skips excepted options} -body {
4026 delegate option * to tail except {-b -c}
4028 constructor {args} {
4029 set tail [tail %AUTO%]
4039 } -result {{-d d D d d} {-a a A a a}}
4042 #-----------------------------------------------------------------------
4045 test from-1.1 {getting default values} -body {
4050 constructor {args} {
4051 $self configure -foo [from args -foo AAA]
4052 $self configure -bar [from args -bar]
4057 list [spot cget -foo] [spot cget -bar]
4062 test from-1.2 {getting non-default values} -body {
4068 constructor {args} {
4069 $self configure -foo [from args -foo]
4070 $self configure -bar [from args -bar]
4071 $self configure -args $args
4075 dog create spot -foo quux -baz frobnitz -bar frobozz
4076 list [spot cget -foo] [spot cget -bar] [spot cget -args]
4079 } -result {quux frobozz {-baz frobnitz}}
4081 #-----------------------------------------------------------------------
4084 test widgetadaptor-1.1 {creating a widget: hull hijacking} -constraints {
4087 widgetadaptor mylabel {
4088 constructor {args} {
4089 installhull [label $self]
4090 $self configurelist $args
4093 delegate method * to hull
4094 delegate option * to hull
4097 mylabel create .label -text "My Label"
4099 set a [.label cget -text]
4100 set b [hull1.label cget -text]
4107 } -result {{My Label} {My Label}}
4109 test widgetadaptor-1.2 {destroying a widget with destroy} -constraints {
4112 widgetadaptor mylabel {
4114 installhull [label $self]
4118 mylabel create .label
4119 set a [namespace children ::mylabel]
4121 set b [namespace children ::mylabel]
4126 } -result {::mylabel::Snit_inst1 {}}
4128 test widgetadaptor-1.3 {destroying two widgets of the same type with destroy} -constraints {
4131 widgetadaptor mylabel {
4133 installhull [label $self]
4137 mylabel create .lab1
4138 mylabel create .lab2
4139 set a [namespace children ::mylabel]
4142 set b [namespace children ::mylabel]
4147 } -result {{::mylabel::Snit_inst1 ::mylabel::Snit_inst2} {}}
4149 test widgetadaptor-1.4 {destroying a widget with rename, then destroy type} -constraints {
4152 widgetadaptor mylabel {
4154 installhull [label $self]
4158 mylabel create .label
4159 set a [namespace children ::mylabel]
4161 set b [namespace children ::mylabel]
4166 } -result {::mylabel::Snit_inst1 {}}
4168 test widgetadaptor-1.5 {destroying two widgets of the same type with rename} -constraints {
4171 widgetadaptor mylabel {
4173 installhull [label $self]
4177 mylabel create .lab1
4178 mylabel create .lab2
4179 set a [namespace children ::mylabel]
4182 set b [namespace children ::mylabel]
4186 } -result {{::mylabel::Snit_inst1 ::mylabel::Snit_inst2} {}}
4188 test widgetadaptor-1.6 {create/destroy twice, with destroy} -constraints {
4191 widgetadaptor mylabel {
4193 installhull [label $self]
4197 mylabel create .lab1
4198 set a [namespace children ::mylabel]
4201 mylabel create .lab1
4202 set b [namespace children ::mylabel]
4205 set c [namespace children ::mylabel]
4209 } -result {::mylabel::Snit_inst1 ::mylabel::Snit_inst2 {}}
4211 test widgetadaptor-1.7 {create/destroy twice, with rename} -constraints {
4214 widgetadaptor mylabel {
4216 installhull [label $self]
4220 mylabel create .lab1
4221 set a [namespace children ::mylabel]
4224 mylabel create .lab1
4225 set b [namespace children ::mylabel]
4228 set c [namespace children ::mylabel]
4232 } -result {::mylabel::Snit_inst1 ::mylabel::Snit_inst2 {}}
4234 test widgetadaptor-1.8 {"create" is optional} -constraints {
4237 widgetadaptor mylabel {
4238 constructor {args} {
4239 installhull [label $self]
4241 method howdy {} {return "Howdy!"}
4245 set a [.label howdy]
4255 test widgetadaptor-1.9 {"create" is optional, but must be a valid name} -constraints {
4259 widgetadaptor mylabel {
4260 constructor {args} {
4261 installhull [label $self]
4263 method howdy {} {return "Howdy!"}
4266 catch {mylabel foo} result
4271 } -result {"::mylabel foo" is not defined}
4274 test widgetadaptor-1.10 {"create" is optional, but must be a valid name} -constraints {
4278 widgetadaptor mylabel {
4279 constructor {args} {
4280 installhull [label $self]
4282 method howdy {} {return "Howdy!"}
4285 catch {mylabel foo} result
4290 } -result {unknown subcommand "foo": namespace ::mylabel does not export any commands}
4292 test widgetadaptor-1.11 {user-defined destructors are called} -constraints {
4295 widgetadaptor mylabel {
4296 typevariable flag ""
4298 constructor {args} {
4299 installhull [label $self]
4300 set flag "created $self"
4304 set flag "destroyed $self"
4307 typemethod getflag {} {
4313 set a [mylabel getflag]
4316 list $a [mylabel getflag]
4319 } -result {{created .label} {destroyed .label}}
4322 test widgetadaptor-1.12 {destroy method not defined for widget types} -constraints {
4326 widgetadaptor mylabel {
4327 constructor {args} {
4328 installhull [label $self]
4333 catch {.label destroy} result
4339 } -result {".label destroy" is not defined}
4342 test widgetadaptor-1.13 {destroy method not defined for widget types} -constraints {
4346 widgetadaptor mylabel {
4347 constructor {args} {
4348 installhull [label $self]
4353 catch {.label destroy} result
4359 } -result {unknown subcommand "destroy": namespace ::mylabel::Snit_inst1 does not export any commands}
4361 test widgetadaptor-1.14 {hull can be repeatedly renamed} -constraints {
4364 widgetadaptor basetype {
4365 constructor {args} {
4366 installhull [label $self]
4369 method basemethod {} { return "basemethod" }
4373 constructor {args} {
4374 installhull [basetype create $self]
4379 constructor {args} {
4380 installhull [w1 $self]
4394 test widgetadaptor-1.15 {widget names can be generated} -constraints {
4397 widgetadaptor unique {
4398 constructor {args} {
4399 installhull [label $self]
4403 set w [unique .%AUTO%]
4409 } -result {.unique1}
4411 test widgetadaptor-1.16 {snit::widgetadaptor as hull} -constraints {
4414 widgetadaptor mylabel {
4415 constructor {args} {
4416 installhull [label $self]
4417 $self configurelist $args
4422 delegate option * to hull
4425 widgetadaptor mylabel2 {
4426 constructor {args} {
4427 installhull [mylabel $self]
4428 $self configurelist $args
4431 return "method2: [$hull method1]"
4433 delegate option * to hull
4436 mylabel2 .label -text "Some Text"
4437 set a [.label method2]
4438 set b [.label cget -text]
4439 .label configure -text "More Text"
4440 set c [.label cget -text]
4441 set d [namespace children ::mylabel2]
4442 set e [namespace children ::mylabel]
4446 set f [namespace children ::mylabel2]
4447 set g [namespace children ::mylabel]
4453 list $a $b $c $d $e $f $g
4454 } -result {{method2: method1} {Some Text} {More Text} ::mylabel2::Snit_inst1 ::mylabel::Snit_inst1 {} {}}
4456 test widgetadaptor-1.17 {snit::widgetadaptor as hull; use rename} -constraints {
4459 widgetadaptor mylabel {
4460 constructor {args} {
4461 installhull [label $self]
4462 $self configurelist $args
4467 delegate option * to hull
4470 widgetadaptor mylabel2 {
4471 constructor {args} {
4472 installhull [mylabel $self]
4473 $self configurelist $args
4476 return "method2: [$hull method1]"
4478 delegate option * to hull
4481 mylabel2 .label -text "Some Text"
4482 set a [.label method2]
4483 set b [.label cget -text]
4484 .label configure -text "More Text"
4485 set c [.label cget -text]
4486 set d [namespace children ::mylabel2]
4487 set e [namespace children ::mylabel]
4491 set f [namespace children ::mylabel2]
4492 set g [namespace children ::mylabel]
4498 list $a $b $c $d $e $f $g
4499 } -result {{method2: method1} {Some Text} {More Text} ::mylabel2::Snit_inst1 ::mylabel::Snit_inst1 {} {}}
4501 test widgetadaptor-1.18 {BWidget Label as hull} -constraints {
4504 widgetadaptor mylabel {
4505 constructor {args} {
4506 installhull [Label $win]
4507 $self configurelist $args
4509 delegate option * to hull
4512 mylabel .label -text "Some Text"
4513 set a [.label cget -text]
4515 .label configure -text "More Text"
4516 set b [.label cget -text]
4518 set c [namespace children ::mylabel]
4522 set d [namespace children ::mylabel]
4528 } -result {{Some Text} {More Text} ::mylabel::Snit_inst1 {}}
4530 test widgetadaptor-1.19 {error in widgetadaptor constructor} -constraints {
4533 widgetadaptor mylabel {
4534 constructor {args} {
4535 error "Simulated Error"
4544 } -result {Error in constructor: Simulated Error}
4547 #-----------------------------------------------------------------------
4550 # A widget is just a widgetadaptor with an automatically created hull
4551 # component (a Tk frame). So the widgetadaptor tests apply; all we
4552 # need to test here is the frame creation.
4554 test widget-1.1 {creating a widget} -constraints {
4558 method hull {} { return $hull }
4560 delegate method * to hull
4561 delegate option * to hull
4564 myframe create .frm -background green
4566 set a [.frm cget -background]
4574 } -result {green ::hull1.frm}
4576 test widget-2.1 {can't redefine hull} -constraints {
4580 method resethull {} { set hull "" }
4590 } -result {can't set "hull": The hull component cannot be redefined}
4592 #-----------------------------------------------------------------------
4595 # The install command is used to install widget components, while getting
4596 # options for the option database.
4598 test install-1.1 {installed components are created properly} -constraints {
4602 # Delegate an option just to make sure the component variable
4604 delegate option -font to text
4606 constructor {args} {
4607 install text using text $win.text -background green
4611 $win.text cget -background
4624 test install-1.2 {installed components are saved properly} -constraints {
4628 # Delegate an option just to make sure the component variable
4630 delegate option -font to text
4632 constructor {args} {
4633 install text using text $win.text -background green
4637 $text cget -background
4650 test install-1.3 {can't install until hull exists} -constraints {
4653 widgetadaptor myframe {
4654 # Delegate an option just to make sure the component variable
4656 delegate option -font to text
4658 constructor {args} {
4659 install text using text $win.text -background green
4668 } -result {Error in constructor: tried to install "text" before the hull exists}
4670 test install-1.4 {install queries option database} -constraints {
4674 delegate option -font to text
4677 option add *Myframe.font Courier
4680 constructor {args} {
4681 install text using text $win.text
4686 set a [.frm cget -font]
4694 test install-1.5 {explicit options override option database} -constraints {
4698 delegate option -font to text
4701 option add *Myframe.font Courier
4704 constructor {args} {
4705 install text using text $win.text -font Times
4710 set a [.frm cget -font]
4718 test install-1.6 {option db works with targetted options} -constraints {
4722 delegate option -textfont to text as -font
4725 option add *Myframe.textfont Courier
4728 constructor {args} {
4729 install text using text $win.text
4734 set a [.frm cget -textfont]
4742 test install-1.7 {install works for snit::types} -body {
4744 option -tailcolor black
4748 delegate option -tailcolor to tail
4750 constructor {args} {
4751 install tail using tail $self.tail
4756 fido cget -tailcolor
4762 test install-1.8 {install can install non-widget components} -constraints {
4766 option -tailcolor black
4770 delegate option -tailcolor to thedog
4773 option add *Myframe.tailcolor green
4776 constructor {args} {
4777 install thedog using dog $win.dog
4782 set a [.frm cget -tailcolor]
4792 test install-1.9 {ok if no options are delegated to component} -constraints {
4796 option -tailcolor black
4800 constructor {args} {
4801 install thedog using dog $win.dog
4809 # Test passes if no error is raised.
4817 delegate option * for a non-shadowed option. The text widget's
4818 -foreground and -font options should be set according to what's
4819 in the option database on the widgetclass.
4824 delegate option * to text
4827 option add *Myframe.foreground red
4828 option add *Myframe.font {Times 14}
4831 constructor {args} {
4832 install text using text $win.text
4837 set a [.frm cget -foreground]
4838 set b [.frm cget -font]
4845 } -result {red {Times 14}}
4848 Delegate option * for a shadowed option. Foreground is declared
4849 as a non-delegated option, hence it will pick up the option database
4850 default. -foreground is not included in the "delegate option *", so
4851 the text widget's -foreground option will not be set from the
4857 option -foreground white
4858 delegate option * to text
4861 option add *Myframe.foreground red
4864 constructor {args} {
4865 install text using text $win.text
4869 $text cget -foreground
4874 set a [.frm cget -foreground]
4879 expr {![string equal $a $b]}
4885 Delegate option * for a creation option. Because the text widget's
4886 -foreground is set explicitly by the constructor, that always
4887 overrides the option database.
4892 delegate option * to text
4895 option add *Myframe.foreground red
4898 constructor {args} {
4899 install text using text $win.text -foreground blue
4904 set a [.frm cget -foreground]
4914 Delegate option * with an excepted option. Because the text widget's
4915 -state is excepted, it won't be set from the option database.
4920 delegate option * to text except -state
4923 option add *Myframe.foreground red
4924 option add *Myframe.state disabled
4927 constructor {args} {
4928 install text using text $win.text
4931 method getstate {} {
4937 set a [.frm getstate]
4946 #-----------------------------------------------------------------------
4947 # Advanced installhull tests
4949 # installhull is used to install the hull widget for both widgets and
4950 # widget adaptors. It has two forms. In one form it installs a widget
4951 # created by some third party; in this form no querying of the option
4952 # database is needed, because we haven't taken responsibility for creating
4953 # it. But in the other form (installhull using) installhull actually
4954 # creates the widget, and takes responsibility for querying the
4955 # option database as needed.
4957 # NOTE: "installhull using" is always used to create a widget's hull frame.
4959 # That options passed into installhull override those from the
4962 test installhull-1.1 {
4963 options delegated to a widget's hull frame with the same name are
4964 initialized from the option database. Note that there's no
4965 explicit code in Snit to do this; it happens because we set the
4966 -class when the widget was created. In fact, it happens whether
4967 we delegate the option name or not.
4972 delegate option -background to hull
4975 option add *Myframe.background red
4976 option add *Myframe.width 123
4985 set a [.frm cget -background]
4994 test installhull-1.2 {
4995 Options delegated to a widget's hull frame with a different name are
4996 initialized from the option database.
5001 delegate option -mainbackground to hull as -background
5004 option add *Myframe.mainbackground red
5009 set a [.frm cget -mainbackground]
5017 test installhull-1.3 {
5018 options delegated to a widgetadaptor's hull frame with the same name are
5019 initialized from the option database. Note that there's no
5020 explicit code in Snit to do this; there's no way to change the
5021 adapted hull widget's -class, so the widget is simply being
5022 initialized normally.
5026 widgetadaptor myframe {
5027 delegate option -background to hull
5030 option add *Frame.background red
5031 option add *Frame.width 123
5034 constructor {args} {
5035 installhull using frame
5044 set a [.frm cget -background]
5053 test installhull-1.4 {
5054 Options delegated to a widget's hull frame with a different name are
5055 initialized from the option database.
5059 widgetadaptor myframe {
5060 delegate option -mainbackground to hull as -background
5063 option add *Frame.mainbackground red
5066 constructor {args} {
5067 installhull using frame
5072 set a [.frm cget -mainbackground]
5080 test installhull-1.5 {
5081 Option values read from the option database are overridden by options
5082 explicitly passed, even if delegated under a different name.
5086 widgetadaptor myframe {
5087 delegate option -mainbackground to hull as -background
5090 option add *Frame.mainbackground red
5091 option add *Frame.width 123
5094 constructor {args} {
5095 installhull using frame -background green -width 321
5104 set a [.frm cget -mainbackground]
5111 } -result {green 321}
5114 #-----------------------------------------------------------------------
5115 # Instance Introspection
5118 test iinfo-1.1 {object info too few args} -constraints {
5130 } -result [tcltest::wrongNumArgs ::snit::RT.method.info {type selfns win self command args} 4]
5133 test iinfo-1.2 {object info too few args} -constraints {
5146 {wrong # args: should be "spot info command ?arg ...?"} \
5147 {wrong # args: should be "spot info command ..."}]
5149 test iinfo-1.3 {object info too many args} -body {
5159 } -result [tcltest::tooManyArgs ::snit::RT.method.info.type {type selfns win self}]
5161 test iinfo-2.1 {object info type} -body {
5170 test iinfo-3.1 {object info typevars} -body {
5172 typevariable thisvar 1
5174 constructor {args} {
5175 typevariable thatvar 2
5180 lsort [spot info typevars]
5183 } -result {::dog::thatvar ::dog::thisvar}
5185 test iinfo-3.2 {object info typevars with pattern} -body {
5187 typevariable thisvar 1
5189 constructor {args} {
5190 typevariable thatvar 2
5195 spot info typevars *this*
5198 } -result {::dog::thisvar}
5200 test iinfo-4.1 {object info vars} -body {
5204 constructor {args} {
5211 lsort [spot info vars]
5214 } -result {::dog::Snit_inst1::hervar ::dog::Snit_inst1::hisvar}
5216 test iinfo-4.2 {object info vars with pattern} -body {
5220 constructor {args} {
5227 spot info vars "*his*"
5230 } -result {::dog::Snit_inst1::hisvar}
5232 test iinfo-5.1 {object info no vars defined} -body {
5236 list [spot info vars] [spot info typevars]
5241 test iinfo-6.1 {info options with no options} -body {
5245 llength [spot info options]
5250 test iinfo-6.2 {info options with only local options} -body {
5257 lsort [spot info options]
5260 } -result {-bar -foo}
5262 test iinfo-6.3 {info options with local and delegated options} -body {
5266 delegate option -quux to sibling
5270 lsort [spot info options]
5273 } -result {-bar -foo -quux}
5275 test iinfo-6.4 {info options with unknown delegated options} -constraints {
5278 widgetadaptor myframe {
5280 delegate option * to hull
5281 constructor {args} {
5282 installhull [frame $self]
5287 set a [lsort [.frm info options]]
5293 } -result {-background -bd -bg -borderwidth -class -colormap -container -cursor -foo -height -highlightbackground -highlightcolor -highlightthickness -relief -takefocus -visual -width}
5295 test iinfo-6.5 {info options with unknown delegated options} -constraints {
5298 widgetadaptor myframe {
5300 delegate option * to hull
5301 constructor {args} {
5302 installhull [frame $self]
5307 set a [lsort [.frm info options]]
5313 } -result {-background -bd -bg -borderwidth -class -colormap -container -cursor -foo -height -highlightbackground -highlightcolor -highlightthickness -padx -pady -relief -takefocus -visual -width}
5315 test iinfo-6.6 {info options with exceptions} -constraints {
5318 widgetadaptor myframe {
5320 delegate option * to hull except -background
5321 constructor {args} {
5322 installhull [frame $self]
5327 set a [lsort [.frm info options]]
5333 } -result {-bd -bg -borderwidth -class -colormap -container -cursor -foo -height -highlightbackground -highlightcolor -highlightthickness -relief -takefocus -visual -width}
5335 test iinfo-6.7 {info options with exceptions} -constraints {
5338 widgetadaptor myframe {
5340 delegate option * to hull except -background
5341 constructor {args} {
5342 installhull [frame $self]
5347 set a [lsort [.frm info options]]
5353 } -result {-bd -bg -borderwidth -class -colormap -container -cursor -foo -height -highlightbackground -highlightcolor -highlightthickness -padx -pady -relief -takefocus -visual -width}
5355 test iinfo-6.8 {info options with pattern} -constraints {
5358 widgetadaptor myframe {
5360 delegate option * to hull
5361 constructor {args} {
5362 installhull [frame $self]
5367 set a [lsort [.frm info options -c*]]
5373 } -result {-class -colormap -container -cursor}
5375 test iinfo-7.1 {info typemethods, simple case} -body {
5380 lsort [spot info typemethods]
5383 } -result {create destroy info}
5385 test iinfo-7.2 {info typemethods, with pattern} -body {
5390 spot info typemethods i*
5395 test iinfo-7.3 {info typemethods, with explicit typemethods} -body {
5397 typemethod foo {} {}
5398 delegate typemethod bar to comp
5403 lsort [spot info typemethods]
5406 } -result {bar create destroy foo info}
5408 test iinfo-7.4 {info typemethods, with implicit typemethods} -body {
5410 delegate typemethod * to comp
5419 set a [lsort [spot info typemethods]]
5424 set b [lsort [spot info typemethods]]
5426 set c [spot info typemethods len*]
5431 } -result {{create destroy info} {create destroy info is length} length}
5433 test iinfo-7.5 {info typemethods, with hierarchical typemethods} -body {
5435 delegate typemethod {comp foo} to comp
5437 typemethod {comp bar} {} {}
5442 lsort [spot info typemethods]
5445 } -result {{comp bar} {comp foo} create destroy info}
5448 test iinfo-8.1 {info methods, simple case} -body {
5453 lsort [spot info methods]
5456 } -result {destroy info}
5458 test iinfo-8.2 {info methods, with pattern} -body {
5463 spot info methods i*
5468 test iinfo-8.3 {info methods, with explicit methods} -body {
5471 delegate method bar to comp
5476 lsort [spot info methods]
5479 } -result {bar destroy foo info}
5481 test iinfo-8.4 {info methods, with implicit methods} -body {
5483 delegate method * to comp
5485 constructor {args} {
5492 set a [lsort [spot info methods]]
5497 set b [lsort [spot info methods]]
5499 set c [spot info methods len*]
5504 } -result {{destroy info} {destroy info is length} length}
5506 test iinfo-8.5 {info methods, with hierarchical methods} -body {
5508 delegate method {comp foo} to comp
5510 method {comp bar} {} {}
5515 lsort [spot info methods]
5518 } -result {{comp bar} {comp foo} destroy info}
5520 test iinfo-9.1 {info args} -body {
5522 method bark {volume} {}
5532 test iinfo-9.2 {info args, too few args} -body {
5534 method bark {volume} {}
5540 } -returnCodes error -cleanup {
5542 } -result [tcltest::wrongNumArgs ::snit::RT.method.info.args {type selfns win self method} 4]
5544 test iinfo-9.3 {info args, too many args} -body {
5546 method bark {volume} {}
5551 spot info args bark wag
5552 } -returnCodes error -cleanup {
5554 } -result [tcltest::tooManyArgs ::snit::RT.method.info.args {type selfns win self method}]
5556 test iinfo-9.4 {info args, unknown method} -body {
5563 } -returnCodes error -cleanup {
5565 } -result {Unknown method "bark"}
5567 test iinfo-9.5 {info args, delegated method} -body {
5570 delegate method bark to x
5576 } -returnCodes error -cleanup {
5578 } -result {Delegated method "bark"}
5580 test iinfo-10.1 {info default} -body {
5582 method bark {{volume 50}} {}
5587 list [spot info default bark volume def] $def
5592 test iinfo-10.2 {info default, too few args} -body {
5594 method bark {volume} {}
5600 } -returnCodes error -cleanup {
5602 } -result [tcltest::wrongNumArgs ::snit::RT.method.info.default {type selfns win self method aname dvar} 4]
5604 test iinfo-10.3 {info default, too many args} -body {
5606 method bark {volume} {}
5611 spot info default bark wag def foo
5612 } -returnCodes error -cleanup {
5614 } -result [tcltest::tooManyArgs ::snit::RT.method.info.default {type selfns win self method aname dvar}]
5616 test iinfo-10.4 {info default, unknown method} -body {
5622 spot info default bark x var
5623 } -returnCodes error -cleanup {
5625 } -result {Unknown method "bark"}
5627 test iinfo-10.5 {info default, delegated method} -body {
5630 delegate method bark to x
5635 spot info default bark x var
5636 } -returnCodes error -cleanup {
5638 } -result {Delegated method "bark"}
5640 test iinfo-11.1 {info body} -body {
5644 method bark {volume} {
5646 speaker play bark.snd
5658 speaker play bark.snd
5662 test iinfo-11.2 {info body, too few args} -body {
5664 method bark {volume} {}
5670 } -returnCodes error -cleanup {
5672 } -result [tcltest::wrongNumArgs ::snit::RT.method.info.body {type selfns win self method} 4]
5674 test iinfo-11.3 {info body, too many args} -body {
5676 method bark {volume} {}
5681 spot info body bark wag
5682 } -returnCodes error -cleanup {
5684 } -result [tcltest::tooManyArgs ::snit::RT.method.info.body {type selfns win self method}]
5686 test iinfo-11.4 {info body, unknown method} -body {
5693 } -returnCodes error -cleanup {
5695 } -result {Unknown method "bark"}
5697 test iinfo-11.5 {info body, delegated method} -body {
5700 delegate method bark to x
5706 } -returnCodes error -cleanup {
5708 } -result {Delegated method "bark"}
5710 #-----------------------------------------------------------------------
5711 # Type Introspection
5714 test tinfo-1.1 {type info too few args} -constraints {
5724 } -result [tcltest::wrongNumArgs ::snit::RT.typemethod.info {type command args} 1]
5727 test tinfo-1.2 {type info too few args} -constraints {
5738 {wrong # args: should be "dog info command ?arg ...?"} \
5739 {wrong # args: should be "dog info command ..."}]
5741 test tinfo-1.3 {type info too many args} -body {
5744 dog info instances foo bar
5749 } -result [tcltest::tooManyArgs ::snit::RT.typemethod.info.instances {type ?pattern?}]
5751 test tinfo-2.1 {type info typevars} -body {
5753 typevariable thisvar 1
5755 constructor {args} {
5756 typevariable thatvar 2
5761 lsort [dog info typevars]
5764 } -result {::dog::thatvar ::dog::thisvar}
5766 test tinfo-3.1 {type info instances} -body {
5772 lsort [dog info instances]
5775 } -result {::fido ::spot}
5777 test tinfo-3.2 {widget info instances} -constraints {
5780 widgetadaptor mylabel {
5781 constructor {args} {
5782 installhull [label $self]
5789 set result [mylabel info instances]
5798 } -result {.lab1 .lab2}
5800 test tinfo-3.3 {type info instances with non-global namespaces} -body {
5805 namespace eval ::dogs:: {
5806 set ::qname [dog create fido]
5809 list $qname [lsort [dog info instances]]
5812 } -result {::dogs::fido {::dogs::fido ::spot}}
5814 test tinfo-3.4 {type info instances with pattern} -body {
5820 dog info instances "*f*"
5825 test tinfo-3.5 {type info instances with unrelated child namespace, bug 2898640} -body {
5827 namespace eval dog::unrelated {}
5835 test tinfo-4.1 {type info typevars with pattern} -body {
5837 typevariable thisvar 1
5839 constructor {args} {
5840 typevariable thatvar 2
5845 dog info typevars *this*
5848 } -result {::dog::thisvar}
5850 test tinfo-5.1 {type info typemethods, simple case} -body {
5853 lsort [dog info typemethods]
5856 } -result {create destroy info}
5858 test tinfo-5.2 {type info typemethods, with pattern} -body {
5861 dog info typemethods i*
5866 test tinfo-5.3 {type info typemethods, with explicit typemethods} -body {
5868 typemethod foo {} {}
5869 delegate typemethod bar to comp
5872 lsort [dog info typemethods]
5875 } -result {bar create destroy foo info}
5877 test tinfo-5.4 {type info typemethods, with implicit typemethods} -body {
5879 delegate typemethod * to comp
5886 set a [lsort [dog info typemethods]]
5891 set b [lsort [dog info typemethods]]
5893 set c [dog info typemethods len*]
5898 } -result {{create destroy info} {create destroy info is length} length}
5900 test tinfo-5.5 {info typemethods, with hierarchical typemethods} -body {
5902 delegate typemethod {comp foo} to comp
5904 typemethod {comp bar} {} {}
5907 lsort [dog info typemethods]
5910 } -result {{comp bar} {comp foo} create destroy info}
5912 test tinfo-6.1 {type info args} -body {
5914 typemethod bark {volume} {}
5922 test tinfo-6.2 {type info args, too few args} -body {
5924 typemethod bark {volume} {}
5928 } -returnCodes error -cleanup {
5930 } -result [tcltest::wrongNumArgs ::snit::RT.typemethod.info.args {type method} 1]
5932 test tinfo-6.3 {type info args, too many args} -body {
5934 typemethod bark {volume} {}
5937 dog info args bark wag
5938 } -returnCodes error -cleanup {
5940 } -result [tcltest::tooManyArgs ::snit::RT.typemethod.info.args {type method}]
5942 test tinfo-6.4 {type info args, unknown method} -body {
5947 } -returnCodes error -cleanup {
5949 } -result {Unknown typemethod "bark"}
5951 test tinfo-6.5 {type info args, delegated method} -body {
5953 delegate typemethod bark to x
5957 } -returnCodes error -cleanup {
5959 } -result {Delegated typemethod "bark"}
5961 test tinfo-7.1 {type info default} -body {
5963 typemethod bark {{volume 50}} {}
5966 list [dog info default bark volume def] $def
5971 test tinfo-7.2 {type info default, too few args} -body {
5973 typemethod bark {volume} {}
5977 } -returnCodes error -cleanup {
5979 } -result [tcltest::wrongNumArgs ::snit::RT.typemethod.info.default {type method aname dvar} 1]
5981 test tinfo-7.3 {type info default, too many args} -body {
5983 typemethod bark {volume} {}
5986 dog info default bark wag def foo
5987 } -returnCodes error -cleanup {
5989 } -result [tcltest::tooManyArgs ::snit::RT.typemethod.info.default {type method aname dvar}]
5991 test tinfo-7.4 {type info default, unknown method} -body {
5995 dog info default bark x var
5996 } -returnCodes error -cleanup {
5998 } -result {Unknown typemethod "bark"}
6000 test tinfo-7.5 {type info default, delegated method} -body {
6002 delegate typemethod bark to x
6005 dog info default bark x var
6006 } -returnCodes error -cleanup {
6008 } -result {Delegated typemethod "bark"}
6010 test tinfo-8.1 {type info body} -body {
6014 typemethod bark {volume} {
6016 speaker play bark.snd
6026 speaker play bark.snd
6030 test tinfo-8.2 {type info body, too few args} -body {
6032 typemethod bark {volume} {}
6036 } -returnCodes error -cleanup {
6038 } -result [tcltest::wrongNumArgs ::snit::RT.typemethod.info.body {type method} 1]
6040 test tinfo-8.3 {type info body, too many args} -body {
6042 typemethod bark {volume} {}
6045 dog info body bark wag
6046 } -returnCodes error -cleanup {
6048 } -result [tcltest::tooManyArgs ::snit::RT.typemethod.info.body {type method}]
6050 test tinfo-8.4 {type info body, unknown method} -body {
6055 } -returnCodes error -cleanup {
6057 } -result {Unknown typemethod "bark"}
6059 test tinfo-8.5 {type info body, delegated method} -body {
6061 delegate typemethod bark to x
6065 } -returnCodes error -cleanup {
6067 } -result {Delegated typemethod "bark"}
6069 #-----------------------------------------------------------------------
6070 # Setting the widget class explicitly
6072 test widgetclass-1.1 {can't set widgetclass for snit::types} -body {
6078 } -result {widgetclass cannot be set for snit::types}
6080 test widgetclass-1.2 {can't set widgetclass for snit::widgetadaptors} -constraints {
6088 } -result {widgetclass cannot be set for snit::widgetadaptors}
6090 test widgetclass-1.3 {widgetclass must begin with uppercase letter} -constraints {
6098 } -result {widgetclass "dog" does not begin with an uppercase letter}
6100 test widgetclass-1.4 {widgetclass can only be defined once} -constraints {
6109 } -result {too many widgetclass statements}
6111 test widgetclass-1.5 {widgetclass set successfully} -constraints {
6115 widgetclass DogWidget
6118 # The test passes if no error is thrown.
6124 test widgetclass-1.6 {implicit widgetclass applied to hull} -constraints {
6129 option add *Dog.background green
6132 method background {} {
6133 $hull cget -background
6139 set bg [.dog background]
6148 test widgetclass-1.7 {explicit widgetclass applied to hull} -constraints {
6152 widgetclass DogWidget
6155 option add *DogWidget.background green
6158 method background {} {
6159 $hull cget -background
6165 set bg [.dog background]
6174 #-----------------------------------------------------------------------
6175 # hulltype statement
6177 test hulltype-1.1 {can't set hulltype for snit::types} -body {
6183 } -result {hulltype cannot be set for snit::types}
6185 test hulltype-1.2 {can't set hulltype for snit::widgetadaptors} -constraints {
6193 } -result {hulltype cannot be set for snit::widgetadaptors}
6195 test hulltype-1.3 {hulltype can be frame} -constraints {
6199 delegate option * to hull
6204 catch {.fido configure -use} result
6211 } -result {unknown option "-use"}
6213 test hulltype-1.4 {hulltype can be toplevel} -constraints {
6217 delegate option * to hull
6222 catch {.fido configure -use} result
6229 } -result {-use use Use {} {}}
6231 test hulltype-1.5 {hulltype can only be defined once} -constraints {
6240 } -result {too many hulltype statements}
6242 test hulltype-2.1 {list of valid hulltypes} -constraints {
6245 lsort $::snit::hulltypes
6246 } -result {frame labelframe tk::frame tk::labelframe tk::toplevel toplevel ttk::frame ttk::labelframe}
6249 #-----------------------------------------------------------------------
6252 test expose-1.1 {can't expose nothing} -body {
6260 } -result [tcltest::wrongNumArgs ::snit::Comp.statement.expose {component ?as? ?methodname?} 0]
6262 test expose-1.1a {can't expose nothing} -body {
6270 } -result [tcltest::wrongNumArgs expose {component ?as? ?methodname?} 0]
6272 test expose-1.2 {expose a component that's never installed} -body {
6284 } -result {undefined component "tail"}
6286 test expose-1.3 {exposed method returns component command} -body {
6293 install tail using tail $self.tail
6307 } -result {::fido.tail}
6309 test expose-1.4 {exposed method calls component methods} -body {
6311 method wag {args} {return "wag<$args>"}
6312 method droop {} {return "droop"}
6319 install tail using tail $self.tail
6329 list [fido tail wag] [fido tail wag abc] [fido tail wag abc def] \
6334 } -result {wag<> wag<abc> {wag<abc def>} droop}
6336 #-----------------------------------------------------------------------
6339 # This section verifies that errorInfo and errorCode are propagated
6340 # appropriately on error.
6342 test error-1.1 {typemethod errors propagate properly} -body {
6344 typemethod generr {} {
6345 error bogusError bogusInfo bogusCode
6349 catch {dog generr} result
6351 global errorInfo errorCode
6353 list $result [string match "*bogusInfo*" $errorInfo] $errorCode
6356 } -result {bogusError 1 bogusCode}
6358 test error-1.2 {snit::type constructor errors propagate properly} -body {
6361 error bogusError bogusInfo bogusCode
6365 catch {dog fido} result
6367 global errorInfo errorCode
6369 list $result [string match "*bogusInfo*" $errorInfo] $errorCode
6372 } -result {{Error in constructor: bogusError} 1 bogusCode}
6374 test error-1.3 {snit::widget constructor errors propagate properly} -constraints {
6378 constructor {args} {
6379 error bogusError bogusInfo bogusCode
6383 catch {dog .fido} result
6385 global errorInfo errorCode
6387 list $result [string match "*bogusInfo*" $errorInfo] $errorCode
6390 } -result {{Error in constructor: bogusError} 1 bogusCode}
6392 test error-1.4 {method errors propagate properly} -body {
6395 error bogusError bogusInfo bogusCode
6400 catch {fido generr} result
6402 global errorInfo errorCode
6404 list $result [string match "*bogusInfo*" $errorInfo] $errorCode
6407 } -result {bogusError 1 bogusCode}
6409 test error-1.5 {onconfigure errors propagate properly} -body {
6413 onconfigure -generr {value} {
6414 error bogusError bogusInfo bogusCode
6419 catch {fido configure -generr 0} result
6421 global errorInfo errorCode
6423 list $result [string match "*bogusInfo*" $errorInfo] $errorCode
6426 } -result {bogusError 1 bogusCode}
6428 test error-1.6 {oncget errors propagate properly} -body {
6433 error bogusError bogusInfo bogusCode
6438 catch {fido cget -generr} result
6440 global errorInfo errorCode
6442 list $result [string match "*bogusInfo*" $errorInfo] $errorCode
6445 } -result {bogusError 1 bogusCode}
6447 #-----------------------------------------------------------------------
6448 # Externally defined typemethods
6450 test etypemethod-1.1 {external typemethods can be called as expected} -body {
6452 typemethod dog foo {a} {return "+$a+"}
6459 test etypemethod-1.2 {external typemethods can use typevariables} -body {
6461 typevariable somevar "Howdy"
6463 typemethod dog getvar {} {return $somevar}
6470 test etypemethod-1.3 {typemethods can be redefined dynamically} -body {
6472 typemethod foo {} { return "foo" }
6476 typemethod dog foo {} { return "bar"}
6485 test etypemethod-1.4 {can't define external typemethod if no type} -body {
6486 typemethod extremelyraredog foo {} { return "bar"}
6489 } -result {no such type: "extremelyraredog"}
6491 test etypemethod-2.1 {external hierarchical method, two tokens} -body {
6493 typemethod dog {wag tail} {} {
6500 } -result {wags tail}
6502 test etypemethod-2.2 {external hierarchical method, three tokens} -body {
6504 typemethod dog {wag tail proudly} {} {
6505 return "wags tail proudly"
6508 dog wag tail proudly
6511 } -result {wags tail proudly}
6513 test etypemethod-2.3 {external hierarchical method, three tokens} -body {
6515 typemethod dog {wag tail really high} {} {
6516 return "wags tail really high"
6519 dog wag tail really high
6522 } -result {wags tail really high}
6524 test etypemethod-2.4 {redefinition is OK} -body {
6526 typemethod dog {wag tail} {} {
6529 typemethod dog {wag tail} {} {
6530 return "wags tail briskly"
6536 } -result {wags tail briskly}
6538 test etypemethod-3.1 {prefix/method collision} -body {
6540 typemethod wag {} {}
6543 typemethod dog {wag tail} {} {}
6548 } -result {Cannot define "wag tail", "wag" has no submethods.}
6550 test etypemethod-3.2 {prefix/method collision} -body {
6552 typemethod {wag tail} {} {}
6555 typemethod dog wag {} {}
6560 } -result {Cannot define "wag", "wag" has submethods.}
6562 test etypemethod-3.3 {prefix/method collision} -body {
6564 typemethod {wag tail} {} {}
6567 typemethod dog {wag tail proudly} {} {}
6572 } -result {Cannot define "wag tail proudly", "wag tail" has no submethods.}
6574 test etypemethod-3.4 {prefix/method collision} -body {
6576 typemethod {wag tail proudly} {} {}
6579 typemethod dog {wag tail} {} {}
6584 } -result {Cannot define "wag tail", "wag tail" has submethods.}
6586 #-----------------------------------------------------------------------
6587 # Externally defined methods
6589 test emethod-1.1 {external methods can be called as expected} -body {
6591 method dog bark {a} {return "+$a+"}
6599 test emethod-1.2 {external methods can use typevariables} -body {
6601 typevariable somevar "Hello"
6603 method dog getvar {} {return $somevar}
6611 test emethod-1.3 {external methods can use variables} -body {
6613 variable somevar "Greetings"
6615 method dog getvar {} {return $somevar}
6621 } -result {Greetings}
6623 test emethod-1.4 {methods can be redefined dynamically} -body {
6625 method bark {} { return "woof" }
6632 method dog bark {} { return "arf"}
6639 } -result {woof arf}
6641 test emethod-1.5 {delegated methods can't be redefined} -body {
6643 delegate method bark to someotherdog
6646 method dog bark {} { return "arf"}
6651 } -result {Cannot define "bark", "bark" has been delegated}
6653 test emethod-1.6 {can't define external method if no type} -body {
6654 method extremelyraredog foo {} { return "bar"}
6657 } -result {no such type: "extremelyraredog"}
6659 test emethod-2.1 {external hierarchical method, two tokens} -body {
6661 method dog {wag tail} {} {
6662 return "$self wags tail."
6669 } -result {::spot wags tail.}
6671 test emethod-2.2 {external hierarchical method, three tokens} -body {
6673 method dog {wag tail proudly} {} {
6674 return "$self wags tail proudly."
6678 spot wag tail proudly
6681 } -result {::spot wags tail proudly.}
6683 test emethod-2.3 {external hierarchical method, three tokens} -body {
6685 method dog {wag tail really high} {} {
6686 return "$self wags tail really high."
6690 spot wag tail really high
6693 } -result {::spot wags tail really high.}
6695 test emethod-2.4 {redefinition is OK} -body {
6697 method dog {wag tail} {} {
6698 return "$self wags tail."
6700 method dog {wag tail} {} {
6701 return "$self wags tail briskly."
6708 } -result {::spot wags tail briskly.}
6710 test emethod-3.1 {prefix/method collision} -body {
6715 method dog {wag tail} {} {
6716 return "$self wags tail."
6722 } -result {Cannot define "wag tail", "wag" has no submethods.}
6724 test emethod-3.2 {prefix/method collision} -body {
6726 method {wag tail} {} {
6727 return "$self wags tail."
6731 method dog wag {} {}
6736 } -result {Cannot define "wag", "wag" has submethods.}
6738 test emethod-3.3 {prefix/method collision} -body {
6740 method {wag tail} {} {}
6743 method dog {wag tail proudly} {} {
6744 return "$self wags tail."
6750 } -result {Cannot define "wag tail proudly", "wag tail" has no submethods.}
6752 test emethod-3.4 {prefix/method collision} -body {
6754 method {wag tail proudly} {} {
6755 return "$self wags tail."
6759 method dog {wag tail} {} {}
6764 } -result {Cannot define "wag tail", "wag tail" has submethods.}
6767 #-----------------------------------------------------------------------
6770 test macro-1.1 {can't redefine non-macros} -body {
6771 snit::macro method {} {}
6774 } -result {invalid macro name "method"}
6776 test macro-1.2 {can define and use a macro} -body {
6777 snit::macro hello {name} {
6778 method hello {} "return {Hello, $name!}"
6791 } -result {Hello, World!}
6793 test macro-1.3 {can redefine macro} -body {
6794 snit::macro dup {} {}
6795 snit::macro dup {} {}
6797 set dummy "No error"
6798 } -result {No error}
6800 test macro-1.4 {can define macro in namespace} -body {
6801 snit::macro ::test::goodbye {name} {
6802 method goodbye {} "return {Goodbye, $name!}"
6806 ::test::goodbye World
6814 } -result {Goodbye, World!}
6816 test macro-1.5 {_proc and _variable are defined} -body {
6817 snit::macro testit {} {
6818 set a [info commands _variable]
6819 set b [info commands _proc]
6820 method testit {} "list $a $b"
6832 } -result {_variable _proc}
6834 test macro-1.6 {_variable works} -body {
6835 snit::macro test1 {} {
6836 _variable myvar "_variable works"
6839 snit::macro test2 {} {
6842 method testit {} "return {$myvar}"
6855 } -result {_variable works}
6857 #-----------------------------------------------------------------------
6858 # Component Statement
6860 test component-1.1 {component defines an instance variable} -body {
6867 namespace tail [spot info vars tail]
6872 test component-1.2 {-public exposes the component} -body {
6880 component tail -public mytail
6883 set tail [tail %AUTO%]
6893 } -result {Wag, wag}
6895 test component-1.3 {-inherit requires a boolean value} -body {
6897 component animal -inherit foo
6901 } -result {component animal -inherit: expected boolean value, got "foo"}
6903 test component-1.4 {-inherit delegates unknown methods to the component} -body {
6911 component animal -inherit yes
6914 set animal [animal %AUTO%]
6924 } -result {Eat, eat.}
6926 test component-1.5 {-inherit delegates unknown options to the component} -body {
6932 component animal -inherit yes
6935 set animal [animal %AUTO%]
6947 #-----------------------------------------------------------------------
6948 # Typevariables, Variables, Typecomponents, Components
6950 test typevar_var-1.1 {variable/typevariable collisions not allowed: order 1} -body {
6957 } -result {Error in "variable var...", "var" is already a typevariable}
6959 test typevar_var-1.2 {variable/typevariable collisions not allowed: order 2} -body {
6966 } -result {Error in "typevariable var...", "var" is already an instance variable}
6968 test typevar_var-1.3 {component/typecomponent collisions not allowed: order 1} -body {
6975 } -result {Error in "component comp...", "comp" is already a typevariable}
6977 test typevar_var-1.4 {component/typecomponent collisions not allowed: order 2} -body {
6984 } -result {Error in "typecomponent comp...", "comp" is already an instance variable}
6986 test typevar_var-1.5 {can't delegate options to typecomponents} -body {
6990 delegate option -opt to comp
6994 } -result {Error in "delegate option -opt...", "comp" is already a typevariable}
6996 test typevar_var-1.6 {can't delegate typemethods to instance components} -body {
7000 delegate typemethod foo to comp
7004 } -result {Error in "delegate typemethod foo...", "comp" is already an instance variable}
7006 test typevar_var-1.7 {can delegate methods to typecomponents} -body {
7007 proc echo {args} {return [join $args "|"]}
7016 delegate method wag to tail
7024 } -result {wag|briskly}
7026 #-----------------------------------------------------------------------
7027 # Option syntax tests.
7029 # This set of tests verifies that the option statement is interpreted
7030 # properly, that errors are caught, and that the type's optionInfo
7031 # array is initialized properly.
7033 # TBD: At some point, this needs to be folded into the regular
7036 test optionsyntax-1.1 {local option names are saved} -body {
7042 set ::dog::Snit_optionInfo(local)
7045 } -result {-foo -bar}
7047 test optionsyntax-1.2 {islocal flag is set} -body {
7052 set ::dog::Snit_optionInfo(islocal--foo)
7057 test optionsyntax-2.1 {implicit resource and class} -body {
7063 $::dog::Snit_optionInfo(resource--foo) \
7064 $::dog::Snit_optionInfo(class--foo)
7069 test optionsyntax-2.2 {explicit resource, default class} -body {
7075 $::dog::Snit_optionInfo(resource--foo) \
7076 $::dog::Snit_optionInfo(class--foo)
7079 } -result {ffoo Ffoo}
7081 test optionsyntax-2.3 {explicit resource and class} -body {
7083 option {-foo ffoo FFoo}
7087 $::dog::Snit_optionInfo(resource--foo) \
7088 $::dog::Snit_optionInfo(class--foo)
7091 } -result {ffoo FFoo}
7093 test optionsyntax-2.4 {can't redefine explicit resource} -body {
7100 } -result {Error in "option {-foo foo}...", resource name redefined from "ffoo" to "foo"}
7102 test optionsyntax-2.5 {can't redefine explicit class} -body {
7104 option {-foo ffoo Ffoo}
7105 option {-foo ffoo FFoo}
7109 } -result {Error in "option {-foo ffoo FFoo}...", class name redefined from "Ffoo" to "FFoo"}
7111 test optionsyntax-2.6 {can redefine implicit resource and class} -body {
7115 option {-foo ffoo FFoo}
7122 test optionsyntax-3.1 {no default value} -body {
7127 set ::dog::Snit_optionInfo(default--foo)
7132 test optionsyntax-3.2 {default value, old syntax} -body {
7137 set ::dog::Snit_optionInfo(default--foo)
7142 test optionsyntax-3.3 {option definition options can be set} -body {
7146 -validatemethod Validate \
7147 -configuremethod Configure \
7153 $::dog::Snit_optionInfo(default--foo) \
7154 $::dog::Snit_optionInfo(validate--foo) \
7155 $::dog::Snit_optionInfo(configure--foo) \
7156 $::dog::Snit_optionInfo(cget--foo) \
7157 $::dog::Snit_optionInfo(readonly--foo)
7160 } -result {Bar Validate Configure Cget 1}
7162 test optionsyntax-3.4 {option definition option values accumulate} -body {
7164 option -foo -default Bar
7165 option -foo -validatemethod Validate
7166 option -foo -configuremethod Configure
7167 option -foo -cgetmethod Cget
7168 option -foo -readonly 1
7172 $::dog::Snit_optionInfo(default--foo) \
7173 $::dog::Snit_optionInfo(validate--foo) \
7174 $::dog::Snit_optionInfo(configure--foo) \
7175 $::dog::Snit_optionInfo(cget--foo) \
7176 $::dog::Snit_optionInfo(readonly--foo)
7179 } -result {Bar Validate Configure Cget 1}
7181 test optionsyntax-3.5 {option definition option values can be redefined} -body {
7183 option -foo -default Bar
7184 option -foo -validatemethod Validate
7185 option -foo -configuremethod Configure
7186 option -foo -cgetmethod Cget
7187 option -foo -readonly 1
7188 option -foo -default Bar2
7189 option -foo -validatemethod Validate2
7190 option -foo -configuremethod Configure2
7191 option -foo -cgetmethod Cget2
7192 option -foo -readonly 0
7196 $::dog::Snit_optionInfo(default--foo) \
7197 $::dog::Snit_optionInfo(validate--foo) \
7198 $::dog::Snit_optionInfo(configure--foo) \
7199 $::dog::Snit_optionInfo(cget--foo) \
7200 $::dog::Snit_optionInfo(readonly--foo)
7203 } -result {Bar2 Validate2 Configure2 Cget2 0}
7205 test optionsyntax-3.6 {option -readonly defaults to 0} -body {
7210 set ::dog::Snit_optionInfo(readonly--foo)
7215 test optionsyntax-3.7 {option -readonly can be any boolean} -body {
7217 option -foo -readonly 0
7218 option -foo -readonly 1
7219 option -foo -readonly y
7220 option -foo -readonly n
7226 test optionsyntax-3.8 {option -readonly must be a boolean} -body {
7228 option -foo -readonly foo
7232 } -result {Error in "option -foo...", -readonly requires a boolean, got "foo"}
7234 test optionsyntax-3.9 {option -readonly can't be empty} -body {
7236 option -foo -readonly {}
7240 } -result {Error in "option -foo...", -readonly requires a boolean, got ""}
7242 #-----------------------------------------------------------------------
7243 # 'delegate option' Syntax tests.
7245 # This set of tests verifies that the 'delegation option' statement is
7246 # interpreted properly, and that the type's optionInfo
7247 # array is initialized properly.
7249 # TBD: At some point, this needs to be folded into the regular
7252 test delegateoptionsyntax-1.1 {'delegated' lists delegated option names} -body {
7254 delegate option -foo to comp
7255 delegate option -bar to comp
7258 set ::dog::Snit_optionInfo(delegated)
7261 } -result {-foo -bar}
7263 test delegateoptionsyntax-1.2 {'delegated' does not include '*'} -body {
7265 delegate option * to comp
7268 set ::dog::Snit_optionInfo(delegated)
7273 test delegateoptionsyntax-1.3 {'islocal' is set to 0} -body {
7275 delegate option -foo to comp
7278 set ::dog::Snit_optionInfo(islocal--foo)
7283 test delegateoptionsyntax-1.4 {'islocal' is not set for '*'} -body {
7285 delegate option * to comp
7288 info exists ::dog::Snit_optionInfo(islocal-*)
7293 test delegateoptionsyntax-1.5 {'delegated-$comp' lists options for the component} -body {
7295 delegate option -foo to comp1
7296 delegate option -bar to comp1
7297 delegate option -baz to comp2
7299 # The * won't show up.
7300 delegate option * to comp2
7304 $::dog::Snit_optionInfo(delegated-comp1) \
7305 $::dog::Snit_optionInfo(delegated-comp2)
7308 } -result {{-foo -bar} -baz}
7310 test delegateoptionsyntax-1.6 {'except' is empty by default} -body {
7312 delegate option -foo to comp
7315 set ::dog::Snit_optionInfo(except)
7320 test delegateoptionsyntax-1.7 {'except' lists exceptions} -body {
7322 delegate option * to comp except {-foo -bar -baz}
7325 set ::dog::Snit_optionInfo(except)
7328 } -result {-foo -bar -baz}
7330 test delegateoptionsyntax-1.8 {'target-$opt' set with default} -body {
7332 delegate option -foo to comp
7335 set ::dog::Snit_optionInfo(target--foo)
7338 } -result {comp -foo}
7340 test delegateoptionsyntax-1.9 {'target-$opt' set explicitly} -body {
7342 delegate option -foo to comp as -bar
7345 set ::dog::Snit_optionInfo(target--foo)
7348 } -result {comp -bar}
7350 test delegateoptionsyntax-1.10 {'starcomp' is {} by default} -body {
7352 delegate option -foo to comp
7355 set ::dog::Snit_optionInfo(starcomp)
7360 test delegateoptionsyntax-1.11 {'starcomp' set for *} -body {
7362 delegate option * to comp
7365 set ::dog::Snit_optionInfo(starcomp)
7370 test delegatedoptionsyntax-2.1 {implicit resource and class} -body {
7372 delegate option -foo to comp
7376 $::dog::Snit_optionInfo(resource--foo) \
7377 $::dog::Snit_optionInfo(class--foo)
7382 test delegatedoptionsyntax-2.2 {explicit resource, default class} -body {
7384 delegate option {-foo ffoo} to comp
7388 $::dog::Snit_optionInfo(resource--foo) \
7389 $::dog::Snit_optionInfo(class--foo)
7392 } -result {ffoo Ffoo}
7394 test delegatedoptionsyntax-2.3 {explicit resource and class} -body {
7396 delegate option {-foo ffoo FFoo} to comp
7400 $::dog::Snit_optionInfo(resource--foo) \
7401 $::dog::Snit_optionInfo(class--foo)
7404 } -result {ffoo FFoo}
7406 test delegatedoptionsyntax-2.4 {* doesn't get resource and class} -body {
7408 delegate option * to comp
7412 [info exist ::dog::Snit_optionInfo(resource-*)] \
7413 [info exist ::dog::Snit_optionInfo(class-*)]
7418 #-----------------------------------------------------------------------
7421 test cgetcache-1.1 {Instance rename invalidates cache} -body {
7423 option -foo -default bar -cgetmethod getfoo
7425 method getfoo {option} {
7426 return $options($option)
7432 # Cache the cget command.
7442 test cgetcache-1.2 {Component rename invalidates cache} -body {
7448 delegate option -foo to tail
7450 constructor {args} {
7451 set tail [tail %AUTO%]
7452 $tail configure -foo quux
7456 set tail [tail %AUTO%]
7462 # Cache the cget command.
7465 # Invalidate the cache
7475 test cgetcache-1.3 {Invalid -cgetmethod causes error} -constraints {
7479 option -foo -default bar -cgetmethod bogus
7489 } -result {can't cget -foo, "::fido bogus" is not defined}
7492 test cgetcache-1.4 {Invalid -cgetmethod causes error} -constraints {
7496 option -foo -default bar -cgetmethod bogus
7506 } -result {unknown subcommand "bogus": must be cget, or configurelist}
7508 test cgetcache-1.5 {hierarchical -cgetmethod} -body {
7510 option -foo -default bar -cgetmethod {Get Opt}
7512 method {Get Opt} {option} {
7524 #-----------------------------------------------------------------------
7527 test configurecache-1.1 {Instance rename invalidates cache} -body {
7529 option -foo -default bar -configuremethod setfoo
7531 method setfoo {option value} {
7532 $self setoption $option $value
7535 method setoption {option value} {
7536 set options($option) $value
7540 # Set the option on creation; this will cache the
7541 # configure command.
7546 spot configure -foo baz
7552 test configurecache-1.2 {Component rename invalidates cache} -body {
7558 delegate option -foo to tail
7560 constructor {args} {
7561 set tail [tail thistail]
7562 $self configurelist $args
7566 # Give it a new component
7567 set tail [tail thattail]
7571 # Set the tail's -foo, and cache the command.
7574 # Invalidate the cache
7577 # Should recache, and set the new tail's option.
7578 fido configure -foo baz
7587 test configurecache-1.3 {Invalid -configuremethod causes error} -constraints {
7591 option -foo -default bar -configuremethod bogus
7595 fido configure -foo quux
7600 } -result {can't configure -foo, "::fido bogus" is not defined}
7603 test configurecache-1.4 {Invalid -configuremethod causes error} -constraints {
7607 option -foo -default bar -configuremethod bogus
7611 fido configure -foo quux
7616 } -result {unknown subcommand "bogus": must be configure, or configurelist}
7618 test configurecache-1.5 {hierarchical -configuremethod} -body {
7620 option -foo -default bar -configuremethod {Set Opt}
7622 method {Set Opt} {option value} {
7623 set options($option) Dummy
7627 dog fido -foo NotDummy
7635 #-----------------------------------------------------------------------
7636 # option -validatemethod
7638 test validatemethod-1.1 {Validate method is called} -body {
7644 -validatemethod ValidateColor
7646 method ValidateColor {option value} {
7655 dog fido -color brown
7661 test validatemethod-1.2 {Validate method gets correct arguments} -body {
7665 -validatemethod ValidateColor
7667 method ValidateColor {option value} {
7668 if {![string equal $option "-color"] ||
7669 ![string equal $value "brown"]} {
7670 error "Expected '-color brown'"
7675 dog fido -color brown
7681 test validatemethod-1.3 {Invalid -validatemethod causes error} -constraints {
7685 option -foo -default bar -validatemethod bogus
7689 fido configure -foo quux
7694 } -result {can't validate -foo, "::fido bogus" is not defined}
7697 test validatemethod-1.4 {Invalid -validatemethod causes error} -constraints {
7701 option -foo -default bar -validatemethod bogus
7705 fido configure -foo quux
7710 } -result {unknown subcommand "bogus": must be configure, or configurelist}
7712 test validatemethod-1.5 {hierarchical -validatemethod} -body {
7714 option -foo -default bar -validatemethod {Val Opt}
7716 method {Val Opt} {option value} {
7726 } -result {Error in constructor: Dummy}
7730 #-----------------------------------------------------------------------
7731 # option -readonly semantics
7733 test optionreadonly-1.1 {Readonly options can be set at creation time} -body {
7740 dog fido -color brown
7747 test optionreadonly-1.2 {Readonly options can't be set after creation} -body {
7756 fido configure -color brown
7761 } -result {option -color can only be set at instance creation}
7763 test optionreadonly-1.3 {Readonly options can't be set after creation} -body {
7770 dog fido -color yellow
7772 fido configure -color brown
7777 } -result {option -color can only be set at instance creation}
7779 #-----------------------------------------------------------------------
7780 # Pragma -hastypeinfo
7782 test hastypeinfo-1.1 {$type info is defined by default} -body {
7790 } -result {::dog::foo}
7793 test hastypeinfo-1.2 {$type info can be disabled} -constraints {
7797 pragma -hastypeinfo no
7806 } -result {"::dog info" is not defined}
7809 test hastypeinfo-1.3 {$type info can be disabled} -constraints {
7813 pragma -hastypeinfo no
7822 } -result {unknown subcommand "info": namespace ::dog does not export any commands}
7825 #-----------------------------------------------------------------------
7826 # Pragma -hastypedestroy
7828 test hastypedestroy-1.1 {$type destroy is defined by default} -body {
7838 } -result {invalid command name "::dog"}
7841 test hastypedestroy-1.2 {$type destroy can be disabled} -constraints {
7845 pragma -hastypedestroy no
7854 namespace delete ::dog
7855 } -result {"::dog destroy" is not defined}
7858 test hastypedestroy-1.3 {$type destroy can be disabled} -constraints {
7862 pragma -hastypedestroy no
7871 namespace delete ::dog
7872 } -result {unknown subcommand "destroy": namespace ::dog does not export any commands}
7874 #-----------------------------------------------------------------------
7875 # Pragma -hasinstances
7877 test hasinstances-1.1 {-hasinstances is true by default} -body {
7891 test hasinstances-1.2 {'-hasinstances no' disables explicit object creation} -constraints {
7895 pragma -hasinstances no
7903 } -result {"::dog create" is not defined}
7906 test hasinstances-1.3 {'-hasinstances no' disables explicit object creation} -constraints {
7910 pragma -hasinstances no
7918 } -result {unknown subcommand "create": namespace ::dog does not export any commands}
7921 test hasinstances-1.4 {'-hasinstances no' disables implicit object creation} -constraints {
7925 pragma -hasinstances no
7931 } -result {"::dog fido" is not defined}
7934 test hasinstances-1.5 {'-hasinstances no' disables implicit object creation} -constraints {
7938 pragma -hasinstances no
7944 } -result {unknown subcommand "fido": namespace ::dog does not export any commands}
7946 #-----------------------------------------------------------------------
7947 # pragma -canreplace
7949 test canreplace-1.1 {By default, "-canreplace no"} -body {
7960 } -result {command "::fido" already exists}
7962 test canreplace-1.2 {Can replace commands when "-canreplace yes"} -constraints {
7966 pragma -canreplace yes
7975 #-----------------------------------------------------------------------
7978 test hasinfo-1.1 {$obj info is defined by default} -body {
7987 } -result {::dog::Snit_inst1::foo}
7990 test hasinfo-1.2 {$obj info can be disabled} -constraints {
8004 } -result {"::spot info" is not defined}
8007 test hasinfo-1.3 {$obj info can be disabled} -constraints {
8021 } -result {unknown subcommand "info": namespace ::dog::Snit_inst1 does not export any commands}
8023 #-----------------------------------------------------------------------
8024 # pragma -hastypemethods
8026 # The "-hastypemethods yes" case is tested by the bulk of this file.
8027 # We'll test the "-hastypemethods no" case here.
8029 test hastypemethods-1.1 {-hastypemethods no, $type foo creates instance.} -body {
8031 pragma -hastypemethods no
8039 namespace delete ::dog
8042 test hastypemethods-1.2 {-hastypemethods no, $type create foo fails.} -body {
8044 pragma -hastypemethods no
8053 namespace delete ::dog
8054 } -result "Error in constructor: [tcltest::tooManyArgs ::dog::Snit_constructor {type selfns win self}]"
8056 test hastypemethods-1.3 {-hastypemethods no, $type info fails.} -body {
8058 pragma -hastypemethods no
8067 namespace delete ::dog
8068 } -result {command "::info" already exists}
8070 test hastypemethods-1.4 {-hastypemethods no, [$widget] fails.} -constraints {
8074 pragma -hastypemethods no
8083 namespace delete ::dog
8084 } -result {wrong # args: should be "::dog name args"}
8086 test hastypemethods-1.5 {-hastypemethods no, -hasinstances no fails.} -body {
8088 pragma -hastypemethods no
8089 pragma -hasinstances no
8094 } -result {type ::dog has neither typemethods nor instances}
8096 #-----------------------------------------------------------------------
8097 # -simpledispatch yes
8099 test simpledispatch-1.1 {not allowed with method delegation.} -constraints {
8103 pragma -simpledispatch yes
8105 delegate method foo to bar
8109 } -result {type ::dog requests -simpledispatch but delegates methods.}
8111 test simpledispatch-1.2 {normal methods work with simpledispatch.} -constraints {
8115 pragma -simpledispatch yes
8117 method barks {how} {
8118 return "$self barks $how."
8126 } -result {::spot barks loudly.}
8128 test simpledispatch-1.3 {option methods work with simpledispatch.} -constraints {
8132 pragma -simpledispatch yes
8138 set a [spot cget -breed]
8139 spot configure -breed collie
8140 set b [spot cget -breed]
8141 spot configurelist [list -breed sheltie]
8142 set c [spot cget -breed]
8147 } -result {mutt collie sheltie}
8149 test simpledispatch-1.4 {info method works with simpledispatch.} -constraints {
8153 pragma -simpledispatch yes
8165 test simpledispatch-1.5 {destroy method works with simpledispatch.} -constraints {
8169 pragma -simpledispatch yes
8175 set a [info commands ::spot]
8177 set b [info commands ::spot]
8181 } -result {::spot {}}
8183 test simpledispatch-1.6 {no hierarchical methods with simpledispatch.} -constraints {
8187 pragma -simpledispatch yes
8189 method {wag tail} {} {}
8193 } -result {type ::dog requests -simpledispatch but defines hierarchical methods.}
8195 #-----------------------------------------------------------------------
8196 # Exotic return codes
8198 test break-1.1 {Methods can "return -code break"} -body {
8200 method bark {} {return -code break "Breaking"}
8205 catch {spot bark} result
8210 test break-1.2 {Typemethods can "return -code break"} -body {
8212 typemethod bark {} {return -code break "Breaking"}
8215 catch {dog bark} result
8220 test break-1.3 {Methods called via mymethod "return -code break"} -body {
8222 method bark {} {return -code break "Breaking"}
8225 return [mymethod bark]
8231 catch {uplevel \#0 [spot getbark]} result
8236 #-----------------------------------------------------------------------
8239 test nspath-1.1 {Typemethods call commands from parent namespace} -constraints {
8242 namespace eval ::snit_test:: {
8243 proc bark {} {return "[namespace current]: Woof"}
8246 snit::type ::snit_test::dog {
8247 typemethod bark {} {
8252 ::snit_test::dog bark
8254 ::snit_test::dog destroy
8255 namespace forget ::snit_test
8256 } -result {::snit_test: Woof}
8258 test nspath-1.2 {Methods can call commands from parent namespace} -constraints {
8261 namespace eval ::snit_test:: {
8262 proc bark {} {return "[namespace current]: Woof"}
8265 snit::type ::snit_test::dog {
8271 ::snit_test::dog spot
8274 ::snit_test::dog destroy
8275 namespace forget ::snit_test
8276 } -result {::snit_test: Woof}
8278 #-----------------------------------------------------------------------
8281 test boolean-1.1 {boolean: valid} -body {
8282 snit::boolean validate 1
8283 snit::boolean validate 0
8284 snit::boolean validate true
8285 snit::boolean validate false
8286 snit::boolean validate yes
8287 snit::boolean validate no
8288 snit::boolean validate on
8289 snit::boolean validate off
8292 test boolean-1.2 {boolean: invalid} -body {
8293 codecatch {snit::boolean validate quux}
8294 } -result {INVALID invalid boolean "quux", should be one of: 1, 0, true, false, yes, no, on, off}
8296 test boolean-2.1 {boolean subtype: valid} -body {
8297 snit::boolean subtype
8300 subtype validate true
8301 subtype validate false
8302 subtype validate yes
8305 subtype validate off
8310 test boolean-2.2 {boolean subtype: invalid} -body {
8311 snit::boolean subtype
8312 codecatch {subtype validate quux}
8315 } -result {INVALID invalid boolean "quux", should be one of: 1, 0, true, false, yes, no, on, off}
8317 #-----------------------------------------------------------------------
8320 test double-1.1 {double: invalid -min} -body {
8321 snit::double obj -min abc
8324 } -result {Error in constructor: invalid -min: "abc"}
8326 test double-1.2 {double: invalid -max} -body {
8327 snit::double obj -max abc
8330 } -result {Error in constructor: invalid -max: "abc"}
8332 test double-1.3 {double: invalid, max < min} -body {
8333 snit::double obj -min 5 -max 0
8336 } -result {Error in constructor: -max < -min}
8338 test double-2.1 {double type: valid} -body {
8339 snit::double validate 1.5
8342 test double-2.2 {double type: invalid} -body {
8343 codecatch {snit::double validate abc}
8344 } -result {INVALID invalid value "abc", expected double}
8346 test double-3.1 {double subtype: valid, no range} -body {
8347 snit::double subtype
8348 subtype validate 1.5
8353 test double-3.2 {double subtype: valid, min but no max} -body {
8354 snit::double subtype -min 0.5
8360 test double-3.3 {double subtype: valid, min and max} -body {
8361 snit::double subtype -min 0.5 -max 10.5
8362 subtype validate 1.5
8367 test double-4.1 {double subtype: not a number} -body {
8368 snit::double subtype
8369 codecatch {subtype validate quux}
8372 } -result {INVALID invalid value "quux", expected double}
8374 test double-4.2 {double subtype: less than min, no max} -body {
8375 snit::double subtype -min 0.5
8376 codecatch {subtype validate -1}
8379 } -result {INVALID invalid value "-1", expected double no less than 0.5}
8381 test double-4.3 {double subtype: less than min, with max} -body {
8382 snit::double subtype -min 0.5 -max 5.5
8383 codecatch {subtype validate -1}
8386 } -result {INVALID invalid value "-1", expected double in range 0.5, 5.5}
8388 test double-4.4 {double subtype: greater than max, no min} -body {
8389 snit::double subtype -max 0.5
8390 codecatch {subtype validate 1}
8393 } -result {INVALID invalid value "1", expected double no greater than 0.5}
8395 #-----------------------------------------------------------------------
8398 test enum-1.1 {enum: valid} -body {
8399 snit::enum validate foo
8402 test enum-2.1 {enum subtype: missing -values} -body {
8406 } -result {Error in constructor: invalid -values: ""}
8408 test enum-3.1 {enum subtype: valid} -body {
8409 snit::enum subtype -values {foo bar baz}
8410 subtype validate foo
8411 subtype validate bar
8412 subtype validate baz
8417 test enum-3.2 {enum subtype: invalid} -body {
8418 snit::enum subtype -values {foo bar baz}
8419 codecatch {subtype validate quux}
8422 } -result {INVALID invalid value "quux", should be one of: foo, bar, baz}
8425 #-----------------------------------------------------------------------
8428 test fpixels-1.1 {no suffix} -constraints tk -body {
8429 snit::fpixels validate 5
8432 test fpixels-1.2 {suffix} -constraints tk -body {
8433 snit::fpixels validate 5i
8436 test fpixels-1.3 {decimal} -constraints tk -body {
8437 snit::fpixels validate 5.5
8440 test fpixels-1.4 {invalid} -constraints tk -body {
8441 codecatch {snit::fpixels validate 5.5abc}
8442 } -result {INVALID invalid value "5.5abc", expected fpixels}
8444 test fpixels-2.1 {bad -min} -constraints tk -body {
8445 snit::fpixels subtype -min abc
8448 } -result {Error in constructor: invalid -min: "abc"}
8450 test fpixels-2.2 {bad -max} -constraints tk -body {
8451 snit::fpixels subtype -max abc
8454 } -result {Error in constructor: invalid -max: "abc"}
8456 test fpixels-2.3 {-min > -max} -constraints tk -body {
8457 snit::fpixels subtype -min 10 -max 5
8460 } -result {Error in constructor: -max < -min}
8462 test fpixels-3.1 {subtype, no suffix} -constraints tk -body {
8463 snit::fpixels subtype
8469 test fpixels-3.2 {suffix} -constraints tk -body {
8470 snit::fpixels subtype
8476 test fpixels-3.3 {decimal} -constraints tk -body {
8477 snit::fpixels subtype
8478 subtype validate 5.5
8483 test fpixels-3.4 {invalid} -constraints tk -body {
8484 snit::fpixels subtype
8485 codecatch {subtype validate 5.5abc}
8488 } -result {INVALID invalid value "5.5abc", expected fpixels}
8491 test fpixels-3.5 {subtype -min} -constraints tk -body {
8492 snit::fpixels subtype -min 5
8498 test fpixels-3.6 {min of min, max} -constraints tk -body {
8499 snit::fpixels subtype -min 5 -max 20
8505 test fpixels-3.7 {max of min, max} -constraints tk -body {
8506 snit::fpixels subtype -min 5 -max 20
8512 test fpixels-3.8 {middle of min, max} -constraints tk -body {
8513 snit::fpixels subtype -min 5 -max 20
8519 test fpixels-3.9 {invalid, < min} -constraints tk -body {
8520 snit::fpixels subtype -min 5
8521 codecatch {subtype validate 4}
8524 } -result {INVALID invalid value "4", expected fpixels no less than 5}
8526 test fpixels-3.10 {invalid, > max} -constraints tk -body {
8527 snit::fpixels subtype -min 5 -max 20
8528 codecatch {subtype validate 21}
8531 } -result {INVALID invalid value "21", expected fpixels in range 5, 20}
8533 test fpixels-3.11 {invalid, > max, range with suffix} -constraints tk -body {
8534 snit::fpixels subtype -min 5i -max 10i
8535 codecatch {subtype validate 11i}
8538 } -result {INVALID invalid value "11i", expected fpixels in range 5i, 10i}
8540 #-----------------------------------------------------------------------
8543 test integer-1.1 {integer: invalid -min} -body {
8544 snit::integer obj -min abc
8547 } -result {Error in constructor: invalid -min: "abc"}
8549 test integer-1.2 {integer: invalid -max} -body {
8550 snit::integer obj -max abc
8553 } -result {Error in constructor: invalid -max: "abc"}
8555 test integer-1.3 {integer: invalid, max < min} -body {
8556 snit::integer obj -min 5 -max 0
8559 } -result {Error in constructor: -max < -min}
8561 test integer-2.1 {integer type: valid} -body {
8562 snit::integer validate 1
8565 test integer-2.2 {integer type: invalid} -body {
8566 codecatch {snit::integer validate abc}
8567 } -result {INVALID invalid value "abc", expected integer}
8569 test integer-3.1 {integer subtype: valid, no range} -body {
8570 snit::integer subtype
8576 test integer-3.2 {integer subtype: valid, min but no max} -body {
8577 snit::integer subtype -min 0
8583 test integer-3.3 {integer subtype: valid, min and max} -body {
8584 snit::integer subtype -min 0 -max 10
8590 test integer-4.1 {integer subtype: not a number} -body {
8591 snit::integer subtype
8592 codecatch {subtype validate quux}
8595 } -result {INVALID invalid value "quux", expected integer}
8597 test integer-4.2 {integer subtype: less than min, no max} -body {
8598 snit::integer subtype -min 0
8599 codecatch {subtype validate -1}
8602 } -result {INVALID invalid value "-1", expected integer no less than 0}
8604 test integer-4.3 {integer subtype: less than min, with max} -body {
8605 snit::integer subtype -min 0 -max 5
8606 codecatch {subtype validate -1}
8609 } -result {INVALID invalid value "-1", expected integer in range 0, 5}
8611 #-----------------------------------------------------------------------
8614 test listtype-1.1 {listtype, length 0; valid} -body {
8615 snit::listtype validate ""
8618 test listtype-1.2 {listtype, length 1; valid} -body {
8619 snit::listtype validate a
8622 test listtype-1.3 {listtype, length 2; valid} -body {
8623 snit::listtype validate {a b}
8626 test listtype-2.1 {listtype subtype, length 0; valid} -body {
8627 snit::listtype subtype
8633 test listtype-2.2 {listtype, length 1; valid} -body {
8634 snit::listtype subtype
8640 test listtype-2.3 {listtype, length 2; valid} -body {
8641 snit::listtype subtype
8642 subtype validate {a b}
8647 test listtype-2.4 {listtype, invalid -minlen} -body {
8648 snit::listtype subtype -minlen abc
8651 } -result {Error in constructor: invalid -minlen: "abc"}
8653 test listtype-2.5 {listtype, negative -minlen} -body {
8654 snit::listtype subtype -minlen -1
8657 } -result {Error in constructor: invalid -minlen: "-1"}
8659 test listtype-2.6 {listtype, invalid -maxlen} -body {
8660 snit::listtype subtype -maxlen abc
8663 } -result {Error in constructor: invalid -maxlen: "abc"}
8665 test listtype-2.7 {listtype, -maxlen < -minlen} -body {
8666 snit::listtype subtype -minlen 10 -maxlen 9
8669 } -result {Error in constructor: -maxlen < -minlen}
8671 test listtype-3.1 {-minlen 2, length 2; valid} -body {
8672 snit::listtype subtype -minlen 2
8673 subtype validate {a b}
8678 test listtype-3.2 {-minlen 2, length 3; valid} -body {
8679 snit::listtype subtype -minlen 2
8680 subtype validate {a b c}
8685 test listtype-3.3 {-minlen 2, length 1; invalid} -body {
8686 snit::listtype subtype -minlen 2
8687 codecatch {subtype validate a}
8690 } -result {INVALID value has too few elements; at least 2 expected}
8692 test listtype-3.4 {range 1 to 3, length 1; valid} -body {
8693 snit::listtype subtype -minlen 1 -maxlen 3
8699 test listtype-3.5 {range 1 to 3, length 3; valid} -body {
8700 snit::listtype subtype -minlen 1 -maxlen 3
8701 subtype validate {a b c}
8706 test listtype-3.6 {range 1 to 3, length 0; invalid} -body {
8707 snit::listtype subtype -minlen 1 -maxlen 3
8708 codecatch {subtype validate {}}
8711 } -result {INVALID value has too few elements; at least 1 expected}
8713 test listtype-3.7 {range 1 to 3, length 4; invalid} -body {
8714 snit::listtype subtype -minlen 1 -maxlen 3
8715 codecatch {subtype validate {a b c d}}
8718 } -result {INVALID value has too many elements; no more than 3 expected}
8720 test listtype-4.1 {boolean list, valid} -body {
8721 snit::listtype subtype -type snit::boolean
8722 subtype validate {yes 1 true}
8725 } -result {yes 1 true}
8727 test listtype-4.2 {boolean list, invalid} -body {
8728 snit::listtype subtype -type snit::boolean
8729 codecatch {subtype validate {yes 1 abc no}}
8732 } -result {INVALID invalid boolean "abc", should be one of: 1, 0, true, false, yes, no, on, off}
8734 #-----------------------------------------------------------------------
8737 test pixels-1.1 {no suffix} -constraints tk -body {
8738 snit::pixels validate 5
8741 test pixels-1.2 {suffix} -constraints tk -body {
8742 snit::pixels validate 5i
8745 test pixels-1.3 {decimal} -constraints tk -body {
8746 snit::pixels validate 5.5
8749 test pixels-1.4 {invalid} -constraints tk -body {
8750 codecatch {snit::pixels validate 5.5abc}
8751 } -result {INVALID invalid value "5.5abc", expected pixels}
8753 test pixels-2.1 {bad -min} -constraints tk -body {
8754 snit::pixels subtype -min abc
8757 } -result {Error in constructor: invalid -min: "abc"}
8759 test pixels-2.2 {bad -max} -constraints tk -body {
8760 snit::pixels subtype -max abc
8763 } -result {Error in constructor: invalid -max: "abc"}
8765 test pixels-2.3 {-min > -max} -constraints tk -body {
8766 snit::pixels subtype -min 10 -max 5
8769 } -result {Error in constructor: -max < -min}
8771 test pixels-3.1 {subtype, no suffix} -constraints tk -body {
8772 snit::pixels subtype
8778 test pixels-3.2 {suffix} -constraints tk -body {
8779 snit::pixels subtype
8785 test pixels-3.3 {decimal} -constraints tk -body {
8786 snit::pixels subtype
8787 subtype validate 5.5
8792 test pixels-3.4 {invalid} -constraints tk -body {
8793 snit::pixels subtype
8794 codecatch {subtype validate 5.5abc}
8797 } -result {INVALID invalid value "5.5abc", expected pixels}
8800 test pixels-3.5 {subtype -min} -constraints tk -body {
8801 snit::pixels subtype -min 5
8807 test pixels-3.6 {min of min, max} -constraints tk -body {
8808 snit::pixels subtype -min 5 -max 20
8814 test pixels-3.7 {max of min, max} -constraints tk -body {
8815 snit::pixels subtype -min 5 -max 20
8821 test pixels-3.8 {middle of min, max} -constraints tk -body {
8822 snit::pixels subtype -min 5 -max 20
8828 test pixels-3.9 {invalid, < min} -constraints tk -body {
8829 snit::pixels subtype -min 5
8830 codecatch {subtype validate 4}
8833 } -result {INVALID invalid value "4", expected pixels no less than 5}
8835 test pixels-3.10 {invalid, > max} -constraints tk -body {
8836 snit::pixels subtype -min 5 -max 20
8837 codecatch {subtype validate 21}
8840 } -result {INVALID invalid value "21", expected pixels in range 5, 20}
8842 test pixels-3.11 {invalid, > max, range with suffix} -constraints tk -body {
8843 snit::pixels subtype -min 5i -max 10i
8844 codecatch {subtype validate 11i}
8847 } -result {INVALID invalid value "11i", expected pixels in range 5i, 10i}
8849 #-----------------------------------------------------------------------
8852 test stringtype-1.1 {stringtype, valid string} -body {
8853 snit::stringtype validate ""
8856 test stringtype-2.1 {stringtype subtype: invalid -regexp} -body {
8857 snit::stringtype subtype -regexp "\[A-Z"
8860 } -result {Error in constructor: invalid -regexp: "[A-Z"}
8862 test stringtype-2.2 {stringtype subtype: invalid -minlen} -body {
8863 snit::stringtype subtype -minlen foo
8866 } -result {Error in constructor: invalid -minlen: "foo"}
8868 test stringtype-2.3 {stringtype subtype: invalid -maxlen} -body {
8869 snit::stringtype subtype -maxlen foo
8872 } -result {Error in constructor: invalid -maxlen: "foo"}
8874 test stringtype-2.4 {stringtype subtype: -maxlen < -minlen} -body {
8875 snit::stringtype subtype -maxlen 1 -minlen 5
8878 } -result {Error in constructor: -maxlen < -minlen}
8880 test stringtype-2.5 {stringtype subtype: -minlen < 0} -body {
8881 snit::stringtype subtype -minlen -1
8884 } -result {Error in constructor: invalid -minlen: "-1"}
8886 test stringtype-2.6 {stringtype subtype: -maxlen < 0} -body {
8887 snit::stringtype subtype -maxlen -1
8890 } -result {Error in constructor: -maxlen < -minlen}
8892 test stringtype-3.1 {stringtype subtype: -glob, valid} -body {
8893 snit::stringtype subtype -glob "*FOO*"
8894 subtype validate 1FOO2
8899 test stringtype-3.2 {stringtype subtype: -glob, case-insensitive} -body {
8900 snit::stringtype subtype -nocase yes -glob "*FOO*"
8901 subtype validate 1foo2
8906 test stringtype-3.3 {stringtype subtype: -glob invalid, case-sensitive} -body {
8907 snit::stringtype subtype -glob "*FOO*"
8908 codecatch {subtype validate 1foo2}
8911 } -result {INVALID invalid value "1foo2"}
8913 test stringtype-5.4 {stringtype subtype: -glob invalid, case-insensitive} -body {
8914 snit::stringtype subtype -nocase yes -glob "*FOO*"
8915 codecatch {subtype validate bar}
8918 } -result {INVALID invalid value "bar"}
8920 test stringtype-5.5 {stringtype subtype: -regexp valid, case-sensitive} -body {
8921 snit::stringtype subtype -regexp {^[A-Z]+$}
8922 subtype validate FOO
8927 test stringtype-5.6 {stringtype subtype: -regexp valid, case-insensitive} -body {
8928 snit::stringtype subtype -nocase yes -regexp {^[A-Z]+$}
8929 subtype validate foo
8934 test stringtype-5.7 {stringtype subtype: -regexp invalid, case-sensitive} -body {
8935 snit::stringtype subtype -regexp {^[A-Z]+$}
8936 codecatch {subtype validate foo}
8939 } -result {INVALID invalid value "foo"}
8941 test stringtype-5.8 {stringtype subtype: -regexp invalid, case-insensitive} -body {
8942 snit::stringtype subtype -nocase yes -regexp {^[A-Z]+$}
8943 codecatch {subtype validate foo1}
8946 } -result {INVALID invalid value "foo1"}
8948 #-----------------------------------------------------------------------
8951 test window-1.1 {window: valid} -constraints tk -body {
8952 snit::window validate .
8955 test window-1.2 {window: invalid} -constraints tk -body {
8956 codecatch {snit::window validate .nonesuch}
8957 } -result {INVALID invalid value ".nonesuch", value is not a window}
8959 test window-2.1 {window subtype: valid} -constraints tk -body {
8960 snit::window subtype
8966 test window-2.2 {window subtype: invalid} -constraints tk -body {
8967 snit::window subtype
8968 codecatch {subtype validate .nonesuch}
8971 } -result {INVALID invalid value ".nonesuch", value is not a window}
8973 #-----------------------------------------------------------------------
8974 # option -type specifications
8976 test optiontype-1.1 {-type is type object name} -body {
8978 option -akcflag -default no -type snit::boolean
8983 # Set -akcflag to a boolean value
8984 spot configure -akcflag yes
8985 spot configure -akcflag 1
8986 spot configure -akcflag on
8987 spot configure -akcflag off
8989 # Set -akcflag to an invalid value
8990 spot configure -akcflag offf
8995 } -result {invalid -akcflag value: invalid boolean "offf", should be one of: 1, 0, true, false, yes, no, on, off}
8997 test optiontype-1.2 {-type is type specification} -body {
8999 option -color -default brown \
9000 -type {snit::enum -values {brown black white golden}}
9005 # Set -color to a valid value
9006 spot configure -color brown
9007 spot configure -color black
9008 spot configure -color white
9009 spot configure -color golden
9011 # Set -color to an invalid value
9012 spot configure -color green
9017 } -result {invalid -color value: invalid value "green", should be one of: brown, black, white, golden}
9019 test optiontype-1.3 {-type catches invalid defaults} -body {
9021 option -color -default green \
9022 -type {snit::enum -values {brown black white golden}}
9030 } -result {Error in constructor: invalid -color default: invalid value "green", should be one of: brown, black, white, golden}
9033 #-----------------------------------------------------------------------
9036 test bug-1.1 {Bug 1161779: destructor can't precede constructor} -body {
9042 constructor {args} {
9043 $self configurelist $args
9051 test bug-2.1 {Bug 1106375: Widget Error on failed object's construction} -constraints {
9054 ::snit::widgetadaptor mylabel {
9055 delegate method * to hull
9056 delegate option * to hull
9058 constructor {args} {
9059 installhull using label
9060 error "simulated error"
9064 catch {mylabel .lab} result
9065 list [info commands .lab] $result
9069 } -result {{} {Error in constructor: simulated error}}
9071 test bug-2.2 {Bug 1106375: Widget Error on failed object's construction} -constraints {
9074 ::snit::widget myframe {
9075 delegate method * to hull
9076 delegate option * to hull
9078 constructor {args} {
9079 error "simulated error"
9083 catch {myframe .frm} result
9084 list [info commands .frm] $result
9087 } -result {{} {Error in constructor: simulated error}}
9089 test bug-3.1 {Bug 1532791: snit2, snit::widget problem} -constraints {
9092 snit::widget mywidget {
9093 delegate method * to mylabel
9094 delegate option * to mylabel
9102 } -result {.mylabel}
9105 #---------------------------------------------------------------------