snit/snit.test

   1 # -*- tcl -*-
   2 #---------------------------------------------------------------------
   3 # TITLE:
   4 #       snit.test
   5 #
   6 # AUTHOR:
   7 #       Will Duquette
   8 #
   9 # DESCRIPTION:
  10 #       Test cases for snit.tcl.  Uses the ::tcltest:: harness.
  11 #
  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).
  15 #
  16 #    Tests back-ported to Tcl 8.3 for snit 1.2 backport by kmg
  17 #    Backport of test made general by Andreas Kupries.
  18 #
  19 #    The tests assume tcltest 2.2
  20
  21 #-----------------------------------------------------------------------
  22 # Back-port to Tcl8.3 by Kenneth Green (kmg)
  23 #
  24 # Global changes:
  25 #  " eq " => "string equal"
  26 #  " ne " -> "!string equal"
  27 #-----------------------------------------------------------------------
  28
  29 source [file join \
  30         [file dirname [file dirname [file join [pwd] [info script]]]] \
  31         devtools testutilities.tcl]
  32
  33 testsNeedTcl     8.3
  34 testsNeedTcltest 2.2
  35
  36 #---------------------------------------------------------------------
  37 # Set up a number of constraints. This also determines which
  38 # implementation of snit is loaded and tested.
  39
  40 # WHD: Work around bugs in 8.5a3
  41 tcltest::testConstraint bug8.5a3 [expr {![string equal [info patchlevel] "8.5a3"]}]
  42
  43 # Marks tests which are only for Tk.
  44 tcltest::testConstraint tk [info exists tk_version]
  45
  46 # If Tk is available, require BWidget
  47 tcltest::testConstraint bwidget [expr {
  48     [tcltest::testConstraint tk] &&
  49     ![catch {package require BWidget}]
  50 }]
  51
  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]} {
  55     set snitVersion 2
  56     set snitFile snit2.tcl
  57 } else {
  58     set snitVersion 1
  59     set snitFile snit.tcl
  60 }
  61
  62 # Marks tests which are only for Snit 1
  63 tcltest::testConstraint snit1 [expr {$snitVersion == 1}]
  64
  65 # Marks tests which are only for Snit 2
  66 tcltest::testConstraint snit2 [expr {$snitVersion == 2}]
  67
  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]
  71
  72 if {[package vsatisfies [package provide Tcl] 8.6]} {
  73     # 8.6+
  74     proc expect {six default} { return $six }
  75 } else {
  76     # 8.4/8.5
  77     proc expect {six default} { return $default }
  78 }
  79
  80 #---------------------------------------------------------------------
  81 # Load the snit package.
  82
  83 testing {
  84     useLocal $snitFile snit
  85 }
  86
  87 #---------------------------------------------------------------------
  88
  89 namespace import ::snit::*
  90
  91 # Set up for Tk tests: Repeat background errors
  92 proc bgerror {msg} {
  93     global errorInfo
  94     set ::bideError $msg
  95     set ::bideErrorInfo $errorInfo
  96 }
  97
  98 # Set up for Tk tests: enter the event loop long enough to catch
  99 # any bgerrors.
 100 proc tkbide {{msg "tkbide"} {msec 500}} {
 101     set ::bideVar 0
 102     set ::bideError ""
 103     set ::bideErrorInfo ""
 104     # It looks like update idletasks does the job.
 105     if {0} {
 106         after $msec {set ::bideVar 1}
 107         tkwait variable ::bideVar
 108     }
 109     update idletasks
 110     if {"" != $::bideError} {
 111         error "$msg: $::bideError" $::bideErrorInfo
 112     }
 113 }
 114
 115 # cleanup type
 116 proc cleanupType {name} {
 117     if {[namespace exists $name]} {
 118         if {[catch {$name destroy} result]} {
 119             global errorInfo
 120             puts $errorInfo
 121             error "Could not cleanup $name!"
 122         }
 123     }
 124     tkbide "cleanupType $name"
 125 }
 126
 127 # cleanup before each test
 128 proc cleanup {} {
 129     global errorInfo
 130
 131     cleanupType ::dog
 132     cleanupType ::cat
 133     cleanupType ::mylabel
 134     cleanupType ::myframe
 135     cleanupType ::foo
 136     cleanupType ::bar
 137     cleanupType ::tail
 138     cleanupType ::papers
 139     cleanupType ::animal
 140     cleanupType ::confused-dog
 141     catch {option clear}
 142
 143     if {![string equal [info commands "spot"] ""]} {
 144         puts "spot not erased!"
 145         error "spot not erased!"
 146     }
 147
 148     if {![string equal [info commands "fido"] ""]} {
 149         puts "fido not erased!"
 150         error "fido not erased!"
 151     }
 152 }
 153
 154 # catch error code and error
 155
 156 proc codecatch {command} {
 157     if {![catch {uplevel 1 $command} result]} {
 158         error "expected error, got OK"
 159     }
 160
 161     return "$::errorCode $result"
 162 }
 163
 164
 165 #-----------------------------------------------------------------------
 166 # Internals: tests for Snit utility functions
 167
 168 test Expand-1.1 {template, no arguments} -body {
 169     snit::Expand "My %TEMPLATE%"
 170 } -result {My %TEMPLATE%}
 171
 172 test Expand-1.2 {template, no matching arguments} -body {
 173     snit::Expand "My %TEMPLATE%" %FOO% foo
 174 } -result {My %TEMPLATE%}
 175
 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}
 179
 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
 183
 184 test Mappend-1.1 {template, no arguments} -body {
 185     set text "Prefix: "
 186     snit::Mappend text "My %TEMPLATE%"
 187 } -cleanup {
 188     unset text
 189 } -result {Prefix: My %TEMPLATE%}
 190
 191 test Mappend-1.2 {template, no matching arguments} -body {
 192     set text "Prefix: "
 193     snit::Mappend text "My %TEMPLATE%" %FOO% foo
 194 } -cleanup {
 195     unset text
 196 } -result {Prefix: My %TEMPLATE%}
 197
 198 test Mappend-1.3 {template with matching arguments} -body {
 199     set text "Prefix: "
 200     snit::Mappend text "%FOO% %BAR% %FOO%" %FOO% bar %BAR% foo
 201 } -cleanup {
 202     unset text
 203 } -result {Prefix: bar foo bar}
 204
 205 test Mappend-1.4 {template with odd number of arguments} -body {
 206     set text "Prefix: "
 207     snit::Mappend text "%FOO% %BAR% %FOO%" %FOO%
 208 } -cleanup {
 209     unset text
 210 } -returnCodes error -result {char map list unbalanced}
 211
 212 test RT.UniqueName-1.1 {no name collision} -body {
 213     set counter 0
 214
 215     # Standard qualified type name.
 216     set n1 [snit::RT.UniqueName counter ::mytype ::my::%AUTO%]
 217
 218     # Standard qualified widget name.
 219     set n2 [snit::RT.UniqueName counter ::mytype .my.%AUTO%]
 220
 221     list $n1 $n2
 222 } -result {::my::mytype1 .my.mytype2} -cleanup {
 223     unset counter n1 n2
 224 }
 225
 226 test RT.UniqueName-1.2 {name collision} -body {
 227     set counter 0
 228
 229     # Create the first two equivalent procs.
 230     proc ::mytype1 {} {}
 231     proc ::mytype2 {} {}
 232
 233     # Create a new name; it should skip to 3.
 234     snit::RT.UniqueName counter ::mytype ::%AUTO%
 235 } -cleanup {
 236     unset counter
 237     rename ::mytype1 ""
 238     rename ::mytype2 ""
 239 } -result {::mytype3}
 240
 241 test RT.UniqueName-1.3 {nested type name} -body {
 242     set counter 0
 243
 244     snit::RT.UniqueName counter ::thisis::yourtype ::your::%AUTO%
 245 } -cleanup {
 246     unset counter
 247 } -result {::your::yourtype1}
 248
 249 test RT.UniqueInstanceNamespace-1.1 {no name collision} -setup {
 250     namespace eval ::mytype:: {}
 251 } -body {
 252     set counter 0
 253     snit::RT.UniqueInstanceNamespace counter ::mytype
 254 } -cleanup {
 255     unset counter
 256     namespace delete ::mytype::
 257 } -result {::mytype::Snit_inst1}
 258
 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:: {}
 263 } -body {
 264     set counter 0
 265
 266     # Should skip to 3.
 267     snit::RT.UniqueInstanceNamespace counter ::mytype
 268 } -cleanup {
 269     unset counter
 270     namespace delete ::mytype::
 271 } -result {::mytype::Snit_inst3}
 272
 273 test Contains-1.1 {contains element} -constraints {
 274     snit1
 275 } -setup {
 276     set mylist {foo bar baz}
 277 } -body {
 278     snit::Contains baz $mylist
 279 } -cleanup {
 280     unset mylist
 281 } -result {1}
 282
 283 test Contains-1.2 {does not contain element} -constraints {
 284     snit1
 285 } -setup {
 286     set mylist {foo bar baz}
 287 } -body {
 288     snit::Contains quux $mylist
 289 } -cleanup {
 290     unset mylist
 291 } -result {0}
 292
 293 #-----------------------------------------------------------------------
 294 # type compilation
 295
 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.
 301
 302 test compile-1.1 {compile returns qualified type} -body {
 303     set compResult [compile type dog { }]
 304
 305     list [llength $compResult] [lindex $compResult 0]
 306 } -result {2 ::dog}
 307
 308 #-----------------------------------------------------------------------
 309 # type destruction
 310
 311 test typedestruction-1.1 {type command is deleted} -body {
 312     type dog { }
 313     dog destroy
 314     info command ::dog
 315 } -result {}
 316
 317 test typedestruction-1.2 {instance commands are deleted} -body {
 318     type dog { }
 319
 320     dog create spot
 321     dog destroy
 322     info command ::spot
 323 } -result {}
 324
 325 test typedestruction-1.3 {type namespace is deleted} -body {
 326     type dog { }
 327     dog destroy
 328     namespace exists ::dog
 329 } -result {0}
 330
 331 test typedestruction-1.4 {type proc is destroyed on error} -body {
 332     catch {type dog {
 333         error "Error creating dog"
 334     }} result
 335
 336     list [namespace exists ::dog] [info command ::dog]
 337 } -result {0 {}}
 338
 339 test typedestruction-1.5 {unrelated namespaces are deleted, bug 2898640} -body {
 340     type dog {}
 341     namespace eval dog::unrelated {}
 342     dog destroy
 343 } -result {}
 344
 345 #-----------------------------------------------------------------------
 346 # type and typemethods
 347
 348 test type-1.1 {type names get qualified} -body {
 349     type dog {}
 350 } -cleanup {
 351     dog destroy
 352 } -result {::dog}
 353
 354 test type-1.2 {typemethods can be defined} -body {
 355     type dog {
 356         typemethod foo {a b} {
 357             return [list $a $b]
 358         }
 359     }
 360
 361     dog foo 1 2
 362 } -cleanup {
 363     dog destroy
 364 } -result {1 2}
 365
 366 test type-1.3 {upvar works in typemethods} -body {
 367     type dog {
 368         typemethod goodname {varname} {
 369             upvar $varname myvar
 370             set myvar spot
 371         }
 372     }
 373
 374     set thename fido
 375     dog goodname thename
 376     set thename
 377 } -cleanup {
 378     dog destroy
 379     unset thename
 380 } -result {spot}
 381
 382 test type-1.4 {typemethod args can't include type} -body {
 383     type dog {
 384         typemethod foo {a type b} { }
 385     }
 386 } -returnCodes error -result {typemethod foo's arglist may not contain "type" explicitly}
 387
 388 test type-1.5 {typemethod args can't include self} -body {
 389     type dog {
 390         typemethod foo {a self b} { }
 391     }
 392 } -returnCodes error -result {typemethod foo's arglist may not contain "self" explicitly}
 393
 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.
 398     type dog {
 399         typemethod foo {
 400             a
 401             b
 402         } { }
 403     }
 404 } -cleanup {
 405     dog destroy
 406 } -result {::dog}
 407
 408
 409 #-----------------------------------------------------------------------
 410 # typeconstructor
 411
 412 test typeconstructor-1.1 {a typeconstructor can be defined} -body {
 413     type dog {
 414         typevariable a
 415
 416         typeconstructor {
 417             set a 1
 418         }
 419
 420         typemethod aget {} {
 421             return $a
 422         }
 423     }
 424
 425     dog aget
 426 } -cleanup {
 427     dog destroy
 428 } -result {1}
 429
 430 test typeconstructor-1.2 {only one typeconstructor can be defined} -body {
 431     type dog {
 432         typevariable a
 433
 434         typeconstructor {
 435             set a 1
 436         }
 437
 438         typeconstructor {
 439             set a 2
 440         }
 441     }
 442 } -returnCodes error -result {too many typeconstructors}
 443
 444 test typeconstructor-1.3 {type proc is destroyed on error} -body {
 445     catch {
 446         type dog {
 447             typeconstructor {
 448                 error "Error creating dog"
 449             }
 450         }
 451     } result
 452
 453     list [namespace exists ::dog] [info command ::dog]
 454 } -result {0 {}}
 455
 456 #-----------------------------------------------------------------------
 457 # Type components
 458
 459 test typecomponent-1.1 {typecomponent defines typevariable} -body {
 460     type dog {
 461         typecomponent mycomp
 462
 463         typemethod test {} {
 464             return $mycomp
 465         }
 466     }
 467
 468     dog test
 469 } -cleanup {
 470     dog destroy
 471 } -result {}
 472
 473 test typecomponent-1.2 {typecomponent trace executes} -body {
 474     type dog {
 475         typecomponent mycomp
 476
 477         typemethod test {} {
 478             typevariable Snit_typecomponents
 479             set mycomp foo
 480             return $Snit_typecomponents(mycomp)
 481         }
 482     }
 483
 484     dog test
 485 } -cleanup {
 486     dog destroy
 487 } -result {foo}
 488
 489 test typecomponent-1.3 {typecomponent -public works} -body {
 490     type dog {
 491         typecomponent mycomp -public string
 492
 493         typeconstructor {
 494             set mycomp string
 495         }
 496     }
 497
 498     dog string length foo
 499 } -cleanup {
 500     dog destroy
 501 } -result {3}
 502
 503 test typecomponent-1.4 {typecomponent -inherit yes} -body {
 504     type dog {
 505         typecomponent mycomp -inherit yes
 506
 507         typeconstructor {
 508             set mycomp string
 509         }
 510     }
 511
 512     dog length foo
 513 } -cleanup {
 514     dog destroy
 515 } -result {3}
 516
 517
 518 #-----------------------------------------------------------------------
 519 # hierarchical type methods
 520
 521 test htypemethod-1.1 {hierarchical method, two tokens} -body {
 522     type dog {
 523         typemethod {wag tail} {} {
 524             return "wags tail"
 525         }
 526     }
 527
 528     dog wag tail
 529 } -cleanup {
 530     dog destroy
 531 } -result {wags tail}
 532
 533 test htypemethod-1.2 {hierarchical method, three tokens} -body {
 534     type dog {
 535         typemethod {wag tail proudly} {} {
 536             return "wags tail proudly"
 537         }
 538     }
 539
 540     dog wag tail proudly
 541 } -cleanup {
 542     dog destroy
 543 } -result {wags tail proudly}
 544
 545 test htypemethod-1.3 {hierarchical method, four tokens} -body {
 546     type dog {
 547         typemethod {wag tail really high} {} {
 548             return "wags tail really high"
 549         }
 550     }
 551
 552     dog wag tail really high
 553 } -cleanup {
 554     dog destroy
 555 } -result {wags tail really high}
 556
 557 test htypemethod-1.4 {redefinition is OK} -body {
 558     type dog {
 559         typemethod {wag tail} {} {
 560             return "wags tail"
 561         }
 562         typemethod {wag tail} {} {
 563             return "wags tail briskly"
 564         }
 565     }
 566
 567     dog wag tail
 568 } -cleanup {
 569     dog destroy
 570 } -result {wags tail briskly}
 571
 572 # Case 1
 573 test htypemethod-1.5 {proper error on missing submethod} -constraints {
 574     snit1
 575 } -body {
 576     cleanup
 577
 578     type dog {
 579         typemethod {wag tail} {} { }
 580     }
 581
 582     dog wag
 583 } -returnCodes {
 584     error
 585 }  -cleanup {
 586     dog destroy
 587 } -result {wrong number args: should be "::dog wag method args"}
 588
 589 # Case 2
 590 test htypemethod-1.6 {proper error on missing submethod} -constraints {
 591     snit2
 592 } -body {
 593     cleanup
 594
 595     type dog {
 596         typemethod {wag tail} {} { }
 597     }
 598
 599     dog wag
 600 } -returnCodes {
 601     error
 602 } -cleanup {
 603     dog destroy
 604 } -result [expect \
 605                {wrong # args: should be "dog wag subcommand ?arg ...?"} \
 606                {wrong # args: should be "dog wag subcommand ?argument ...?"}]
 607
 608 # Case 1
 609 test htypemethod-1.7 {proper error on bogus submethod} -constraints {
 610     snit1
 611 } -body {
 612     cleanup
 613
 614     type dog {
 615         typemethod {wag tail} {} { }
 616     }
 617
 618     dog wag ears
 619 } -returnCodes {
 620     error
 621 }  -cleanup {
 622     dog destroy
 623 } -result {"::dog wag ears" is not defined}
 624
 625 # Case 2
 626 test htypemethod-1.8 {proper error on bogus submethod} -constraints {
 627     snit2
 628 } -body {
 629     cleanup
 630
 631     type dog {
 632         typemethod {wag tail} {} { }
 633     }
 634
 635     dog wag ears
 636 } -returnCodes {
 637     error
 638 } -cleanup {
 639     dog destroy
 640 } -result {unknown subcommand "ears": namespace ::dog does not export any commands}
 641
 642 test htypemethod-2.1 {prefix/method collision, level 1, order 1} -body {
 643     type dog {
 644         typemethod wag {} {}
 645         typemethod {wag tail} {} {}
 646     }
 647 } -returnCodes {
 648     error
 649 } -result {Error in "typemethod {wag tail}...", "wag" has no submethods.}
 650
 651 test htypemethod-2.2 {prefix/method collision, level 1, order 2} -body {
 652     type dog {
 653         typemethod {wag tail} {} {}
 654         typemethod wag {} {}
 655     }
 656 } -returnCodes {
 657     error
 658 } -result {Error in "typemethod wag...", "wag" has submethods.}
 659
 660 test htypemethod-2.3 {prefix/method collision, level 2, order 1} -body {
 661     type dog {
 662         typemethod {wag tail} {} {}
 663         typemethod {wag tail proudly} {} {}
 664     }
 665 } -returnCodes {
 666     error
 667 } -result {Error in "typemethod {wag tail proudly}...", "wag tail" has no submethods.}
 668
 669 test htypemethod-2.4 {prefix/method collision, level 2, order 2} -body {
 670     type dog {
 671         typemethod {wag tail proudly} {} {}
 672         typemethod {wag tail} {} {}
 673     }
 674 } -returnCodes {
 675     error
 676 } -result {Error in "typemethod {wag tail}...", "wag tail" has submethods.}
 677
 678 #-----------------------------------------------------------------------
 679 # Typemethod delegation
 680
 681 test dtypemethod-1.1 {delegate typemethod to non-existent component} -body {
 682     set result ""
 683
 684     type dog {
 685         delegate typemethod foo to bar
 686     }
 687
 688     dog foo
 689 } -returnCodes {
 690     error
 691 } -result {::dog delegates typemethod "foo" to undefined typecomponent "bar"}
 692
 693 test dtypemethod-1.2 {delegating to existing typecomponent} -body {
 694     type dog {
 695         delegate typemethod length to string
 696
 697         typeconstructor {
 698             set string string
 699         }
 700     }
 701
 702     dog length foo
 703 } -cleanup {
 704     dog destroy
 705 } -result {3}
 706
 707 # Case 1
 708 test dtypemethod-1.3 {delegating to existing typecomponent with error} -constraints {
 709     snit1
 710 } -body {
 711     type dog {
 712         delegate typemethod length to string
 713
 714         typeconstructor {
 715             set string string
 716         }
 717     }
 718
 719     dog length foo bar
 720 } -returnCodes {
 721     error
 722 } -result {wrong # args: should be "string length string"}
 723
 724 # Case 2
 725 test dtypemethod-1.4 {delegating to existing typecomponent with error} -constraints {
 726     snit2
 727 } -body {
 728     type dog {
 729         delegate typemethod length to string
 730
 731         typeconstructor {
 732             set string string
 733         }
 734     }
 735
 736     dog length foo bar
 737 } -returnCodes {
 738     error
 739 } -result {wrong # args: should be "dog length string"}
 740
 741 test dtypemethod-1.5 {delegating unknown typemethods to existing typecomponent} -body {
 742     type dog {
 743         delegate typemethod * to string
 744
 745         typeconstructor {
 746             set string string
 747         }
 748     }
 749
 750     dog length foo
 751 } -cleanup {
 752     dog destroy
 753 } -result {3}
 754
 755 # Case 1
 756 test dtypemethod-1.6 {delegating unknown typemethod to existing typecomponent with error} -body {
 757     type dog {
 758         delegate typemethod * to stringhandler
 759
 760         typeconstructor {
 761             set stringhandler string
 762         }
 763     }
 764
 765     dog foo bar
 766 } -constraints {
 767     snit1
 768 } -returnCodes {
 769     error
 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}
 771
 772 test dtypemethod-1.6a {delegating unknown typemethod to existing typecomponent with error} -body {
 773     type dog {
 774         delegate typemethod * to stringhandler
 775
 776         typeconstructor {
 777             set stringhandler string
 778         }
 779     }
 780
 781     dog foo bar
 782 } -constraints {
 783     snit2
 784 } -returnCodes {
 785     error
 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}
 787
 788 test dtypemethod-1.7 {can't delegate local typemethod: order 1} -body {
 789     type dog {
 790         typemethod foo {} {}
 791         delegate typemethod foo to bar
 792     }
 793 } -returnCodes {
 794     error
 795 } -result {Error in "delegate typemethod foo...", "foo" has been defined locally.}
 796
 797 test dtypemethod-1.8 {can't delegate local typemethod: order 2} -body {
 798     type dog {
 799         delegate typemethod foo to bar
 800         typemethod foo {} {}
 801     }
 802 } -returnCodes {
 803     error
 804 } -result {Error in "typemethod foo...", "foo" has been delegated}
 805
 806 # Case 1
 807 test dtypemethod-1.9 {excepted methods are caught properly} -constraints {
 808     snit1
 809 } -body {
 810     type dog {
 811         delegate typemethod * to string except {match index}
 812
 813         typeconstructor {
 814             set string string
 815         }
 816     }
 817
 818     catch {dog length foo} a
 819     catch {dog match foo}  b
 820     catch {dog index foo}  c
 821
 822     list $a $b $c
 823 } -cleanup {
 824     dog destroy
 825 } -result {3 {"::dog match" is not defined} {"::dog index" is not defined}}
 826
 827 # Case 2
 828 test dtypemethod-1.10 {excepted methods are caught properly} -constraints {
 829     snit2
 830 } -body {
 831     type dog {
 832         delegate typemethod * to string except {match index}
 833
 834         typeconstructor {
 835             set string string
 836         }
 837     }
 838
 839     catch {dog length foo} a
 840     catch {dog match foo}  b
 841     catch {dog index foo}  c
 842
 843     list $a $b $c
 844 } -cleanup {
 845     dog destroy
 846 } -result {3 {unknown subcommand "match": must be length} {unknown subcommand "index": must be length}}
 847
 848 test dtypemethod-1.11 {as clause can include arguments} -body {
 849     proc tail {a b} {
 850         return "<$a $b>"
 851     }
 852
 853     type dog {
 854         delegate typemethod wag to tail as {wag briskly}
 855
 856         typeconstructor {
 857             set tail tail
 858         }
 859     }
 860
 861     dog wag
 862 } -cleanup {
 863     dog destroy
 864     rename tail ""
 865 } -result {<wag briskly>}
 866
 867 test dtypemethod-2.1 {'using "%c %m"' gets normal behavior} -body {
 868     type dog {
 869         delegate typemethod length to string using {%c %m}
 870
 871         typeconstructor {
 872             set string string
 873         }
 874     }
 875
 876     dog length foo
 877 } -cleanup {
 878     dog destroy
 879 } -result {3}
 880
 881 test dtypemethod-2.2 {All relevant 'using' conversions are converted} -body {
 882     proc echo {args} {
 883         return $args
 884     }
 885
 886     type dog {
 887         delegate typemethod {tail wag} using {echo %% %t %M %m %j %n %w %s %c}
 888     }
 889
 890     dog tail wag
 891 } -cleanup {
 892     dog destroy
 893     rename echo ""
 894 } -result {% ::dog {tail wag} wag tail_wag %n %w %s %c}
 895
 896 test dtypemethod-2.3 {"%%" is handled properly} -body {
 897     proc echo {args} { join $args "|" }
 898
 899     type dog {
 900         delegate typemethod wag using {echo %%m %%%m}
 901     }
 902
 903     dog wag
 904 } -cleanup {
 905     dog destroy
 906     rename echo ""
 907 } -result {%m|%wag}
 908
 909 test dtypemethod-2.4 {Method "*" and "using"} -body {
 910     proc echo {args} { join $args "|" }
 911
 912     type dog {
 913         delegate typemethod * using {echo %m}
 914     }
 915
 916     list [dog wag] [dog bark loudly]
 917 } -cleanup {
 918     dog destroy
 919     rename echo ""
 920 } -result {wag bark|loudly}
 921
 922 test dtypemethod-3.1 {typecomponent names can be changed dynamically} -body {
 923     proc echo {args} { join $args "|" }
 924
 925     type dog {
 926         delegate typemethod length to mycomp
 927
 928         typeconstructor {
 929             set mycomp string
 930         }
 931
 932         typemethod switchit {} {
 933             set mycomp echo
 934         }
 935     }
 936
 937     set a [dog length foo]
 938     dog switchit
 939     set b [dog length foo]
 940
 941     list $a $b
 942 } -cleanup {
 943     dog destroy
 944     rename echo ""
 945 } -result {3 length|foo}
 946
 947 test dtypemethod-4.1 {hierarchical typemethod, two tokens} -body {
 948     type tail {
 949         method wag {} {return "wags tail"}
 950     }
 951
 952     type dog {
 953         typeconstructor {
 954             set tail [tail %AUTO%]
 955         }
 956         delegate typemethod {wag tail} to tail as wag
 957     }
 958
 959     dog wag tail
 960 } -cleanup {
 961     dog destroy
 962     tail destroy
 963 } -result {wags tail}
 964
 965 test dtypemethod-4.2 {hierarchical typemethod, three tokens} -body {
 966     type tail {
 967         method wag {} {return "wags tail"}
 968     }
 969
 970     type dog {
 971         typeconstructor {
 972             set tail [tail %AUTO%]
 973         }
 974         delegate typemethod {wag tail proudly} to tail as wag
 975     }
 976
 977     dog wag tail proudly
 978 } -cleanup {
 979     dog destroy
 980     tail destroy
 981 } -result {wags tail}
 982
 983 test dtypemethod-4.3 {hierarchical typemethod, four tokens} -body {
 984     type tail {
 985         method wag {} {return "wags tail"}
 986     }
 987
 988     type dog {
 989         typeconstructor {
 990             set tail [tail %AUTO%]
 991         }
 992         delegate typemethod {wag tail really high} to tail as wag
 993     }
 994
 995     dog wag tail really high
 996 } -cleanup {
 997     dog destroy
 998     tail destroy
 999 } -result {wags tail}
1000
1001 test dtypemethod-4.4 {redefinition is OK} -body {
1002     type tail {
1003         method {wag tail}    {} {return "wags tail"}
1004         method {wag briskly} {} {return "wags tail briskly"}
1005     }
1006
1007     type dog {
1008         typeconstructor {
1009             set tail [tail %AUTO%]
1010         }
1011         delegate typemethod {wag tail} to tail as {wag tail}
1012         delegate typemethod {wag tail} to tail as {wag briskly}
1013     }
1014
1015     dog wag tail
1016 } -cleanup {
1017     dog destroy
1018     tail destroy
1019 } -result {wags tail briskly}
1020
1021 test dtypemethod-4.5 {last token is used by default} -body {
1022     type tail {
1023         method wag {} {return "wags tail"}
1024     }
1025
1026     type dog {
1027         typeconstructor {
1028             set tail [tail %AUTO%]
1029         }
1030         delegate typemethod {tail wag} to tail
1031     }
1032
1033     dog tail wag
1034 } -cleanup {
1035     dog destroy
1036     tail destroy
1037 } -result {wags tail}
1038
1039 test dtypemethod-4.6 {last token can be *} -body {
1040     type tail {
1041         method wag {} {return "wags"}
1042         method droop {} {return "droops"}
1043     }
1044
1045     type dog {
1046         typeconstructor {
1047             set tail [tail %AUTO%]
1048         }
1049         delegate typemethod {tail *} to tail
1050     }
1051
1052     list [dog tail wag] [dog tail droop]
1053 } -cleanup {
1054     dog destroy
1055     tail destroy
1056 } -result {wags droops}
1057
1058 # Case 2
1059 test dtypemethod-4.7 {except with multiple tokens} -constraints {
1060     snit1
1061 } -body {
1062     type tail {
1063         method wag {} {return "wags"}
1064         method droop {} {return "droops"}
1065     }
1066
1067     type dog {
1068         typeconstructor {
1069             set tail [tail %AUTO%]
1070         }
1071         delegate typemethod {tail *} to tail except droop
1072     }
1073
1074     catch {dog tail droop} result
1075
1076     list [dog tail wag] $result
1077 } -cleanup {
1078     dog destroy
1079     tail destroy
1080 } -result {wags {"::dog tail droop" is not defined}}
1081
1082 # Case 2
1083 test dtypemethod-4.8 {except with multiple tokens} -constraints {
1084     snit2
1085 } -body {
1086     type tail {
1087         method wag {} {return "wags"}
1088         method droop {} {return "droops"}
1089     }
1090
1091     type dog {
1092         typeconstructor {
1093             set tail [tail %AUTO%]
1094         }
1095         delegate typemethod {tail *} to tail except droop
1096     }
1097
1098     catch {dog tail droop} result
1099
1100     list [dog tail wag] $result
1101 } -cleanup {
1102     dog destroy
1103     tail destroy
1104 } -result {wags {unknown subcommand "droop": namespace ::dog does not export any commands}}
1105
1106 test dtypemethod-4.9 {"*" in the wrong spot} -body {
1107     type dog {
1108         delegate typemethod {tail * wag} to tail
1109     }
1110 } -returnCodes {
1111     error
1112 } -result {Error in "delegate typemethod {tail * wag}...", "*" must be the last token.}
1113
1114 test dtypemethod-5.1 {prefix/typemethod collision} -body {
1115     type dog {
1116         delegate typemethod wag to tail
1117         delegate typemethod {wag tail} to tail as wag
1118     }
1119 } -returnCodes {
1120     error
1121 } -result {Error in "delegate typemethod {wag tail}...", "wag" has no submethods.}
1122
1123 test dtypemethod-5.2 {prefix/typemethod collision} -body {
1124     type dog {
1125         delegate typemethod {wag tail} to tail as wag
1126         delegate typemethod wag to tail
1127     }
1128 } -returnCodes {
1129     error
1130 } -result {Error in "delegate typemethod wag...", "wag" has submethods.}
1131
1132 test dtypemethod-5.3 {prefix/typemethod collision} -body {
1133     type dog {
1134         delegate typemethod {wag tail} to tail
1135         delegate typemethod {wag tail proudly} to tail as wag
1136     }
1137 } -returnCodes {
1138     error
1139 } -result {Error in "delegate typemethod {wag tail proudly}...", "wag tail" has no submethods.}
1140
1141 test dtypemethod-5.4 {prefix/typemethod collision} -body {
1142     type dog {
1143         delegate typemethod {wag tail proudly} to tail as wag
1144         delegate typemethod {wag tail} to tail
1145     }
1146 } -returnCodes {
1147     error
1148 } -result {Error in "delegate typemethod {wag tail}...", "wag tail" has submethods.}
1149
1150 #-----------------------------------------------------------------------
1151 # type creation
1152
1153 test creation-1.1 {type instance names get qualified} -body {
1154     type dog { }
1155
1156     dog create spot
1157 } -cleanup {
1158     dog destroy
1159 } -result {::spot}
1160
1161 test creation-1.2 {type instance names can be generated} -body {
1162     type dog { }
1163
1164     dog create my%AUTO%
1165 } -cleanup {
1166     dog destroy
1167 } -result {::mydog1}
1168
1169 test creation-1.3 {"create" method is optional} -body {
1170     type dog { }
1171
1172     dog fido
1173 } -cleanup {
1174     dog destroy
1175 } -result {::fido}
1176
1177 test creation-1.4 {constructor arg can't be type} -body {
1178     type dog {
1179         constructor {type} { }
1180     }
1181 } -returnCodes {
1182     error
1183 } -result {constructor's arglist may not contain "type" explicitly}
1184
1185 test creation-1.5 {constructor arg can't be self} -body {
1186     type dog {
1187         constructor {self} { }
1188     }
1189 } -returnCodes {
1190     error
1191 } -result {constructor's arglist may not contain "self" explicitly}
1192
1193 test creation-1.6 {weird names are OK} -body {
1194     # I.e., names with non-identifier characters
1195     type confused-dog {
1196         method meow {} {
1197             return "$self meows."
1198         }
1199     }
1200
1201     confused-dog spot
1202     spot meow
1203 } -cleanup {
1204     confused-dog destroy
1205 } -result {::spot meows.}
1206
1207 # Case 1
1208 test creation-1.7 {If -hasinstances yes, [$type] == [$type create %AUTO%]} -constraints {
1209     snit1
1210 } -body {
1211     type dog {
1212         variable dummy
1213     }
1214
1215     set mydog [dog]
1216 } -cleanup {
1217     $mydog destroy
1218     dog destroy
1219 } -result {::dog1}
1220
1221 # Case 2
1222 test creation-1.8 {If -hasinstances yes, [$type] == [$type create %AUTO%]} -constraints {
1223     snit2
1224 } -body {
1225     type dog {
1226         # WHD: In Snit 1.0, this pragma was not needed.
1227         pragma -hastypemethods no
1228         variable dummy
1229     }
1230
1231     set mydog [dog]
1232 } -cleanup {
1233     # [dog destroy] doesn't exist
1234     $mydog destroy
1235     namespace delete ::dog
1236 } -result {::dog1}
1237
1238 # Case 1
1239 test creation-1.9 {If -hasinstances no, [$type] != [$type create %AUTO%]} -constraints {
1240     snit1
1241 } -body {
1242     type dog {
1243         pragma -hasinstances no
1244     }
1245
1246     set mydog [dog]
1247 } -cleanup {
1248     dog destroy
1249 } -returnCodes {
1250     error
1251 } -result {wrong # args: should be "::dog method args"}
1252
1253 # Case 2
1254 test creation-1.10 {If -hasinstances no, [$type] != [$type create %AUTO%]} -constraints {
1255     snit2
1256 } -body {
1257     type dog {
1258         pragma -hasinstances no
1259     }
1260
1261     set mydog [dog]
1262 } -cleanup {
1263     dog destroy
1264 } -returnCodes {
1265     error
1266 } -result [expect \
1267                {wrong # args: should be "dog subcommand ?arg ...?"} \
1268                {wrong # args: should be "dog subcommand ?argument ...?"}]
1269
1270 # Case 1
1271 test creation-1.11 {If widget, [$type] != [$type create %AUTO%]} -constraints {
1272     snit1 tk
1273 } -body {
1274     widget dog {
1275         variable dummy
1276     }
1277
1278     set mydog [dog]
1279 } -cleanup {
1280     dog destroy
1281 } -returnCodes {
1282     error
1283 } -result {wrong # args: should be "::dog method args"}
1284
1285 # Case 2
1286 test creation-1.12 {If widget, [$type] != [$type create %AUTO%]} -constraints {
1287     snit2 tk
1288 } -body {
1289     widget dog {
1290         variable dummy
1291     }
1292
1293     set mydog [dog]
1294 } -cleanup {
1295     dog destroy
1296 } -returnCodes {
1297     error
1298 } -result [expect \
1299                {wrong # args: should be "dog subcommand ?arg ...?"} \
1300                {wrong # args: should be "dog subcommand ?argument ...?"}]
1301
1302 test creation-1.13 {If -hastypemethods yes, [$type] == [$type create %AUTO%]} -constraints {
1303     snit1
1304 } -body {
1305     type dog {
1306         variable dummy
1307     }
1308
1309     set mydog [dog]
1310 } -cleanup {
1311     dog destroy
1312 } -result {::dog1}
1313
1314 test creation-1.14 {If -hastypemethods yes, [$type] != [$type create %AUTO%]} -constraints {
1315     snit2
1316 } -body {
1317     type dog {
1318         variable dummy
1319     }
1320
1321     set mydog [dog]
1322 } -cleanup {
1323     dog destroy
1324 } -returnCodes {
1325     error
1326 } -result [expect \
1327                {wrong # args: should be "dog subcommand ?arg ...?"} \
1328                {wrong # args: should be "dog subcommand ?argument ...?"}]
1329
1330 test creation-2.1 {Can't call "destroy" in constructor} -body {
1331     type dog {
1332         constructor {} {
1333             $self destroy
1334         }
1335     }
1336
1337     dog spot
1338 } -cleanup {
1339     dog destroy
1340 } -returnCodes {
1341     error
1342 } -result {Error in constructor: Called 'destroy' method in constructor}
1343
1344 #-----------------------------------------------------------------------
1345 # procs
1346
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.
1351     type dog {
1352         proc foo {
1353             a
1354             b
1355         } { }
1356     }
1357 } -cleanup {
1358     dog destroy
1359 } -result {::dog}
1360
1361
1362 #-----------------------------------------------------------------------
1363 # methods
1364
1365 test method-1.1 {methods get called} -body {
1366     type dog {
1367         method bark {} {
1368             return "$self barks"
1369         }
1370     }
1371
1372     dog create spot
1373     spot bark
1374 } -cleanup {
1375     dog destroy
1376 } -result {::spot barks}
1377
1378 test method-1.2 {methods can call other methods} -body {
1379     type dog {
1380         method bark {} {
1381             return "$self barks."
1382         }
1383
1384         method chase {quarry} {
1385             return "$self chases $quarry; [$self bark]"
1386         }
1387     }
1388
1389     dog create spot
1390     spot chase cat
1391 } -cleanup {
1392     dog destroy
1393 } -result {::spot chases cat; ::spot barks.}
1394
1395 test method-1.3 {instances can call one another} -body {
1396     type dog {
1397         method bark {} {
1398             return "$self barks."
1399         }
1400
1401         method chase {quarry} {
1402             return "$self chases $quarry; [$quarry bark] [$self bark]"
1403         }
1404     }
1405
1406     dog create spot
1407     dog create fido
1408     spot chase ::fido
1409 } -cleanup {
1410     dog destroy
1411 } -result {::spot chases ::fido; ::fido barks. ::spot barks.}
1412
1413 test method-1.4 {upvar works in methods} -body {
1414     type dog {
1415         method goodname {varname} {
1416             upvar $varname myvar
1417             set myvar spot
1418         }
1419     }
1420
1421     dog create fido
1422     set thename fido
1423     fido goodname thename
1424     set thename
1425 } -cleanup {
1426     dog destroy
1427 } -result {spot}
1428
1429 # Case 1
1430 test method-1.5 {unknown methods get an error} -constraints {
1431     snit1
1432 } -body {
1433     type dog { }
1434
1435     dog create spot
1436     set result ""
1437     spot chase
1438 } -cleanup {
1439     dog destroy
1440 } -returnCodes {
1441     error
1442 } -result {"::spot chase" is not defined}
1443
1444 # Case 2
1445 test method-1.6 {unknown methods get an error} -constraints {
1446     snit2
1447 } -body {
1448     type dog { }
1449
1450     dog create spot
1451     set result ""
1452     spot chase
1453 } -cleanup {
1454     dog destroy
1455 } -returnCodes {
1456     error
1457 } -result {unknown subcommand "chase": namespace ::dog::Snit_inst1 does not export any commands}
1458
1459 test method-1.7 {info type method returns the object's type} -body {
1460     type dog { }
1461
1462     dog create spot
1463     spot info type
1464 } -cleanup {
1465     dog destroy
1466 } -result {::dog}
1467
1468 test method-1.8 {instance method can call type method} -body {
1469     type dog {
1470         typemethod hello {} {
1471             return "Hello"
1472         }
1473         method helloworld {} {
1474             return "[$type hello], World!"
1475         }
1476     }
1477
1478     dog create spot
1479     spot helloworld
1480 } -cleanup {
1481     dog destroy
1482 } -result {Hello, World!}
1483
1484 test method-1.9 {type methods must be qualified} -body {
1485     type dog {
1486         typemethod hello {} {
1487             return "Hello"
1488         }
1489         method helloworld {} {
1490             return "[hello], World!"
1491         }
1492     }
1493
1494     dog create spot
1495     spot helloworld
1496 } -cleanup {
1497     dog destroy
1498 } -returnCodes {
1499     error
1500 } -result {invalid command name "hello"}
1501
1502 # Case 1
1503 test method-1.10 {too few arguments} -constraints {
1504     snit1
1505 } -body {
1506     type dog {
1507         method bark {volume} { }
1508     }
1509
1510     dog create spot
1511     spot bark
1512 } -cleanup {
1513     dog destroy
1514 } -returnCodes {
1515     error
1516 } -result [tcltest::wrongNumArgs ::dog::Snit_methodbark {type selfns win self volume} 4]
1517
1518 # Case 2
1519 test method-1.11 {too few arguments} -constraints {
1520     snit2
1521 } -body {
1522     type dog {
1523         method bark {volume} { }
1524     }
1525
1526     dog create spot
1527     spot bark
1528 } -cleanup {
1529     dog destroy
1530 } -returnCodes {
1531     error
1532 } -result {wrong # args: should be "spot bark volume"}
1533
1534 # Case 1
1535 test method-1.12 {too many arguments} -constraints {
1536     snit1
1537 } -body {
1538     type dog {
1539         method bark {volume} { }
1540     }
1541
1542     dog create spot
1543
1544     spot bark really loud
1545 } -returnCodes {
1546     error
1547 } -result [tcltest::tooManyArgs ::dog::Snit_methodbark {type selfns win self volume}]
1548
1549 # Case 2
1550 test method-1.13 {too many arguments} -constraints {
1551     snit2
1552 } -body {
1553     type dog {
1554         method bark {volume} { }
1555     }
1556
1557     dog create spot
1558
1559     spot bark really loud
1560 } -cleanup {
1561     dog destroy
1562 } -returnCodes {
1563     error
1564 } -result {wrong # args: should be "spot bark volume"}
1565
1566 test method-1.14 {method args can't include type} -body {
1567     type dog {
1568         method foo {a type b} { }
1569     }
1570 } -returnCodes {
1571     error
1572 } -result {method foo's arglist may not contain "type" explicitly}
1573
1574 test method-1.15 {method args can't include self} -body {
1575     type dog {
1576         method foo {a self b} { }
1577     }
1578 } -returnCodes {
1579     error
1580 } -result {method foo's arglist may not contain "self" explicitly}
1581
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.
1586     type dog {
1587         method foo {
1588                     a
1589                     b
1590                 } { }
1591     }
1592 } -cleanup {
1593     dog destroy
1594 } -result {::dog}
1595
1596 #-----------------------------------------------------------------------
1597 # hierarchical methods
1598
1599 test hmethod-1.1 {hierarchical method, two tokens} -body {
1600     type dog {
1601         method {wag tail} {} {
1602             return "$self wags tail."
1603         }
1604     }
1605
1606     dog spot
1607     spot wag tail
1608 } -cleanup {
1609     dog destroy
1610 } -result {::spot wags tail.}
1611
1612 test hmethod-1.2 {hierarchical method, three tokens} -body {
1613     type dog {
1614         method {wag tail proudly} {} {
1615             return "$self wags tail proudly."
1616         }
1617     }
1618
1619     dog spot
1620     spot wag tail proudly
1621 } -cleanup {
1622     dog destroy
1623 } -result {::spot wags tail proudly.}
1624
1625 test hmethod-1.3 {hierarchical method, three tokens} -body {
1626     type dog {
1627         method {wag tail really high} {} {
1628             return "$self wags tail really high."
1629         }
1630     }
1631
1632     dog spot
1633     spot wag tail really high
1634 } -cleanup {
1635     dog destroy
1636 } -result {::spot wags tail really high.}
1637
1638 test hmethod-1.4 {redefinition is OK} -body {
1639     type dog {
1640         method {wag tail} {} {
1641             return "$self wags tail."
1642         }
1643         method {wag tail} {} {
1644             return "$self wags tail briskly."
1645         }
1646     }
1647
1648     dog spot
1649     spot wag tail
1650 } -cleanup {
1651     dog destroy
1652 } -result {::spot wags tail briskly.}
1653
1654 # Case 1
1655 test hmethod-1.5 {proper error on missing submethod} -constraints {
1656     snit1
1657 } -body {
1658     type dog {
1659         method {wag tail} {} { }
1660     }
1661
1662     dog spot
1663     spot wag
1664 } -cleanup {
1665     dog destroy
1666 } -returnCodes {
1667     error
1668 } -result {wrong number args: should be "::spot wag method args"}
1669
1670 # Case 2
1671 test hmethod-1.6 {proper error on missing submethod} -constraints {
1672     snit2
1673 } -body {
1674     type dog {
1675         method {wag tail} {} { }
1676     }
1677
1678     dog spot
1679     spot wag
1680 } -cleanup {
1681     dog destroy
1682 } -returnCodes {
1683     error
1684 } -result [expect \
1685                {wrong # args: should be "spot wag subcommand ?arg ...?"} \
1686                {wrong # args: should be "spot wag subcommand ?argument ...?"}]
1687
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.
1699     #
1700     # Fortunately, Anton provided the fix as well.
1701     type tail {
1702         option -manner
1703
1704         method wag {} {
1705             return "wags tail $options(-manner)"
1706         }
1707     }
1708
1709     type dog {
1710         delegate option -manner to tail
1711         delegate method {this tail wag} to tail
1712
1713         constructor {args} {
1714             set tail [tail %AUTO%]
1715             $self configurelist $args
1716         }
1717     }
1718
1719     dog fido -manner briskly
1720     dog spot -manner slowly
1721
1722     list [fido this tail wag] [spot this tail wag] [fido this tail wag]
1723 } -cleanup {
1724     dog destroy
1725     tail destroy
1726 } -result {{wags tail briskly} {wags tail slowly} {wags tail briskly}}
1727
1728 test hmethod-2.1 {prefix/method collision} -body {
1729     type dog {
1730         method wag {} {}
1731         method {wag tail} {} {
1732             return "$self wags tail."
1733         }
1734     }
1735 } -returnCodes {
1736     error
1737 } -result {Error in "method {wag tail}...", "wag" has no submethods.}
1738
1739 test hmethod-2.2 {prefix/method collision} -body {
1740     type dog {
1741         method {wag tail} {} {
1742             return "$self wags tail."
1743         }
1744         method wag {} {}
1745     }
1746 } -returnCodes {
1747     error
1748 } -result {Error in "method wag...", "wag" has submethods.}
1749
1750 test hmethod-2.3 {prefix/method collision} -body {
1751     type dog {
1752         method {wag tail} {} {}
1753         method {wag tail proudly} {} {
1754             return "$self wags tail."
1755         }
1756     }
1757 } -returnCodes {
1758     error
1759 } -result {Error in "method {wag tail proudly}...", "wag tail" has no submethods.}
1760
1761 test hmethod-2.4 {prefix/method collision} -body {
1762     type dog {
1763         method {wag tail proudly} {} {
1764             return "$self wags tail."
1765         }
1766         method {wag tail} {} {}
1767     }
1768 } -returnCodes {
1769     error
1770 } -result {Error in "method {wag tail}...", "wag tail" has submethods.}
1771
1772 #-----------------------------------------------------------------------
1773 # mymethod and renaming
1774
1775 test rename-1.1 {mymethod uses name of instance name variable} -body {
1776     type dog {
1777         method mymethod {} {
1778             list [mymethod] [mymethod "A B"] [mymethod A B]
1779         }
1780     }
1781
1782     dog fido
1783     fido mymethod
1784 } -cleanup {
1785     dog destroy
1786 } -result {{::snit::RT.CallInstance ::dog::Snit_inst1} {::snit::RT.CallInstance ::dog::Snit_inst1 {A B}} {::snit::RT.CallInstance ::dog::Snit_inst1 A B}}
1787
1788 test rename-1.2 {instances can be renamed} -body {
1789     type dog {
1790         method names {} {
1791             list [mymethod] $selfns $win $self
1792         }
1793     }
1794
1795     dog fido
1796     set a [fido names]
1797     rename fido spot
1798     set b [spot names]
1799
1800     concat $a $b
1801 } -cleanup {
1802     dog destroy
1803 } -result {{::snit::RT.CallInstance ::dog::Snit_inst1} ::dog::Snit_inst1 ::fido ::fido {::snit::RT.CallInstance ::dog::Snit_inst1} ::dog::Snit_inst1 ::fido ::spot}
1804
1805 test rename-1.3 {rename to "" deletes an instance} -constraints {
1806     bug8.5a3
1807 } -body {
1808     type dog { }
1809
1810     dog fido
1811     rename fido ""
1812     namespace children ::dog
1813 } -cleanup {
1814     dog destroy
1815 } -result {}
1816
1817 test rename-1.4 {rename to "" deletes an instance even after a rename} -constraints {
1818     bug8.5a3
1819 } -body {
1820     type dog { }
1821
1822     dog fido
1823     rename fido spot
1824     rename spot ""
1825     namespace children ::dog
1826 } -cleanup {
1827     dog destroy
1828 } -result {}
1829
1830 test rename-1.5 {creating an object twice destroys the first instance} -constraints {
1831     bug8.5a3
1832 } -body {
1833     type dog {
1834         # Can't even test this normally.
1835         pragma -canreplace yes
1836     }
1837
1838     dog fido
1839     set a [namespace children ::dog]
1840     dog fido
1841     set b [namespace children ::dog]
1842     fido destroy
1843     set c [namespace children ::dog]
1844
1845     list $a $b $c
1846 } -cleanup {
1847     dog destroy
1848 } -result {::dog::Snit_inst1 ::dog::Snit_inst2 {}}
1849
1850 #-----------------------------------------------------------------------
1851 # mymethod actually works
1852
1853 test mymethod-1.1 {run mymethod handler} -body {
1854     type foo {
1855         option -command {}
1856         method runcmd {} {
1857             eval [linsert $options(-command) end $self snarf]
1858             return
1859         }
1860     }
1861     type bar {
1862         variable sub
1863         constructor {args} {
1864             set sub [foo fubar -command [mymethod Handler]]
1865             return
1866         }
1867
1868         method Handler {args} {
1869             set ::RES $args
1870         }
1871
1872         method test {} {
1873             $sub runcmd
1874             return
1875         }
1876     }
1877
1878     set ::RES {}
1879     bar boogle
1880     boogle test
1881     set ::RES
1882 } -cleanup {
1883     bar destroy
1884     foo destroy
1885 } -result {::bar::fubar snarf}
1886
1887 #-----------------------------------------------------------------------
1888 # myproc
1889
1890 test myproc-1.1 {myproc qualifies proc names} -body {
1891     type dog {
1892         proc foo {} {}
1893
1894         typemethod getit {} {
1895             return [myproc foo]
1896         }
1897     }
1898
1899     dog getit
1900 } -cleanup {
1901     dog destroy
1902 } -result {::dog::foo}
1903
1904 test myproc-1.2 {myproc adds arguments} -body {
1905     type dog {
1906         proc foo {} {}
1907
1908         typemethod getit {} {
1909             return [myproc foo "a b"]
1910         }
1911     }
1912
1913     dog getit
1914 } -cleanup {
1915     dog destroy
1916 } -result {::dog::foo {a b}}
1917
1918 test myproc-1.3 {myproc adds arguments} -body {
1919     type dog {
1920         proc foo {} {}
1921
1922         typemethod getit {} {
1923             return [myproc foo "a b" c d]
1924         }
1925     }
1926
1927     dog getit
1928 } -cleanup {
1929     dog destroy
1930 } -result {::dog::foo {a b} c d}
1931
1932 test myproc-1.4 {procs with selfns work} -body {
1933     type dog {
1934         variable datum foo
1935
1936         method qualify {} {
1937             return [myproc getdatum $selfns]
1938         }
1939         proc getdatum {selfns} {
1940             return $datum
1941         }
1942     }
1943     dog create spot
1944     eval [spot qualify]
1945 } -cleanup {
1946     dog destroy
1947 } -result {foo}
1948
1949
1950 #-----------------------------------------------------------------------
1951 # mytypemethod
1952
1953 test mytypemethod-1.1 {mytypemethod qualifies typemethods} -body {
1954     type dog {
1955         typemethod this {} {}
1956
1957         typemethod a {} {
1958             return [mytypemethod this]
1959         }
1960         typemethod b {} {
1961             return [mytypemethod this x]
1962         }
1963         typemethod c {} {
1964             return [mytypemethod this "x y"]
1965         }
1966         typemethod d {} {
1967             return [mytypemethod this x y]
1968         }
1969     }
1970
1971     list [dog a] [dog b] [dog c] [dog d]
1972 } -cleanup {
1973     dog destroy
1974 } -result {{::dog this} {::dog this x} {::dog this {x y}} {::dog this x y}}
1975
1976 #-----------------------------------------------------------------------
1977 # typevariable
1978
1979 test typevariable-1.1 {typevarname qualifies typevariables} -body {
1980     # Note: typevarname is DEPRECATED.  Real code should use
1981     # mytypevar instead.
1982     type dog {
1983         method tvname {name} {
1984             typevarname $name
1985         }
1986     }
1987
1988     dog create spot
1989     spot tvname myvar
1990 } -cleanup {
1991     dog destroy
1992 } -result {::dog::myvar}
1993
1994 test typevariable-1.2 {undefined typevariables are OK} -body {
1995     type dog {
1996         method tset {value} {
1997             typevariable theValue
1998
1999             set theValue $value
2000         }
2001
2002         method tget {} {
2003             typevariable theValue
2004
2005             return $theValue
2006         }
2007     }
2008
2009     dog create spot
2010     dog create fido
2011     spot tset Howdy
2012
2013     list [spot tget] [fido tget] [set ::dog::theValue]
2014 } -cleanup {
2015     dog destroy
2016 } -result {Howdy Howdy Howdy}
2017
2018 test typevariable-1.3 {predefined typevariables are OK} -body {
2019     type dog {
2020         typevariable greeting Hello
2021
2022         method tget {} {
2023             return $greeting
2024         }
2025     }
2026
2027     dog create spot
2028     dog create fido
2029
2030     list [spot tget] [fido tget] [set ::dog::greeting]
2031 } -cleanup {
2032     dog destroy
2033 } -result {Hello Hello Hello}
2034
2035 test typevariable-1.4 {typevariables can be arrays} -body {
2036     type dog {
2037         typevariable greetings
2038
2039         method fill {} {
2040             set greetings(a) Hi
2041             set greetings(b) Howdy
2042         }
2043     }
2044
2045     dog create spot
2046     spot fill
2047     list $::dog::greetings(a) $::dog::greetings(b)
2048 } -cleanup {
2049     dog destroy
2050 } -result {Hi Howdy}
2051
2052 test typevariable-1.5 {typevariables can used in typemethods} -body {
2053     type dog {
2054         typevariable greetings Howdy
2055
2056         typemethod greet {} {
2057             return $greetings
2058         }
2059     }
2060
2061     dog greet
2062 } -cleanup {
2063     dog destroy
2064 } -result {Howdy}
2065
2066 test typevariable-1.6 {typevariables can used in procs} -body {
2067     type dog {
2068         typevariable greetings Howdy
2069
2070         method greet {} {
2071             return [realGreet]
2072         }
2073
2074         proc realGreet {} {
2075             return $greetings
2076         }
2077     }
2078
2079     dog create spot
2080     spot greet
2081 } -cleanup {
2082     dog destroy
2083 } -result {Howdy}
2084
2085 test typevariable-1.7 {mytypevar qualifies typevariables} -body {
2086     type dog {
2087         method tvname {name} {
2088             mytypevar $name
2089         }
2090     }
2091
2092     dog create spot
2093     spot tvname myvar
2094 } -cleanup {
2095     dog destroy
2096 } -result {::dog::myvar}
2097
2098 test typevariable-1.8 {typevariable with too many initializers throws an error} -body {
2099     type dog {
2100         typevariable color dark brown
2101     }
2102 } -returnCodes {
2103     error
2104 } -result {Error in "typevariable color...", too many initializers}
2105
2106 test typevariable-1.9 {typevariable with too many initializers throws an error} -body {
2107     type dog {
2108         typevariable color -array dark brown
2109     }
2110
2111     set result
2112 } -returnCodes {
2113     error
2114 } -result {Error in "typevariable color...", too many initializers}
2115
2116 test typevariable-1.10 {typevariable can initialize array variables} -body {
2117     type dog {
2118         typevariable data -array {
2119             family jones
2120             color brown
2121         }
2122
2123         typemethod getdata {item} {
2124             return $data($item)
2125         }
2126     }
2127
2128     list [dog getdata family] [dog getdata color]
2129 } -cleanup {
2130     dog destroy
2131 } -result {jones brown}
2132
2133 #-----------------------------------------------------------------------
2134 # instance variable
2135
2136 test ivariable-1.1 {myvar qualifies instance variables} -body {
2137     type dog {
2138         method vname {name} {
2139             myvar $name
2140         }
2141     }
2142
2143     dog create spot
2144     spot vname somevar
2145 } -cleanup {
2146     dog destroy
2147 } -result {::dog::Snit_inst1::somevar}
2148
2149 test ivariable-1.2 {undefined instance variables are OK} -body {
2150     type dog {
2151         method setgreeting {value} {
2152             variable greeting
2153
2154             set greeting $value
2155         }
2156
2157         method getgreeting {} {
2158             variable greeting
2159
2160             return $greeting
2161         }
2162     }
2163
2164     set spot [dog create spot]
2165     spot setgreeting Hey
2166
2167     dog create fido
2168     fido setgreeting Howdy
2169
2170     list [spot getgreeting] [fido getgreeting] [set ::dog::Snit_inst1::greeting]
2171 } -cleanup {
2172     dog destroy
2173 } -result {Hey Howdy Hey}
2174
2175 test ivariable-1.3 {instance variables are destroyed automatically} -body {
2176     type dog {
2177         constructor {args} {
2178             variable greeting
2179
2180             set greeting Hi
2181         }
2182     }
2183
2184     dog create spot
2185     set g1 $::dog::Snit_inst1::greeting
2186
2187     spot destroy
2188     list $g1 [info exists ::dog::Snit_inst1::greeting]
2189 } -cleanup {
2190     dog destroy
2191 } -result {Hi 0}
2192
2193 test ivariable-1.4 {defined instance variables need not be declared} -body {
2194     type dog {
2195         variable greetings
2196
2197         method put {} {
2198             set greetings Howdy
2199         }
2200
2201         method get {} {
2202             return $greetings
2203         }
2204     }
2205
2206     dog create spot
2207     spot put
2208     spot get
2209 } -cleanup {
2210     dog destroy
2211 } -result {Howdy}
2212
2213 test ivariable-1.5 {instance variables can be arrays} -body {
2214     type dog {
2215         variable greetings
2216
2217         method fill {} {
2218             set greetings(a) Hi
2219             set greetings(b) Howdy
2220         }
2221
2222         method vname {} {
2223             return [myvar greetings]
2224         }
2225     }
2226
2227     dog create spot
2228     spot fill
2229     list [set [spot vname](a)] [set [spot vname](b)]
2230 } -cleanup {
2231     dog destroy
2232 } -result {Hi Howdy}
2233
2234 test ivariable-1.6 {instance variables can be initialized in the definition} -body {
2235     type dog {
2236         variable greetings {Hi Howdy}
2237         variable empty {}
2238
2239         method list {} {
2240             list $greetings $empty
2241         }
2242     }
2243
2244     dog create spot
2245     spot list
2246 } -cleanup {
2247     dog destroy
2248 } -result {{Hi Howdy} {}}
2249
2250 test ivariable-1.7 {variable is illegal when selfns is undefined} -body {
2251     type dog {
2252         method caller {} {
2253             callee
2254         }
2255         proc callee {} {
2256             variable foo
2257         }
2258     }
2259
2260     dog create spot
2261
2262     spot caller
2263 } -returnCodes {
2264     error
2265 } -cleanup {
2266     dog destroy
2267 } -result {can't read "selfns": no such variable}
2268
2269 test ivariable-1.8 {myvar is illegal when selfns is undefined} -body {
2270     type dog {
2271         method caller {} {
2272             callee
2273         }
2274         proc callee {} {
2275             myvar foo
2276         }
2277     }
2278
2279     dog create spot
2280
2281     spot caller
2282 } -returnCodes {
2283     error
2284 } -cleanup {
2285     dog destroy
2286 } -result {can't read "selfns": no such variable}
2287
2288 test ivariable-1.9 {procs which define selfns see instance variables} -body {
2289     type dog {
2290         variable greeting Howdy
2291
2292         method caller {} {
2293             return [callee $selfns]
2294         }
2295
2296         proc callee {selfns} {
2297             return $greeting
2298         }
2299     }
2300
2301     dog create spot
2302
2303     spot caller
2304 } -cleanup {
2305     dog destroy
2306 } -result {Howdy}
2307
2308 test ivariable-1.10 {in methods, variable works with fully qualified names} -body {
2309     namespace eval ::somenamespace:: {
2310         set somevar somevalue
2311     }
2312
2313     type dog {
2314         method get {} {
2315             variable ::somenamespace::somevar
2316             return $somevar
2317         }
2318     }
2319
2320     dog create spot
2321
2322     spot get
2323 } -cleanup {
2324     dog destroy
2325 } -result {somevalue}
2326
2327 test ivariable-1.11 {variable with too many initializers throws an error} -body {
2328     type dog {
2329         variable color dark brown
2330     }
2331 } -returnCodes {
2332     error
2333 } -result {Error in "variable color...", too many initializers}
2334
2335 test ivariable-1.12 {variable with too many initializers throws an error} -body {
2336     type dog {
2337         variable color -array dark brown
2338     }
2339 } -returnCodes {
2340     error
2341 } -result {Error in "variable color...", too many initializers}
2342
2343 test ivariable-1.13 {variable can initialize array variables} -body {
2344     type dog {
2345         variable data -array {
2346             family jones
2347             color brown
2348         }
2349
2350         method getdata {item} {
2351             return $data($item)
2352         }
2353     }
2354
2355     dog spot
2356     list [spot getdata family] [spot getdata color]
2357 } -cleanup {
2358     dog destroy
2359 } -result {jones brown}
2360
2361 #-----------------------------------------------------------------------
2362 # codename
2363 #
2364 # NOTE: codename is deprecated; myproc should be used instead.
2365
2366 test codename-1.1 {codename qualifies procs} -body {
2367     type dog {
2368         method qualify {} {
2369             return [codename myproc]
2370         }
2371         proc myproc {} { }
2372     }
2373     dog create spot
2374     spot qualify
2375 } -cleanup {
2376     dog destroy
2377 } -result {::dog::myproc}
2378
2379 test codename-1.2 {procs with selfns work} -body {
2380     type dog {
2381         variable datum foo
2382
2383         method qualify {} {
2384             return [list [codename getdatum] $selfns]
2385         }
2386         proc getdatum {selfns} {
2387             return $datum
2388         }
2389     }
2390     dog create spot
2391     eval [spot qualify]
2392 } -cleanup {
2393     dog destroy
2394 } -result {foo}
2395
2396 #-----------------------------------------------------------------------
2397 # Options
2398
2399 test option-1.1 {options get default values} -body {
2400     type dog {
2401         option -color golden
2402     }
2403
2404     dog create spot
2405     spot cget -color
2406 } -cleanup {
2407     dog destroy
2408 } -result {golden}
2409
2410 test option-1.2 {options can be set} -body {
2411     type dog {
2412         option -color golden
2413     }
2414
2415     dog create spot
2416     spot configure -color black
2417     spot cget -color
2418 } -cleanup {
2419     dog destroy
2420 } -result {black}
2421
2422 test option-1.3 {multiple options can be set} -body {
2423     type dog {
2424         option -color golden
2425         option -akc 0
2426     }
2427
2428     dog create spot
2429     spot configure -color brown -akc 1
2430     list [spot cget -color] [spot cget -akc]
2431 } -cleanup {
2432     dog destroy
2433 } -result {brown 1}
2434
2435 test option-1.4 {options can be retrieved as instance variable} -body {
2436     type dog {
2437         option -color golden
2438         option -akc 0
2439
2440         method listopts {} {
2441             list $options(-color) $options(-akc)
2442         }
2443     }
2444
2445     dog create spot
2446     spot configure -color black -akc 1
2447     spot listopts
2448 } -cleanup {
2449     dog destroy
2450 } -result {black 1}
2451
2452 test option-1.5 {options can be set as an instance variable} -body {
2453     type dog {
2454         option -color golden
2455         option -akc 0
2456
2457         method setopts {} {
2458             set options(-color) black
2459             set options(-akc) 1
2460         }
2461     }
2462
2463     dog create spot
2464     spot setopts
2465     list [spot cget -color] [spot cget -akc]
2466 } -cleanup {
2467     dog destroy
2468 } -result {black 1}
2469
2470 test option-1.6 {options can be set at creation time} -body {
2471     type dog {
2472         option -color golden
2473         option -akc 0
2474     }
2475
2476     dog create spot -color white -akc 1
2477     list [spot cget -color] [spot cget -akc]
2478 } -cleanup {
2479     dog destroy
2480 } -result {white 1}
2481
2482 test option-1.7 {undefined option: cget} -body {
2483     type dog {
2484         option -color golden
2485         option -akc 0
2486     }
2487
2488     dog create spot
2489     spot cget -colour
2490 } -returnCodes {
2491     error
2492 } -cleanup {
2493     dog destroy
2494 } -result {unknown option "-colour"}
2495
2496 test option-1.8 {undefined option: configure} -body {
2497     type dog {
2498         option -color golden
2499         option -akc 0
2500     }
2501
2502     dog create spot
2503     spot configure -colour blue
2504 } -returnCodes {
2505     error
2506 } -cleanup {
2507     dog destroy
2508 } -result {unknown option "-colour"}
2509
2510 test option-1.9 {options default to ""} -body {
2511     type dog {
2512         option -color
2513     }
2514
2515     dog create spot
2516     spot cget -color
2517 } -cleanup {
2518     dog destroy
2519 } -result {}
2520
2521 test option-1.10 {spaces allowed in option defaults} -body {
2522     type dog {
2523         option -breed "golden retriever"
2524     }
2525     dog fido
2526     fido cget -breed
2527 } -cleanup {
2528     dog destroy
2529 } -result {golden retriever}
2530
2531 test option-1.11 {brackets allowed in option defaults} -body {
2532     type dog {
2533         option -regexp {[a-z]+}
2534     }
2535
2536     dog fido
2537     fido cget -regexp
2538 } -cleanup {
2539     dog destroy
2540 } -result {[a-z]+}
2541
2542 test option-2.1 {configure returns info, local options only} -body {
2543     type dog {
2544         option -color black
2545         option -akc 1
2546     }
2547
2548     dog create spot
2549     spot configure -color red
2550     spot configure -akc 0
2551     spot configure
2552 } -cleanup {
2553     dog destroy
2554 } -result {{-color color Color black red} {-akc akc Akc 1 0}}
2555
2556 test option-2.2 {configure -opt returns info, local options only} -body {
2557     type dog {
2558         option -color black
2559         option -akc 1
2560     }
2561
2562     dog create spot
2563     spot configure -color red
2564     spot configure -color
2565 } -cleanup {
2566     dog destroy
2567 } -result {-color color Color black red}
2568
2569 test option-2.3 {configure -opt returns info, explicit options} -body {
2570     type papers {
2571         option -akcflag 1
2572     }
2573
2574     type dog {
2575         option -color black
2576         delegate option -akc to papers as -akcflag
2577         constructor {args} {
2578             set papers [papers create $self.papers]
2579         }
2580
2581         destructor {
2582             catch {$self.papers destroy}
2583         }
2584     }
2585
2586     dog create spot
2587     spot configure -akc 0
2588     spot configure -akc
2589 } -cleanup {
2590     dog destroy
2591 } -result {-akc akc Akc 1 0}
2592
2593 test option-2.4 {configure -unknownopt} -body {
2594     type papers {
2595         option -akcflag 1
2596     }
2597
2598     type dog {
2599         option -color black
2600         delegate option -akc to papers as -akcflag
2601         constructor {args} {
2602             set papers [papers create $self.papers]
2603         }
2604
2605         destructor {
2606             catch {$self.papers destroy}
2607         }
2608     }
2609
2610     dog create spot
2611     spot configure -foo
2612 } -returnCodes {
2613     error
2614 } -cleanup {
2615     dog destroy
2616     papers destroy
2617 } -result {unknown option "-foo"}
2618
2619 test option-2.5 {configure returns info, unknown options} -constraints {
2620     tk
2621 } -body {
2622     widgetadaptor myframe {
2623         option -foo a
2624         delegate option -width to hull
2625         delegate option * to hull
2626         constructor {args} {
2627             installhull [frame $self]
2628         }
2629     }
2630
2631     myframe .frm
2632     set a [.frm configure -foo]
2633     set b [.frm configure -width]
2634     set c [.frm configure -height]
2635     destroy .frm
2636     tkbide
2637
2638     list $a $b $c
2639
2640 } -cleanup {
2641     myframe destroy
2642 } -result {{-foo foo Foo a a} {-width width Width 0 0} {-height height Height 0 0}}
2643
2644 test option-2.6 {configure -opt unknown to implicit component} -constraints {
2645     tk
2646 } -body {
2647     widgetadaptor myframe {
2648         delegate option * to hull
2649         constructor {args} {
2650             installhull [frame $self]
2651         }
2652     }
2653     myframe .frm
2654     catch {.frm configure -quux} result
2655     destroy .frm
2656     tkbide
2657     set result
2658 } -cleanup {
2659     myframe destroy
2660 } -result {unknown option "-quux"}
2661
2662 test option-3.1 {set option resource name explicitly} -body {
2663     type dog {
2664         option {-tailcolor tailColor} black
2665     }
2666
2667     dog fido
2668
2669     fido configure -tailcolor
2670 } -cleanup {
2671     dog destroy
2672 } -result {-tailcolor tailColor TailColor black black}
2673
2674 test option-3.2 {set option class name explicitly} -body {
2675     type dog {
2676         option {-tailcolor tailcolor TailColor} black
2677     }
2678
2679     dog fido
2680
2681     fido configure -tailcolor
2682 } -cleanup {
2683     dog destroy
2684 } -result {-tailcolor tailcolor TailColor black black}
2685
2686 test option-3.3 {delegated option's names come from owner} -body {
2687     type tail {
2688         option -color black
2689     }
2690
2691     type dog {
2692         delegate option -tailcolor to tail as -color
2693
2694         constructor {args} {
2695             set tail [tail fidotail]
2696         }
2697     }
2698
2699     dog fido
2700
2701     fido configure -tailcolor
2702 } -cleanup {
2703     dog destroy
2704     tail destroy
2705 } -result {-tailcolor tailcolor Tailcolor black black}
2706
2707 test option-3.4 {delegated option's resource name set explicitly} -body {
2708     type tail {
2709         option -color black
2710     }
2711
2712     type dog {
2713         delegate option {-tailcolor tailColor} to tail as -color
2714
2715         constructor {args} {
2716             set tail [tail fidotail]
2717         }
2718     }
2719
2720     dog fido
2721
2722     fido configure -tailcolor
2723 } -cleanup {
2724     dog destroy
2725     tail destroy
2726 } -result {-tailcolor tailColor TailColor black black}
2727
2728 test option-3.5 {delegated option's class name set explicitly} -body {
2729     type tail {
2730         option -color black
2731     }
2732
2733     type dog {
2734         delegate option {-tailcolor tailcolor TailColor} to tail as -color
2735
2736         constructor {args} {
2737             set tail [tail fidotail]
2738         }
2739     }
2740
2741     dog fido
2742
2743     fido configure -tailcolor
2744 } -cleanup {
2745     dog destroy
2746     tail destroy
2747 } -result {-tailcolor tailcolor TailColor black black}
2748
2749 test option-3.6 {delegated option's default comes from component} -body {
2750     type tail {
2751         option -color black
2752     }
2753
2754     type dog {
2755         delegate option -tailcolor to tail as -color
2756
2757         constructor {args} {
2758             set tail [tail fidotail -color red]
2759         }
2760     }
2761
2762     dog fido
2763
2764     fido configure -tailcolor
2765 } -cleanup {
2766     dog destroy
2767     tail destroy
2768 } -result {-tailcolor tailcolor Tailcolor black red}
2769
2770 test option-4.1 {local option name must begin with hyphen} -body {
2771     type dog {
2772         option nohyphen
2773     }
2774 } -returnCodes {
2775     error
2776 } -result {Error in "option nohyphen...", badly named option "nohyphen"}
2777
2778 test option-4.2 {local option name must be lower case} -body {
2779     type dog {
2780         option -Upper
2781     }
2782 } -returnCodes {
2783     error
2784 } -result {Error in "option -Upper...", badly named option "-Upper"}
2785
2786 test option-4.3 {local option name may not contain spaces} -body {
2787     type dog {
2788         option {"-with space"}
2789     }
2790 } -returnCodes {
2791     error
2792 } -result {Error in "option {"-with space"}...", badly named option "-with space"}
2793
2794 test option-4.4 {delegated option name must begin with hyphen} -body {
2795     type dog {
2796         delegate option nohyphen to tail
2797     }
2798 } -returnCodes {
2799     error
2800 } -result {Error in "delegate option nohyphen...", badly named option "nohyphen"}
2801
2802 test option-4.5 {delegated option name must be lower case} -body {
2803     type dog {
2804         delegate option -Upper to tail
2805     }
2806 } -returnCodes {
2807     error
2808 } -result {Error in "delegate option -Upper...", badly named option "-Upper"}
2809
2810 test option-4.6 {delegated option name may not contain spaces} -body {
2811     type dog {
2812         delegate option {"-with space"} to tail
2813     }
2814 } -returnCodes {
2815     error
2816 } -result {Error in "delegate option {"-with space"}...", badly named option "-with space"}
2817
2818 test option-5.1 {local widget options read from option database} -constraints {
2819     tk
2820 } -body {
2821     widget dog {
2822         option -foo a
2823         option -bar b
2824
2825         typeconstructor {
2826             option add *Dog.bar bb
2827         }
2828     }
2829
2830     dog .fido
2831     set a [.fido cget -foo]
2832     set b [.fido cget -bar]
2833     destroy .fido
2834     tkbide
2835
2836     list $a $b
2837
2838 } -cleanup {
2839     dog destroy
2840 } -result {a bb}
2841
2842 test option-5.2 {local option database values available in constructor} -constraints {
2843     tk
2844 } -body {
2845     widget dog {
2846         option -bar b
2847         variable saveit
2848
2849         typeconstructor {
2850             option add *Dog.bar bb
2851         }
2852
2853         constructor {args} {
2854             set saveit $options(-bar)
2855         }
2856
2857         method getit {} {
2858             return $saveit
2859         }
2860     }
2861
2862     dog .fido
2863     set result [.fido getit]
2864     destroy .fido
2865     tkbide
2866
2867     set result
2868 } -cleanup {
2869     dog destroy
2870 } -result {bb}
2871
2872 test option-6.1 {if no options, no options variable} -body {
2873     type dog {
2874         variable dummy
2875     }
2876
2877     dog spot
2878     spot info vars options
2879 } -cleanup {
2880     dog destroy
2881 } -result {}
2882
2883 test option-6.2 {if no options, no options methods} -body {
2884     type dog {
2885         variable dummy
2886     }
2887
2888     dog spot
2889     spot info methods c*
2890 } -cleanup {
2891     dog destroy
2892 } -result {}
2893
2894 #-----------------------------------------------------------------------
2895 # onconfigure
2896
2897 test onconfigure-1.1 {invalid onconfigure methods are caught} -body {
2898     type dog {
2899         onconfigure -color {value} { }
2900     }
2901 } -returnCodes {
2902     error
2903 } -result {onconfigure -color: option "-color" unknown}
2904
2905 test onconfigure-1.2 {onconfigure methods take one argument} -body {
2906     type dog {
2907         option -color golden
2908
2909         onconfigure -color {value badarg} { }
2910     }
2911 } -returnCodes {
2912     error
2913 } -result {onconfigure -color handler should have one argument, got "value badarg"}
2914
2915 test onconfigure-1.3 {onconfigure methods work} -body {
2916     type dog {
2917         option -color golden
2918
2919         onconfigure -color {value} {
2920             set options(-color) "*$value*"
2921         }
2922     }
2923
2924     dog create spot
2925     spot configure -color brown
2926     spot cget -color
2927 } -cleanup {
2928     dog destroy
2929 } -result {*brown*}
2930
2931 test onconfigure-1.4 {onconfigure arg can't be type} -body {
2932     type dog {
2933         option -color
2934         onconfigure -color {type} { }
2935     }
2936 } -returnCodes {
2937     error
2938 } -result {onconfigure -color's arglist may not contain "type" explicitly}
2939
2940 test onconfigure-1.5 {onconfigure arg can't be self} -body {
2941     type dog {
2942         option -color
2943         onconfigure -color {self} { }
2944     }
2945 } -returnCodes {
2946     error
2947 } -result {onconfigure -color's arglist may not contain "self" explicitly}
2948
2949 #-----------------------------------------------------------------------
2950 # oncget
2951
2952 test oncget-1.1 {invalid oncget methods are caught} -body {
2953     type dog {
2954         oncget -color { }
2955     }
2956 } -returnCodes {
2957     error
2958 } -result {Error in "oncget -color...", option "-color" unknown}
2959
2960 test oncget-1.2 {oncget methods work} -body {
2961     cleanup
2962
2963     type dog {
2964         option -color golden
2965
2966         oncget -color {
2967             return "*$options(-color)*"
2968         }
2969     }
2970
2971     dog create spot
2972     spot configure -color brown
2973     spot cget -color
2974 } -cleanup {
2975     dog destroy
2976 } -result {*brown*}
2977
2978 #-----------------------------------------------------------------------
2979 # constructor
2980
2981
2982 test constructor-1.1 {constructor can do things} -body {
2983     type dog {
2984         variable a
2985         variable b
2986         constructor {args} {
2987             set a 1
2988             set b 2
2989         }
2990         method foo {} {
2991             list $a $b
2992         }
2993     }
2994
2995     dog create spot
2996     spot foo
2997 } -cleanup {
2998     dog destroy
2999 } -result {1 2}
3000
3001 test constructor-1.2 {constructor with no configurelist ignores args} -body {
3002     type dog {
3003         constructor {args} { }
3004         option -color golden
3005         option -akc 0
3006     }
3007
3008     dog create spot -color white -akc 1
3009     list [spot cget -color] [spot cget -akc]
3010 } -cleanup {
3011     dog destroy
3012 } -result {golden 0}
3013
3014 test constructor-1.3 {constructor with configurelist gets args} -body {
3015     type dog {
3016         constructor {args} {
3017             $self configurelist $args
3018         }
3019         option -color golden
3020         option -akc 0
3021     }
3022
3023     dog create spot -color white -akc 1
3024     list [spot cget -color] [spot cget -akc]
3025 } -cleanup {
3026     dog destroy
3027 } -result {white 1}
3028
3029 test constructor-1.4 {constructor with specific args} -body {
3030     type dog {
3031         option -value ""
3032         constructor {a b args} {
3033             set options(-value) [list $a $b $args]
3034         }
3035     }
3036
3037     dog spot retriever golden -akc 1
3038     spot cget -value
3039 } -cleanup {
3040     dog destroy
3041 } -result {retriever golden {-akc 1}}
3042
3043 test constructor-1.5 {constructor with list as one list arg} -body {
3044     type dog {
3045         option -value ""
3046         constructor {args} {
3047             set options(-value) $args
3048         }
3049     }
3050
3051     dog spot {retriever golden}
3052     spot cget -value
3053 } -cleanup {
3054     dog destroy
3055 } -result {{retriever golden}}
3056
3057 test constructor-1.6 {default constructor configures options} -body {
3058     type dog {
3059         option -color brown
3060         option -breed mutt
3061     }
3062
3063     dog spot -color golden -breed retriever
3064     list [spot cget -color] [spot cget -breed]
3065 } -cleanup {
3066     dog destroy
3067 } -result {golden retriever}
3068
3069 test constructor-1.7 {default constructor takes no args if no options} -body {
3070     type dog {
3071         variable color
3072     }
3073
3074     dog spot -color golden
3075 } -returnCodes {
3076     error
3077 } -result "Error in constructor: [tcltest::tooManyArgs ::dog::Snit_constructor {type selfns win self}]"
3078
3079 #-----------------------------------------------------------------------
3080 # destroy
3081
3082 test destroy-1.1 {destroy cleans up the instance} -body {
3083     type dog {
3084         option -color golden
3085     }
3086
3087     set a [namespace children ::dog::]
3088     dog create spot
3089     set b [namespace children ::dog::]
3090     spot destroy
3091     set c [namespace children ::dog::]
3092     list $a $b $c [info commands ::dog::spot]
3093 } -cleanup {
3094     dog destroy
3095 } -result {{} ::dog::Snit_inst1 {} {}}
3096
3097 test destroy-1.2 {incomplete objects are destroyed} -body {
3098     array unset ::dog::snit_ivars
3099
3100     type dog {
3101         option -color golden
3102
3103         constructor {args} {
3104             $self configurelist $args
3105
3106             if {"red" == [$self cget -color]} {
3107                 error "No Red Dogs!"
3108             }
3109         }
3110     }
3111
3112     catch {dog create spot -color red} result
3113     set names [array names ::dog::snit_ivars]
3114     list $result $names [info commands ::dog::spot]
3115 } -cleanup {
3116     dog destroy
3117 } -result {{Error in constructor: No Red Dogs!} {} {}}
3118
3119 test destroy-1.3 {user-defined destructors are called} -body {
3120     type dog {
3121         typevariable flag ""
3122
3123         constructor {args} {
3124             set flag "created $self"
3125         }
3126
3127         destructor {
3128             set flag "destroyed $self"
3129         }
3130
3131         typemethod getflag {} {
3132             return $flag
3133         }
3134     }
3135
3136     dog create spot
3137     set a [dog getflag]
3138     spot destroy
3139     list $a [dog getflag]
3140 } -cleanup {
3141     dog destroy
3142 } -result {{created ::spot} {destroyed ::spot}}
3143
3144 #-----------------------------------------------------------------------
3145 # delegate: general syntax tests
3146
3147 test delegate-1.1 {can only delegate methods or options} -body {
3148     type dog {
3149         delegate foo bar to baz
3150     }
3151 } -returnCodes {
3152     error
3153 } -result {Error in "delegate foo bar...", "foo"?}
3154
3155 test delegate-1.2 {"to" must appear in the right place} -body {
3156     type dog {
3157         delegate method foo from bar
3158     }
3159 } -returnCodes {
3160     error
3161 } -result {Error in "delegate method foo...", unknown delegation option "from"}
3162
3163 test delegate-1.3 {"as" must have a target} -body {
3164     type dog {
3165         delegate method foo to bar as
3166     }
3167 } -returnCodes {
3168     error
3169 } -result {Error in "delegate method foo...", invalid syntax}
3170
3171 test delegate-1.4 {"as" must have a single target} -body {
3172     type dog {
3173         delegate method foo to bar as baz quux
3174     }
3175 } -returnCodes {
3176     error
3177 } -result {Error in "delegate method foo...", unknown delegation option "quux"}
3178
3179 test delegate-1.5 {"as" doesn't work with "*"} -body {
3180     type dog {
3181         delegate method * to hull as foo
3182     }
3183 } -returnCodes {
3184     error
3185 } -result {Error in "delegate method *...", cannot specify "as" with "*"}
3186
3187 test delegate-1.6 {"except" must have a target} -body {
3188     type dog {
3189         delegate method * to bar except
3190     }
3191 } -returnCodes {
3192     error
3193 } -result {Error in "delegate method *...", invalid syntax}
3194
3195 test delegate-1.7 {"except" must have a single target} -body {
3196     type dog {
3197         delegate method * to bar except baz quux
3198     }
3199 } -returnCodes {
3200     error
3201 } -result {Error in "delegate method *...", unknown delegation option "quux"}
3202
3203 test delegate-1.8 {"except" works only with "*"} -body {
3204     type dog {
3205         delegate method foo to hull except bar
3206     }
3207 } -returnCodes {
3208     error
3209 } -result {Error in "delegate method foo...", can only specify "except" with "*"}
3210
3211 test delegate-1.9 {only "as" or "except"} -body {
3212     type dog {
3213         delegate method foo to bar with quux
3214     }
3215 } -returnCodes {
3216     error
3217 } -result {Error in "delegate method foo...", unknown delegation option "with"}
3218
3219
3220 #-----------------------------------------------------------------------
3221 # delegated methods
3222
3223 test dmethod-1.1 {delegate method to non-existent component} -body {
3224     type dog {
3225         delegate method foo to bar
3226     }
3227
3228     dog create spot
3229     spot foo
3230 } -returnCodes {
3231     error
3232 } -cleanup {
3233     dog destroy
3234 } -result {::dog ::spot delegates method "foo" to undefined component "bar"}
3235
3236 test dmethod-1.2 {delegating to existing component} -body {
3237     type dog {
3238         constructor {args} {
3239             set string string
3240         }
3241
3242         delegate method length to string
3243     }
3244
3245     dog create spot
3246     spot length foo
3247 } -cleanup {
3248     dog destroy
3249 } -result {3}
3250
3251 # Case 1
3252 test dmethod-1.3 {delegating to existing component with error} -constraints {
3253     snit1
3254 } -body {
3255     type dog {
3256         constructor {args} {
3257             set string string
3258         }
3259
3260         delegate method length to string
3261     }
3262
3263     dog create spot
3264     spot length foo bar
3265 } -cleanup {
3266     dog destroy
3267 } -returnCodes {
3268     error
3269 } -result {wrong # args: should be "string length string"}
3270
3271 # Case 2
3272 test dmethod-1.4 {delegating to existing component with error} -constraints {
3273     snit2
3274 } -body {
3275     type dog {
3276         constructor {args} {
3277             set string string
3278         }
3279
3280         delegate method length to string
3281     }
3282
3283     dog create spot
3284     spot length foo bar
3285 } -cleanup {
3286     dog destroy
3287 } -returnCodes {
3288     error
3289 } -result {wrong # args: should be "spot length string"}
3290
3291 test dmethod-1.5 {delegating unknown methods to existing component} -body {
3292     type dog {
3293         constructor {args} {
3294             set string string
3295         }
3296
3297         delegate method * to string
3298     }
3299
3300     dog create spot
3301     spot length foo
3302 } -cleanup {
3303     dog destroy
3304 } -result {3}
3305
3306 test dmethod-1.6 {delegating unknown method to existing component with error} -body {
3307     type dog {
3308         constructor {args} {
3309             set stringhandler string
3310         }
3311
3312         delegate method * to stringhandler
3313     }
3314
3315     dog create spot
3316     spot foo bar
3317 } -constraints {
3318     snit1
3319 } -returnCodes {
3320     error
3321 } -cleanup {
3322     dog destroy
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}
3324
3325 test dmethod-1.6a {delegating unknown method to existing component with error} -body {
3326     type dog {
3327         constructor {args} {
3328             set stringhandler string
3329         }
3330
3331         delegate method * to stringhandler
3332     }
3333
3334     dog create spot
3335     spot foo bar
3336 } -constraints {
3337     snit2
3338 } -returnCodes {
3339     error
3340 } -cleanup {
3341     dog destroy
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}
3343
3344 test dmethod-1.7 {can't delegate local method: order 1} -body {
3345     type cat {
3346         method foo {} {}
3347         delegate method foo to hull
3348     }
3349 } -returnCodes {
3350     error
3351 } -result {Error in "delegate method foo...", "foo" has been defined locally.}
3352
3353 test dmethod-1.8 {can't delegate local method: order 2} -body {
3354     type cat {
3355         delegate method foo to hull
3356         method foo {} {}
3357     }
3358 } -returnCodes {
3359     error
3360 } -result {Error in "method foo...", "foo" has been delegated}
3361
3362 # Case 1
3363 test dmethod-1.9 {excepted methods are caught properly} -constraints {
3364     snit1
3365 } -body {
3366     type tail {
3367         method wag {}    {return "wagged"}
3368         method flaunt {} {return "flaunted"}
3369         method tuck {}   {return "tuck"}
3370     }
3371
3372     type cat {
3373         method meow {} {}
3374         delegate method * to tail except {wag tuck}
3375
3376         constructor {args} {
3377             set tail [tail %AUTO%]
3378         }
3379     }
3380
3381     cat fifi
3382
3383     catch {fifi flaunt} a
3384     catch {fifi wag}    b
3385     catch {fifi tuck}   c
3386
3387     list $a $b $c
3388 } -cleanup {
3389     cat destroy
3390     tail destroy
3391 } -result {flaunted {"::fifi wag" is not defined} {"::fifi tuck" is not defined}}
3392
3393 # Case 2
3394 test dmethod-1.10 {excepted methods are caught properly} -constraints {
3395     snit2
3396 } -body {
3397     type tail {
3398         method wag {}    {return "wagged"}
3399         method flaunt {} {return "flaunted"}
3400         method tuck {}   {return "tuck"}
3401     }
3402
3403     type cat {
3404         method meow {} {}
3405         delegate method * to tail except {wag tuck}
3406
3407         constructor {args} {
3408             set tail [tail %AUTO%]
3409         }
3410     }
3411
3412     cat fifi
3413
3414     catch {fifi flaunt} a
3415     catch {fifi wag}    b
3416     catch {fifi tuck}   c
3417
3418     list $a $b $c
3419 } -cleanup {
3420     cat destroy
3421     tail destroy
3422 } -result {flaunted {unknown subcommand "wag": must be flaunt} {unknown subcommand "tuck": must be flaunt}}
3423
3424 test dmethod-1.11 {as clause can include arguments} -body {
3425     type tail {
3426         method wag {adverb}    {return "wagged $adverb"}
3427     }
3428
3429     type dog {
3430         delegate method wag to tail as {wag briskly}
3431
3432         constructor {args} {
3433             set tail [tail %AUTO%]
3434         }
3435     }
3436
3437     dog spot
3438
3439     spot wag
3440 } -cleanup {
3441     dog destroy
3442     tail destroy
3443 } -result {wagged briskly}
3444
3445 test dmethod-2.1 {'using "%c %m"' gets normal behavior} -body {
3446     type tail {
3447         method wag {adverb}    {return "wagged $adverb"}
3448     }
3449
3450     type dog {
3451         delegate method wag to tail using {%c %m}
3452
3453         constructor {args} {
3454             set tail [tail %AUTO%]
3455         }
3456     }
3457
3458     dog spot
3459
3460     spot wag briskly
3461 } -cleanup {
3462     dog destroy
3463     tail destroy
3464 } -result {wagged briskly}
3465
3466 test dmethod-2.2 {All 'using' conversions are converted} -body {
3467     proc echo {args} { return $args }
3468
3469     type dog {
3470         delegate method {tail wag} using {echo %% %t %M %m %j %n %w %s %c}
3471     }
3472
3473     dog spot
3474
3475     spot tail wag
3476 } -cleanup {
3477     dog destroy
3478     rename echo ""
3479 } -result {% ::dog {tail wag} wag tail_wag ::dog::Snit_inst1 ::spot ::spot %c}
3480
3481 test dmethod-2.3 {"%%" is handled properly} -body {
3482     proc echo {args} { join $args "|" }
3483
3484     type dog {
3485         delegate method wag using {echo %%m %%%m}
3486     }
3487
3488     dog spot
3489
3490     spot wag
3491 } -cleanup {
3492     dog destroy
3493     rename echo ""
3494 } -result {%m|%wag}
3495
3496 test dmethod-2.4 {Method "*" and "using"} -body {
3497     proc echo {args} { join $args "|" }
3498
3499     type dog {
3500         delegate method * using {echo %m}
3501     }
3502
3503     dog spot
3504
3505     list [spot wag] [spot bark loudly]
3506 } -cleanup {
3507     dog destroy
3508     rename echo ""
3509 } -result {wag bark|loudly}
3510
3511
3512 test dmethod-3.1 {component names can be changed dynamically} -body {
3513     type tail1 {
3514         method wag {}    {return "wagged"}
3515     }
3516
3517     type tail2 {
3518         method wag {}    {return "drooped"}
3519     }
3520
3521     type dog {
3522         delegate method wag to tail
3523
3524         constructor {args} {
3525             set tail [tail1 %AUTO%]
3526         }
3527
3528         method switchit {} {
3529             set tail [tail2 %AUTO%]
3530         }
3531     }
3532
3533     dog fido
3534
3535     set a [fido wag]
3536     fido switchit
3537     set b [fido wag]
3538
3539     list $a $b
3540 } -cleanup {
3541     dog destroy
3542     tail1 destroy
3543     tail2 destroy
3544 } -result {wagged drooped}
3545
3546 test dmethod-4.1 {hierarchical method, two tokens} -body {
3547     type tail {
3548         method wag {} {return "wags tail"}
3549     }
3550
3551     type dog {
3552         constructor {} {
3553             set tail [tail %AUTO%]
3554         }
3555         delegate method {wag tail} to tail as wag
3556     }
3557
3558     dog spot
3559     spot wag tail
3560 } -cleanup {
3561     dog destroy
3562     tail destroy
3563 } -result {wags tail}
3564
3565 test dmethod-4.2 {hierarchical method, three tokens} -body {
3566     type tail {
3567         method wag {} {return "wags tail"}
3568     }
3569
3570     type dog {
3571         constructor {} {
3572             set tail [tail %AUTO%]
3573         }
3574         delegate method {wag tail proudly} to tail as wag
3575     }
3576
3577     dog spot
3578     spot wag tail proudly
3579 } -cleanup {
3580     dog destroy
3581     tail destroy
3582 } -result {wags tail}
3583
3584 test dmethod-4.3 {hierarchical method, three tokens} -body {
3585     type tail {
3586         method wag {} {return "wags tail"}
3587     }
3588
3589     type dog {
3590         constructor {} {
3591             set tail [tail %AUTO%]
3592         }
3593         delegate method {wag tail really high} to tail as wag
3594     }
3595
3596     dog spot
3597     spot wag tail really high
3598 } -cleanup {
3599     dog destroy
3600     tail destroy
3601 } -result {wags tail}
3602
3603 test dmethod-4.4 {redefinition is OK} -body {
3604     type tail {
3605         method {wag tail}    {} {return "wags tail"}
3606         method {wag briskly} {} {return "wags tail briskly"}
3607     }
3608
3609     type dog {
3610         constructor {} {
3611             set tail [tail %AUTO%]
3612         }
3613         delegate method {wag tail} to tail as {wag tail}
3614         delegate method {wag tail} to tail as {wag briskly}
3615     }
3616
3617     dog spot
3618     spot wag tail
3619 } -cleanup {
3620     dog destroy
3621     tail destroy
3622 } -result {wags tail briskly}
3623
3624 test dmethod-4.5 {all tokens are used by default} -body {
3625     type tail {
3626         method wag {} {return "wags tail"}
3627     }
3628
3629     type dog {
3630         constructor {} {
3631             set tail [tail %AUTO%]
3632         }
3633         delegate method {tail wag} to tail
3634     }
3635
3636     dog spot
3637     spot tail wag
3638 } -cleanup {
3639     dog destroy
3640     tail destroy
3641 } -result {wags tail}
3642
3643 test dmethod-4.6 {last token can be *} -body {
3644     type tail {
3645         method wag {} {return "wags"}
3646         method droop {} {return "droops"}
3647     }
3648
3649     type dog {
3650         constructor {} {
3651             set tail [tail %AUTO%]
3652         }
3653         delegate method {tail *} to tail
3654     }
3655
3656     dog spot
3657
3658     list [spot tail wag] [spot tail droop]
3659 } -cleanup {
3660     dog destroy
3661     tail destroy
3662 } -result {wags droops}
3663
3664 # Case 1
3665 test dmethod-4.7 {except with multiple tokens} -constraints {
3666     snit1
3667 } -body {
3668     type tail {
3669         method wag {} {return "wags"}
3670         method droop {} {return "droops"}
3671     }
3672
3673     type dog {
3674         constructor {} {
3675             set tail [tail %AUTO%]
3676         }
3677         delegate method {tail *} to tail except droop
3678     }
3679
3680     dog spot
3681
3682     catch {spot tail droop} result
3683
3684     list [spot tail wag] $result
3685 } -cleanup {
3686     dog destroy
3687     tail destroy
3688 } -result {wags {"::spot tail droop" is not defined}}
3689
3690 # Case 2
3691 test dmethod-4.8 {except with multiple tokens} -constraints {
3692     snit2
3693 } -body {
3694     type tail {
3695         method wag {} {return "wags"}
3696         method droop {} {return "droops"}
3697     }
3698
3699     type dog {
3700         constructor {} {
3701             set tail [tail %AUTO%]
3702         }
3703         delegate method {tail *} to tail except droop
3704     }
3705
3706     dog spot
3707
3708     catch {spot tail droop} result
3709
3710     list [spot tail wag] $result
3711 } -cleanup {
3712     dog destroy
3713     tail destroy
3714 } -result {wags {unknown subcommand "droop": namespace ::dog::Snit_inst1 does not export any commands}}
3715
3716 test dmethod-4.9 {"*" in the wrong spot} -body {
3717     type dog {
3718         delegate method {tail * wag} to tail
3719     }
3720 } -returnCodes {
3721     error
3722 } -result {Error in "delegate method {tail * wag}...", "*" must be the last token.}
3723
3724 test dmethod-5.1 {prefix/method collision} -body {
3725     type dog {
3726         delegate method wag to tail
3727         delegate method {wag tail} to tail as wag
3728     }
3729 } -returnCodes {
3730     error
3731 } -result {Error in "delegate method {wag tail}...", "wag" has no submethods.}
3732
3733 test dmethod-5.2 {prefix/method collision} -body {
3734     type dog {
3735         delegate method {wag tail} to tail as wag
3736         delegate method wag to tail
3737     }
3738 } -returnCodes {
3739     error
3740 } -result {Error in "delegate method wag...", "wag" has submethods.}
3741
3742 test dmethod-5.3 {prefix/method collision} -body {
3743     type dog {
3744         delegate method {wag tail} to tail
3745         delegate method {wag tail proudly} to tail as wag
3746     }
3747 } -returnCodes {
3748     error
3749 } -result {Error in "delegate method {wag tail proudly}...", "wag tail" has no submethods.}
3750
3751 test dmethod-5.4 {prefix/method collision} -body {
3752     type dog {
3753         delegate method {wag tail proudly} to tail as wag
3754         delegate method {wag tail} to tail
3755     }
3756 } -returnCodes {
3757     error
3758 } -result {Error in "delegate method {wag tail}...", "wag tail" has submethods.}
3759
3760 #-----------------------------------------------------------------------
3761 # delegated options
3762
3763 test doption-1.1 {delegate option to non-existent component} -body {
3764     type dog {
3765         delegate option -foo to bar
3766     }
3767
3768     dog create spot
3769     spot cget -foo
3770 } -returnCodes {
3771     error
3772 } -cleanup {
3773     dog destroy
3774 } -result {component "bar" is undefined in ::dog ::spot}
3775
3776 test doption-1.2 {delegating option to existing component: cget} -body {
3777     type cat {
3778         option -color "black"
3779     }
3780
3781     cat create hershey
3782
3783     type dog {
3784         constructor {args} {
3785             set catthing ::hershey
3786         }
3787
3788         delegate option -color to catthing
3789     }
3790
3791     dog create spot
3792     spot cget -color
3793 } -cleanup {
3794     dog destroy
3795     cat destroy
3796 } -result {black}
3797
3798 test doption-1.3 {delegating option to existing component: configure} -body {
3799     type cat {
3800         option -color "black"
3801     }
3802
3803     cat create hershey
3804
3805     type dog {
3806         constructor {args} {
3807             set catthing ::hershey
3808             $self configurelist $args
3809         }
3810
3811         delegate option -color to catthing
3812     }
3813
3814     dog create spot -color blue
3815     list [spot cget -color] [hershey cget -color]
3816 } -cleanup {
3817     dog destroy
3818     cat destroy
3819 } -result {blue blue}
3820
3821 test doption-1.4 {delegating unknown options to existing component} -body {
3822     type cat {
3823         option -color "black"
3824     }
3825
3826     cat create hershey
3827
3828     type dog {
3829         constructor {args} {
3830             set catthing ::hershey
3831
3832             # Note: must do this after components are defined; this
3833             # may be a problem.
3834             $self configurelist $args
3835         }
3836
3837         delegate option * to catthing
3838     }
3839
3840     dog create spot -color blue
3841     list [spot cget -color] [hershey cget -color]
3842 } -cleanup {
3843     dog destroy
3844     cat destroy
3845 } -result {blue blue}
3846
3847 test doption-1.5 {can't oncget for delegated option} -body {
3848     type dog {
3849         delegate option -color to catthing
3850
3851         oncget -color { }
3852     }
3853 } -returnCodes {
3854     error
3855 } -result {Error in "oncget -color...", option "-color" is delegated}
3856
3857 test doption-1.6 {can't onconfigure for delegated option} -body {
3858     type dog {
3859         delegate option -color to catthing
3860
3861         onconfigure -color {value} { }
3862     }
3863 } -returnCodes {
3864     error
3865 } -result {onconfigure -color: option "-color" is delegated}
3866
3867 test doption-1.7 {delegating unknown options to existing component: error} -body {
3868     type cat {
3869         option -color "black"
3870     }
3871
3872     cat create hershey
3873
3874     type dog {
3875         constructor {args} {
3876             set catthing ::hershey
3877             $self configurelist $args
3878         }
3879
3880         delegate option * to catthing
3881     }
3882
3883     dog create spot -colour blue
3884 } -returnCodes {
3885     error
3886 } -cleanup {
3887     dog destroy
3888     cat destroy
3889 } -result {Error in constructor: unknown option "-colour"}
3890
3891 test doption-1.8 {can't delegate local option: order 1} -body {
3892     type cat {
3893         option -color "black"
3894         delegate option -color to hull
3895     }
3896 } -returnCodes {
3897     error
3898 } -result {Error in "delegate option -color...", "-color" has been defined locally}
3899
3900 test doption-1.9 {can't delegate local option: order 2} -body {
3901     type cat {
3902         delegate option -color to hull
3903         option -color "black"
3904     }
3905 } -returnCodes {
3906     error
3907 } -result {Error in "option -color...", cannot define "-color" locally, it has been delegated}
3908
3909 test doption-1.10 {excepted options are caught properly on cget} -body {
3910     type tail {
3911         option -a a
3912         option -b b
3913         option -c c
3914     }
3915
3916     type cat {
3917         delegate option * to tail except {-b -c}
3918
3919         constructor {args} {
3920             set tail [tail %AUTO%]
3921         }
3922     }
3923
3924     cat fifi
3925
3926     catch {fifi cget -a} a
3927     catch {fifi cget -b} b
3928     catch {fifi cget -c} c
3929
3930     list $a $b $c
3931 } -cleanup {
3932     cat destroy
3933     tail destroy
3934 } -result {a {unknown option "-b"} {unknown option "-c"}}
3935
3936 test doption-1.11 {excepted options are caught properly on configurelist} -body {
3937     type tail {
3938         option -a a
3939         option -b b
3940         option -c c
3941     }
3942
3943     type cat {
3944         delegate option * to tail except {-b -c}
3945
3946         constructor {args} {
3947             set tail [tail %AUTO%]
3948         }
3949     }
3950
3951     cat fifi
3952
3953     catch {fifi configurelist {-a 1}} a
3954     catch {fifi configurelist {-b 1}} b
3955     catch {fifi configurelist {-c 1}} c
3956
3957     list $a $b $c
3958 } -cleanup {
3959     cat destroy
3960     tail destroy
3961 } -result {{} {unknown option "-b"} {unknown option "-c"}}
3962
3963 test doption-1.12 {excepted options are caught properly on configure, 1} -body {
3964     type tail {
3965         option -a a
3966         option -b b
3967         option -c c
3968     }
3969
3970     type cat {
3971         delegate option * to tail except {-b -c}
3972
3973         constructor {args} {
3974             set tail [tail %AUTO%]
3975         }
3976     }
3977
3978     cat fifi
3979
3980     catch {fifi configure -a 1} a
3981     catch {fifi configure -b 1} b
3982     catch {fifi configure -c 1} c
3983
3984     list $a $b $c
3985 } -cleanup {
3986     cat destroy
3987     tail destroy
3988 } -result {{} {unknown option "-b"} {unknown option "-c"}}
3989
3990 test doption-1.13 {excepted options are caught properly on configure, 2} -body {
3991     type tail {
3992         option -a a
3993         option -b b
3994         option -c c
3995     }
3996
3997     type cat {
3998         delegate option * to tail except {-b -c}
3999
4000         constructor {args} {
4001             set tail [tail %AUTO%]
4002         }
4003     }
4004
4005     cat fifi
4006
4007     catch {fifi configure -a} a
4008     catch {fifi configure -b} b
4009     catch {fifi configure -c} c
4010
4011     list $a $b $c
4012 } -cleanup {
4013     cat destroy
4014     tail destroy
4015 } -result {{-a a A a a} {unknown option "-b"} {unknown option "-c"}}
4016
4017 test doption-1.14 {configure query skips excepted options} -body {
4018     type tail {
4019         option -a a
4020         option -b b
4021         option -c c
4022     }
4023
4024     type cat {
4025         option -d d
4026         delegate option * to tail except {-b -c}
4027
4028         constructor {args} {
4029             set tail [tail %AUTO%]
4030         }
4031     }
4032
4033     cat fifi
4034
4035     fifi configure
4036 } -cleanup {
4037     cat destroy
4038     tail destroy
4039 } -result {{-d d D d d} {-a a A a a}}
4040
4041
4042 #-----------------------------------------------------------------------
4043 # from
4044
4045 test from-1.1 {getting default values} -body {
4046     type dog {
4047         option -foo FOO
4048         option -bar BAR
4049
4050         constructor {args} {
4051             $self configure -foo  [from args -foo AAA]
4052             $self configure -bar  [from args -bar]
4053         }
4054     }
4055
4056     dog create spot
4057     list [spot cget -foo] [spot cget -bar]
4058 } -cleanup {
4059     dog destroy
4060 } -result {AAA BAR}
4061
4062 test from-1.2 {getting non-default values} -body {
4063     type dog {
4064         option -foo FOO
4065         option -bar BAR
4066         option -args
4067
4068         constructor {args} {
4069             $self configure -foo [from args -foo]
4070             $self configure -bar [from args -bar]
4071             $self configure -args $args
4072         }
4073     }
4074
4075     dog create spot -foo quux -baz frobnitz -bar frobozz
4076     list [spot cget -foo] [spot cget -bar] [spot cget -args]
4077 } -cleanup {
4078     dog destroy
4079 } -result {quux frobozz {-baz frobnitz}}
4080
4081 #-----------------------------------------------------------------------
4082 # Widgetadaptors
4083
4084 test widgetadaptor-1.1 {creating a widget: hull hijacking} -constraints {
4085     tk
4086 } -body {
4087     widgetadaptor mylabel {
4088         constructor {args} {
4089             installhull [label $self]
4090             $self configurelist $args
4091         }
4092
4093         delegate method * to hull
4094         delegate option * to hull
4095     }
4096
4097     mylabel create .label -text "My Label"
4098
4099     set a [.label cget -text]
4100     set b [hull1.label cget -text]
4101
4102     destroy .label
4103     tkbide
4104     list $a $b
4105 } -cleanup {
4106     mylabel destroy
4107 } -result {{My Label} {My Label}}
4108
4109 test widgetadaptor-1.2 {destroying a widget with destroy} -constraints {
4110     tk
4111 } -body {
4112     widgetadaptor mylabel {
4113         constructor {} {
4114             installhull [label $self]
4115         }
4116     }
4117
4118     mylabel create .label
4119     set a [namespace children ::mylabel]
4120     destroy .label
4121     set b [namespace children ::mylabel]
4122     tkbide
4123     list $a $b
4124 } -cleanup {
4125     mylabel destroy
4126 } -result {::mylabel::Snit_inst1 {}}
4127
4128 test widgetadaptor-1.3 {destroying two widgets of the same type with destroy} -constraints {
4129     tk
4130 } -body {
4131     widgetadaptor mylabel {
4132         constructor {} {
4133             installhull [label $self]
4134         }
4135     }
4136
4137     mylabel create .lab1
4138     mylabel create .lab2
4139     set a [namespace children ::mylabel]
4140     destroy .lab1
4141     destroy .lab2
4142     set b [namespace children ::mylabel]
4143     tkbide
4144     list $a $b
4145 } -cleanup {
4146     mylabel destroy
4147 } -result {{::mylabel::Snit_inst1 ::mylabel::Snit_inst2} {}}
4148
4149 test widgetadaptor-1.4 {destroying a widget with rename, then destroy type} -constraints {
4150     tk bug8.5a3
4151 } -body {
4152     widgetadaptor mylabel {
4153         constructor {} {
4154             installhull [label $self]
4155         }
4156     }
4157
4158     mylabel create .label
4159     set a [namespace children ::mylabel]
4160     rename .label ""
4161     set b [namespace children ::mylabel]
4162
4163     mylabel destroy
4164     tkbide
4165     list $a $b
4166 } -result {::mylabel::Snit_inst1 {}}
4167
4168 test widgetadaptor-1.5 {destroying two widgets of the same type with rename} -constraints {
4169     tk bug8.5a3
4170 } -body {
4171     widgetadaptor mylabel {
4172         constructor {} {
4173             installhull [label $self]
4174         }
4175     }
4176
4177     mylabel create .lab1
4178     mylabel create .lab2
4179     set a [namespace children ::mylabel]
4180     rename .lab1 ""
4181     rename .lab2 ""
4182     set b [namespace children ::mylabel]
4183     mylabel destroy
4184     tkbide
4185     list $a $b
4186 } -result {{::mylabel::Snit_inst1 ::mylabel::Snit_inst2} {}}
4187
4188 test widgetadaptor-1.6 {create/destroy twice, with destroy} -constraints {
4189     tk
4190 } -body {
4191     widgetadaptor mylabel {
4192         constructor {} {
4193             installhull [label $self]
4194         }
4195     }
4196
4197     mylabel create .lab1
4198     set a [namespace children ::mylabel]
4199     destroy .lab1
4200
4201     mylabel create .lab1
4202     set b [namespace children ::mylabel]
4203     destroy .lab1
4204
4205     set c [namespace children ::mylabel]
4206     mylabel destroy
4207     tkbide
4208     list $a $b $c
4209 } -result {::mylabel::Snit_inst1 ::mylabel::Snit_inst2 {}}
4210
4211 test widgetadaptor-1.7 {create/destroy twice, with rename} -constraints {
4212     tk bug8.5a3
4213 } -body {
4214     widgetadaptor mylabel {
4215         constructor {} {
4216             installhull [label $self]
4217         }
4218     }
4219
4220     mylabel create .lab1
4221     set a [namespace children ::mylabel]
4222     rename .lab1 ""
4223
4224     mylabel create .lab1
4225     set b [namespace children ::mylabel]
4226     rename .lab1 ""
4227
4228     set c [namespace children ::mylabel]
4229     mylabel destroy
4230     tkbide
4231     list $a $b $c
4232 } -result {::mylabel::Snit_inst1 ::mylabel::Snit_inst2 {}}
4233
4234 test widgetadaptor-1.8 {"create" is optional} -constraints {
4235     tk
4236 } -body {
4237     widgetadaptor mylabel {
4238         constructor {args} {
4239             installhull [label $self]
4240         }
4241         method howdy {} {return "Howdy!"}
4242     }
4243
4244     mylabel .label
4245     set a [.label howdy]
4246
4247     destroy .label
4248     tkbide
4249     set a
4250 } -cleanup {
4251     mylabel destroy
4252 } -result {Howdy!}
4253
4254 # Case 1
4255 test widgetadaptor-1.9 {"create" is optional, but must be a valid name} -constraints {
4256     snit1
4257     tk
4258 } -body {
4259     widgetadaptor mylabel {
4260         constructor {args} {
4261             installhull [label $self]
4262         }
4263         method howdy {} {return "Howdy!"}
4264     }
4265
4266     catch {mylabel foo} result
4267     tkbide
4268     set result
4269 } -cleanup {
4270     mylabel destroy
4271 } -result {"::mylabel foo" is not defined}
4272
4273 # Case 2
4274 test widgetadaptor-1.10 {"create" is optional, but must be a valid name} -constraints {
4275     snit2
4276     tk
4277 } -body {
4278     widgetadaptor mylabel {
4279         constructor {args} {
4280             installhull [label $self]
4281         }
4282         method howdy {} {return "Howdy!"}
4283     }
4284
4285     catch {mylabel foo} result
4286     tkbide
4287     set result
4288 } -cleanup {
4289     mylabel destroy
4290 } -result {unknown subcommand "foo": namespace ::mylabel does not export any commands}
4291
4292 test widgetadaptor-1.11 {user-defined destructors are called} -constraints {
4293     tk
4294 } -body {
4295     widgetadaptor mylabel {
4296         typevariable flag ""
4297
4298         constructor {args} {
4299             installhull [label $self]
4300             set flag "created $self"
4301         }
4302
4303         destructor {
4304             set flag "destroyed $self"
4305         }
4306
4307         typemethod getflag {} {
4308             return $flag
4309         }
4310     }
4311
4312     mylabel .label
4313     set a [mylabel getflag]
4314     destroy .label
4315     tkbide
4316     list $a [mylabel getflag]
4317 } -cleanup {
4318     mylabel destroy
4319 } -result {{created .label} {destroyed .label}}
4320
4321 # Case 1
4322 test widgetadaptor-1.12 {destroy method not defined for widget types} -constraints {
4323     snit1
4324     tk
4325 } -body {
4326     widgetadaptor mylabel {
4327         constructor {args} {
4328             installhull [label $self]
4329         }
4330     }
4331
4332     mylabel .label
4333     catch {.label destroy} result
4334     destroy .label
4335     tkbide
4336     set result
4337 } -cleanup {
4338     mylabel destroy
4339 } -result {".label destroy" is not defined}
4340
4341 # Case 2
4342 test widgetadaptor-1.13 {destroy method not defined for widget types} -constraints {
4343     snit2
4344     tk
4345 } -body {
4346     widgetadaptor mylabel {
4347         constructor {args} {
4348             installhull [label $self]
4349         }
4350     }
4351
4352     mylabel .label
4353     catch {.label destroy} result
4354     destroy .label
4355     tkbide
4356     set result
4357 } -cleanup {
4358     mylabel destroy
4359 } -result {unknown subcommand "destroy": namespace ::mylabel::Snit_inst1 does not export any commands}
4360
4361 test widgetadaptor-1.14 {hull can be repeatedly renamed} -constraints {
4362     tk
4363 } -body {
4364     widgetadaptor basetype {
4365         constructor {args} {
4366             installhull [label $self]
4367         }
4368
4369         method basemethod {} { return "basemethod" }
4370     }
4371
4372     widgetadaptor w1 {
4373         constructor {args} {
4374             installhull [basetype create $self]
4375         }
4376     }
4377
4378     widgetadaptor w2 {
4379         constructor {args} {
4380             installhull [w1 $self]
4381         }
4382     }
4383
4384     set a [w2 .foo]
4385     destroy .foo
4386     tkbide
4387     set a
4388 } -cleanup {
4389     w2 destroy
4390     w1 destroy
4391     basetype destroy
4392 } -result {.foo}
4393
4394 test widgetadaptor-1.15 {widget names can be generated} -constraints {
4395     tk
4396 } -body {
4397     widgetadaptor unique {
4398         constructor {args} {
4399             installhull [label $self]
4400         }
4401     }
4402
4403     set w [unique .%AUTO%]
4404     destroy $w
4405     tkbide
4406     set w
4407 } -cleanup {
4408     unique destroy
4409 } -result {.unique1}
4410
4411 test widgetadaptor-1.16 {snit::widgetadaptor as hull} -constraints {
4412     tk
4413 } -body {
4414     widgetadaptor mylabel {
4415         constructor {args} {
4416             installhull [label $self]
4417             $self configurelist $args
4418         }
4419         method method1 {} {
4420             return "method1"
4421         }
4422         delegate option * to hull
4423     }
4424
4425     widgetadaptor mylabel2 {
4426         constructor {args} {
4427             installhull [mylabel $self]
4428             $self configurelist $args
4429         }
4430         method method2 {} {
4431             return "method2: [$hull method1]"
4432         }
4433         delegate option * to hull
4434     }
4435
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]
4443
4444     destroy .label
4445
4446     set f [namespace children ::mylabel2]
4447     set g [namespace children ::mylabel]
4448
4449     mylabel2 destroy
4450     mylabel destroy
4451
4452     tkbide
4453     list $a $b $c $d $e $f $g
4454 } -result {{method2: method1} {Some Text} {More Text} ::mylabel2::Snit_inst1 ::mylabel::Snit_inst1 {} {}}
4455
4456 test widgetadaptor-1.17 {snit::widgetadaptor as hull; use rename} -constraints {
4457     tk bug8.5a3
4458 } -body {
4459     widgetadaptor mylabel {
4460         constructor {args} {
4461             installhull [label $self]
4462             $self configurelist $args
4463         }
4464         method method1 {} {
4465             return "method1"
4466         }
4467         delegate option * to hull
4468     }
4469
4470     widgetadaptor mylabel2 {
4471         constructor {args} {
4472             installhull [mylabel $self]
4473             $self configurelist $args
4474         }
4475         method method2 {} {
4476             return "method2: [$hull method1]"
4477         }
4478         delegate option * to hull
4479     }
4480
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]
4488
4489     rename .label ""
4490
4491     set f [namespace children ::mylabel2]
4492     set g [namespace children ::mylabel]
4493
4494     mylabel2 destroy
4495     mylabel destroy
4496
4497     tkbide
4498     list $a $b $c $d $e $f $g
4499 } -result {{method2: method1} {Some Text} {More Text} ::mylabel2::Snit_inst1 ::mylabel::Snit_inst1 {} {}}
4500
4501 test widgetadaptor-1.18 {BWidget Label as hull} -constraints {
4502     bwidget
4503 } -body {
4504     widgetadaptor mylabel {
4505         constructor {args} {
4506             installhull [Label $win]
4507             $self configurelist $args
4508         }
4509         delegate option * to hull
4510     }
4511
4512     mylabel .label -text "Some Text"
4513     set a [.label cget -text]
4514
4515     .label configure -text "More Text"
4516     set b [.label cget -text]
4517
4518     set c [namespace children ::mylabel]
4519
4520     destroy .label
4521
4522     set d [namespace children ::mylabel]
4523
4524     mylabel destroy
4525
4526     tkbide
4527     list $a $b $c $d
4528 } -result {{Some Text} {More Text} ::mylabel::Snit_inst1 {}}
4529
4530 test widgetadaptor-1.19 {error in widgetadaptor constructor} -constraints {
4531     tk
4532 } -body {
4533     widgetadaptor mylabel {
4534         constructor {args} {
4535             error "Simulated Error"
4536         }
4537     }
4538
4539     mylabel .lab
4540 } -returnCodes {
4541     error
4542 } -cleanup {
4543     mylabel destroy
4544 } -result {Error in constructor: Simulated Error}
4545
4546
4547 #-----------------------------------------------------------------------
4548 # Widgets
4549
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.
4553
4554 test widget-1.1 {creating a widget} -constraints {
4555     tk
4556 } -body {
4557     widget myframe {
4558         method hull {} { return $hull }
4559
4560         delegate method * to hull
4561         delegate option * to hull
4562     }
4563
4564     myframe create .frm -background green
4565
4566     set a [.frm cget -background]
4567     set b [.frm hull]
4568
4569     destroy .frm
4570     tkbide
4571     list $a $b
4572 } -cleanup {
4573     myframe destroy
4574 } -result {green ::hull1.frm}
4575
4576 test widget-2.1 {can't redefine hull} -constraints {
4577     tk
4578 } -body {
4579     widget myframe {
4580         method resethull {} { set hull "" }
4581     }
4582
4583     myframe .frm
4584
4585     .frm resethull
4586 } -returnCodes {
4587     error
4588 } -cleanup {
4589     myframe destroy
4590 } -result {can't set "hull": The hull component cannot be redefined}
4591
4592 #-----------------------------------------------------------------------
4593 # install
4594 #
4595 # The install command is used to install widget components, while getting
4596 # options for the option database.
4597
4598 test install-1.1 {installed components are created properly} -constraints {
4599     tk
4600 } -body {
4601     widget myframe {
4602         # Delegate an option just to make sure the component variable
4603         # exists.
4604         delegate option -font to text
4605
4606         constructor {args} {
4607             install text using text $win.text -background green
4608         }
4609
4610         method getit {} {
4611             $win.text cget -background
4612         }
4613     }
4614
4615     myframe .frm
4616     set a [.frm getit]
4617     destroy .frm
4618     tkbide
4619     set a
4620 } -cleanup {
4621     myframe destroy
4622 } -result {green}
4623
4624 test install-1.2 {installed components are saved properly} -constraints {
4625     tk
4626 } -body {
4627     widget myframe {
4628         # Delegate an option just to make sure the component variable
4629         # exists.
4630         delegate option -font to text
4631
4632         constructor {args} {
4633             install text using text $win.text -background green
4634         }
4635
4636         method getit {} {
4637             $text cget -background
4638         }
4639     }
4640
4641     myframe .frm
4642     set a [.frm getit]
4643     destroy .frm
4644     tkbide
4645     set a
4646 } -cleanup {
4647     myframe destroy
4648 } -result {green}
4649
4650 test install-1.3 {can't install until hull exists} -constraints {
4651     tk
4652 } -body {
4653     widgetadaptor myframe {
4654         # Delegate an option just to make sure the component variable
4655         # exists.
4656         delegate option -font to text
4657
4658         constructor {args} {
4659             install text using text $win.text -background green
4660         }
4661     }
4662
4663     myframe .frm
4664 } -returnCodes {
4665     error
4666 } -cleanup {
4667     myframe destroy
4668 } -result {Error in constructor: tried to install "text" before the hull exists}
4669
4670 test install-1.4 {install queries option database} -constraints {
4671     tk
4672 } -body {
4673     widget myframe {
4674         delegate option -font to text
4675
4676         typeconstructor {
4677             option add *Myframe.font Courier
4678         }
4679
4680         constructor {args} {
4681             install text using text $win.text
4682         }
4683     }
4684
4685     myframe .frm
4686     set a [.frm cget -font]
4687     destroy .frm
4688     tkbide
4689     set a
4690 } -cleanup {
4691     myframe destroy
4692 } -result {Courier}
4693
4694 test install-1.5 {explicit options override option database} -constraints {
4695     tk
4696 } -body {
4697     widget myframe {
4698         delegate option -font to text
4699
4700         typeconstructor {
4701             option add *Myframe.font Courier
4702         }
4703
4704         constructor {args} {
4705             install text using text $win.text -font Times
4706         }
4707     }
4708
4709     myframe .frm
4710     set a [.frm cget -font]
4711     destroy .frm
4712     tkbide
4713     set a
4714 } -cleanup {
4715     myframe destroy
4716 } -result {Times}
4717
4718 test install-1.6 {option db works with targetted options} -constraints {
4719     tk
4720 } -body {
4721     widget myframe {
4722         delegate option -textfont to text as -font
4723
4724         typeconstructor {
4725             option add *Myframe.textfont Courier
4726         }
4727
4728         constructor {args} {
4729             install text using text $win.text
4730         }
4731     }
4732
4733     myframe .frm
4734     set a [.frm cget -textfont]
4735     destroy .frm
4736     tkbide
4737     set a
4738 } -cleanup {
4739     myframe destroy
4740 } -result {Courier}
4741
4742 test install-1.7 {install works for snit::types} -body {
4743     type tail {
4744         option -tailcolor black
4745     }
4746
4747     type dog {
4748         delegate option -tailcolor to tail
4749
4750         constructor {args} {
4751             install tail using tail $self.tail
4752         }
4753     }
4754
4755     dog fido
4756     fido cget -tailcolor
4757 } -cleanup {
4758     dog destroy
4759     tail destroy
4760 } -result {black}
4761
4762 test install-1.8 {install can install non-widget components} -constraints {
4763     tk
4764 } -body {
4765     type dog {
4766         option -tailcolor black
4767     }
4768
4769     widget myframe {
4770         delegate option -tailcolor to thedog
4771
4772         typeconstructor {
4773             option add *Myframe.tailcolor green
4774         }
4775
4776         constructor {args} {
4777             install thedog using dog $win.dog
4778         }
4779     }
4780
4781     myframe .frm
4782     set a [.frm cget -tailcolor]
4783     destroy .frm
4784     tkbide
4785     set a
4786
4787 } -cleanup {
4788     dog destroy
4789     myframe destroy
4790 } -result {green}
4791
4792 test install-1.9 {ok if no options are delegated to component} -constraints {
4793     tk
4794 } -body {
4795     type dog {
4796         option -tailcolor black
4797     }
4798
4799     widget myframe {
4800         constructor {args} {
4801             install thedog using dog $win.dog
4802         }
4803     }
4804
4805     myframe .frm
4806     destroy .frm
4807     tkbide
4808
4809     # Test passes if no error is raised.
4810     list ok
4811 } -cleanup {
4812     myframe destroy
4813     dog destroy
4814 } -result {ok}
4815
4816 test install-2.1 {
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.
4820 } -constraints {
4821     tk
4822 } -body {
4823     widget myframe {
4824         delegate option * to text
4825
4826         typeconstructor {
4827             option add *Myframe.foreground red
4828             option add *Myframe.font {Times 14}
4829         }
4830
4831         constructor {args} {
4832             install text using text $win.text
4833         }
4834     }
4835
4836     myframe .frm
4837     set a [.frm cget -foreground]
4838     set b [.frm cget -font]
4839     destroy .frm
4840     tkbide
4841
4842     list $a $b
4843 } -cleanup {
4844     myframe destroy
4845 } -result {red {Times 14}}
4846
4847 test install-2.2 {
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
4852     option database.
4853 } -constraints {
4854     tk
4855 } -body {
4856     widget myframe {
4857         option -foreground white
4858         delegate option * to text
4859
4860         typeconstructor {
4861             option add *Myframe.foreground red
4862         }
4863
4864         constructor {args} {
4865             install text using text $win.text
4866         }
4867
4868         method getit {} {
4869             $text cget -foreground
4870         }
4871     }
4872
4873     myframe .frm
4874     set a [.frm cget -foreground]
4875     set b [.frm getit]
4876     destroy .frm
4877     tkbide
4878
4879     expr {![string equal $a $b]}
4880 } -cleanup {
4881     myframe destroy
4882 } -result {1}
4883
4884 test install-2.3 {
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.
4888 } -constraints {
4889     tk
4890 } -body {
4891     widget myframe {
4892         delegate option * to text
4893
4894         typeconstructor {
4895             option add *Myframe.foreground red
4896         }
4897
4898         constructor {args} {
4899             install text using text $win.text -foreground blue
4900         }
4901     }
4902
4903     myframe .frm
4904     set a [.frm cget -foreground]
4905     destroy .frm
4906     tkbide
4907
4908     set a
4909 } -cleanup {
4910     myframe destroy
4911 } -result {blue}
4912
4913 test install-2.4 {
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.
4916 } -constraints {
4917     tk
4918 } -body {
4919     widget myframe {
4920         delegate option * to text except -state
4921
4922         typeconstructor {
4923             option add *Myframe.foreground red
4924             option add *Myframe.state disabled
4925         }
4926
4927         constructor {args} {
4928             install text using text $win.text
4929         }
4930
4931         method getstate {} {
4932             $text cget -state
4933         }
4934     }
4935
4936     myframe .frm
4937     set a [.frm getstate]
4938     destroy .frm
4939     tkbide
4940
4941     set a
4942 } -cleanup {
4943     myframe destroy
4944 } -result {normal}
4945
4946 #-----------------------------------------------------------------------
4947 # Advanced installhull tests
4948 #
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.
4956 #
4957 # NOTE: "installhull using" is always used to create a widget's hull frame.
4958 #
4959 # That options passed into installhull override those from the
4960 # option database.
4961
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.
4968 } -constraints {
4969     tk
4970 } -body {
4971     widget myframe {
4972         delegate option -background to hull
4973
4974         typeconstructor {
4975             option add *Myframe.background red
4976             option add *Myframe.width 123
4977         }
4978
4979         method getwid {} {
4980             $hull cget -width
4981         }
4982     }
4983
4984     myframe .frm
4985     set a [.frm cget -background]
4986     set b [.frm getwid]
4987     destroy .frm
4988     tkbide
4989     list $a $b
4990 } -cleanup {
4991     myframe destroy
4992 } -result {red 123}
4993
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.
4997 } -constraints {
4998     tk
4999 } -body {
5000     widget myframe {
5001         delegate option -mainbackground to hull as -background
5002
5003         typeconstructor {
5004             option add *Myframe.mainbackground red
5005         }
5006     }
5007
5008     myframe .frm
5009     set a [.frm cget -mainbackground]
5010     destroy .frm
5011     tkbide
5012     set a
5013 } -cleanup {
5014     myframe destroy
5015 } -result {red}
5016
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.
5023 } -constraints {
5024     tk
5025 } -body {
5026     widgetadaptor myframe {
5027         delegate option -background to hull
5028
5029         typeconstructor {
5030             option add *Frame.background red
5031             option add *Frame.width 123
5032         }
5033
5034         constructor {args} {
5035             installhull using frame
5036         }
5037
5038         method getwid {} {
5039             $hull cget -width
5040         }
5041     }
5042
5043     myframe .frm
5044     set a [.frm cget -background]
5045     set b [.frm getwid]
5046     destroy .frm
5047     tkbide
5048     list $a $b
5049 } -cleanup {
5050     myframe destroy
5051 } -result {red 123}
5052
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.
5056 } -constraints {
5057     tk
5058 } -body {
5059     widgetadaptor myframe {
5060         delegate option -mainbackground to hull as -background
5061
5062         typeconstructor {
5063             option add *Frame.mainbackground red
5064         }
5065
5066         constructor {args} {
5067             installhull using frame
5068         }
5069     }
5070
5071     myframe .frm
5072     set a [.frm cget -mainbackground]
5073     destroy .frm
5074     tkbide
5075     set a
5076 } -cleanup {
5077     myframe destroy
5078 } -result {red}
5079
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.
5083 } -constraints {
5084     tk
5085 } -body {
5086     widgetadaptor myframe {
5087         delegate option -mainbackground to hull as -background
5088
5089         typeconstructor {
5090             option add *Frame.mainbackground red
5091             option add *Frame.width 123
5092         }
5093
5094         constructor {args} {
5095             installhull using frame -background green -width 321
5096         }
5097
5098         method getwid {} {
5099             $hull cget -width
5100         }
5101     }
5102
5103     myframe .frm
5104     set a [.frm cget -mainbackground]
5105     set b [.frm getwid]
5106     destroy .frm
5107     tkbide
5108     list $a $b
5109 } -cleanup {
5110     myframe destroy
5111 } -result {green 321}
5112
5113
5114 #-----------------------------------------------------------------------
5115 # Instance Introspection
5116
5117 # Case 1
5118 test iinfo-1.1 {object info too few args} -constraints {
5119     snit1
5120 } -body {
5121     type dog { }
5122
5123     dog create spot
5124
5125     spot info
5126 } -returnCodes {
5127     error
5128 } -cleanup {
5129     dog destroy
5130 } -result [tcltest::wrongNumArgs ::snit::RT.method.info {type selfns win self command args} 4]
5131
5132 # Case 2
5133 test iinfo-1.2 {object info too few args} -constraints {
5134     snit2
5135 } -body {
5136     type dog { }
5137
5138     dog create spot
5139
5140     spot info
5141 } -returnCodes {
5142     error
5143 } -cleanup {
5144     dog destroy
5145 } -result [expect \
5146                {wrong # args: should be "spot info command ?arg ...?"} \
5147                {wrong # args: should be "spot info command ..."}]
5148
5149 test iinfo-1.3 {object info too many args} -body {
5150     type dog { }
5151
5152     dog create spot
5153
5154     spot info type foo
5155 } -returnCodes {
5156     error
5157 } -cleanup {
5158     dog destroy
5159 } -result [tcltest::tooManyArgs ::snit::RT.method.info.type {type selfns win self}]
5160
5161 test iinfo-2.1 {object info type} -body {
5162     type dog { }
5163
5164     dog create spot
5165     spot info type
5166 } -cleanup {
5167     dog destroy
5168 } -result {::dog}
5169
5170 test iinfo-3.1 {object info typevars} -body {
5171     type dog {
5172         typevariable thisvar 1
5173
5174         constructor {args} {
5175             typevariable thatvar 2
5176         }
5177     }
5178
5179     dog create spot
5180     lsort [spot info typevars]
5181 } -cleanup {
5182     dog destroy
5183 } -result {::dog::thatvar ::dog::thisvar}
5184
5185 test iinfo-3.2 {object info typevars with pattern} -body {
5186     type dog {
5187         typevariable thisvar 1
5188
5189         constructor {args} {
5190             typevariable thatvar 2
5191         }
5192     }
5193
5194     dog create spot
5195     spot info typevars *this*
5196 } -cleanup {
5197     dog destroy
5198 } -result {::dog::thisvar}
5199
5200 test iinfo-4.1 {object info vars} -body {
5201     type dog {
5202         variable hisvar 1
5203
5204         constructor {args} {
5205             variable hervar
5206             set hervar 2
5207         }
5208     }
5209
5210     dog create spot
5211     lsort [spot info vars]
5212 } -cleanup {
5213     dog destroy
5214 } -result {::dog::Snit_inst1::hervar ::dog::Snit_inst1::hisvar}
5215
5216 test iinfo-4.2 {object info vars with pattern} -body {
5217     type dog {
5218         variable hisvar 1
5219
5220         constructor {args} {
5221             variable hervar
5222             set hervar 2
5223         }
5224     }
5225
5226     dog create spot
5227     spot info vars "*his*"
5228 } -cleanup {
5229     dog destroy
5230 } -result {::dog::Snit_inst1::hisvar}
5231
5232 test iinfo-5.1 {object info no vars defined} -body {
5233     type dog { }
5234
5235     dog create spot
5236     list [spot info vars] [spot info typevars]
5237 } -cleanup {
5238     dog destroy
5239 } -result {{} {}}
5240
5241 test iinfo-6.1 {info options with no options} -body {
5242     type dog { }
5243     dog create spot
5244
5245     llength [spot info options]
5246 } -cleanup {
5247     dog destroy
5248 } -result {0}
5249
5250 test iinfo-6.2 {info options with only local options} -body {
5251     type dog {
5252         option -foo a
5253         option -bar b
5254     }
5255     dog create spot
5256
5257     lsort [spot info options]
5258 } -cleanup {
5259     dog destroy
5260 } -result {-bar -foo}
5261
5262 test iinfo-6.3 {info options with local and delegated options} -body {
5263     type dog {
5264         option -foo a
5265         option -bar b
5266         delegate option -quux to sibling
5267     }
5268     dog create spot
5269
5270     lsort [spot info options]
5271 } -cleanup {
5272     dog destroy
5273 } -result {-bar -foo -quux}
5274
5275 test iinfo-6.4 {info options with unknown delegated options} -constraints {
5276     tk tcl83
5277 } -body {
5278     widgetadaptor myframe {
5279         option -foo a
5280         delegate option * to hull
5281         constructor {args} {
5282             installhull [frame $self]
5283         }
5284     }
5285     myframe .frm
5286
5287     set a [lsort [.frm info options]]
5288     destroy .frm
5289     tkbide
5290     set a
5291 } -cleanup {
5292     myframe destroy
5293 } -result {-background -bd -bg -borderwidth -class -colormap -container -cursor -foo -height -highlightbackground -highlightcolor -highlightthickness -relief -takefocus -visual -width}
5294
5295 test iinfo-6.5 {info options with unknown delegated options} -constraints {
5296     tk tcl84
5297 } -body {
5298     widgetadaptor myframe {
5299         option -foo a
5300         delegate option * to hull
5301         constructor {args} {
5302             installhull [frame $self]
5303         }
5304     }
5305     myframe .frm
5306
5307     set a [lsort [.frm info options]]
5308     destroy .frm
5309     tkbide
5310     set a
5311 } -cleanup {
5312     myframe destroy
5313 } -result {-background -bd -bg -borderwidth -class -colormap -container -cursor -foo -height -highlightbackground -highlightcolor -highlightthickness -padx -pady -relief -takefocus -visual -width}
5314
5315 test iinfo-6.6 {info options with exceptions} -constraints {
5316     tk tcl83
5317 } -body {
5318     widgetadaptor myframe {
5319         option -foo a
5320         delegate option * to hull except -background
5321         constructor {args} {
5322             installhull [frame $self]
5323         }
5324     }
5325     myframe .frm
5326
5327     set a [lsort [.frm info options]]
5328     destroy .frm
5329     tkbide
5330     set a
5331 } -cleanup {
5332     myframe destroy
5333 } -result {-bd -bg -borderwidth -class -colormap -container -cursor -foo -height -highlightbackground -highlightcolor -highlightthickness -relief -takefocus -visual -width}
5334
5335 test iinfo-6.7 {info options with exceptions} -constraints {
5336     tk tcl84
5337 } -body {
5338     widgetadaptor myframe {
5339         option -foo a
5340         delegate option * to hull except -background
5341         constructor {args} {
5342             installhull [frame $self]
5343         }
5344     }
5345     myframe .frm
5346
5347     set a [lsort [.frm info options]]
5348     destroy .frm
5349     tkbide
5350     set a
5351 } -cleanup {
5352     myframe destroy
5353 } -result {-bd -bg -borderwidth -class -colormap -container -cursor -foo -height -highlightbackground -highlightcolor -highlightthickness -padx -pady -relief -takefocus -visual -width}
5354
5355 test iinfo-6.8 {info options with pattern} -constraints {
5356     tk
5357 } -body {
5358     widgetadaptor myframe {
5359         option -foo a
5360         delegate option * to hull
5361         constructor {args} {
5362             installhull [frame $self]
5363         }
5364     }
5365     myframe .frm
5366
5367     set a [lsort [.frm info options -c*]]
5368     destroy .frm
5369     tkbide
5370     set a
5371 } -cleanup {
5372     myframe destroy
5373 } -result {-class -colormap -container -cursor}
5374
5375 test iinfo-7.1 {info typemethods, simple case} -body {
5376     type dog { }
5377
5378     dog spot
5379
5380     lsort [spot info typemethods]
5381 } -cleanup {
5382     dog destroy
5383 } -result {create destroy info}
5384
5385 test iinfo-7.2 {info typemethods, with pattern} -body {
5386     type dog { }
5387
5388     dog spot
5389
5390     spot info typemethods i*
5391 } -cleanup {
5392     dog destroy
5393 } -result {info}
5394
5395 test iinfo-7.3 {info typemethods, with explicit typemethods} -body {
5396     type dog {
5397         typemethod foo {} {}
5398         delegate typemethod bar to comp
5399     }
5400
5401     dog spot
5402
5403     lsort [spot info typemethods]
5404 } -cleanup {
5405     dog destroy
5406 } -result {bar create destroy foo info}
5407
5408 test iinfo-7.4 {info typemethods, with implicit typemethods} -body {
5409     type dog {
5410         delegate typemethod * to comp
5411
5412         typeconstructor {
5413             set comp string
5414         }
5415     }
5416
5417     dog create spot
5418
5419     set a [lsort [spot info typemethods]]
5420
5421     dog length foo
5422     dog is boolean yes
5423
5424     set b [lsort [spot info typemethods]]
5425
5426     set c [spot info typemethods len*]
5427
5428     list $a $b $c
5429 } -cleanup {
5430     dog destroy
5431 } -result {{create destroy info} {create destroy info is length} length}
5432
5433 test iinfo-7.5 {info typemethods, with hierarchical typemethods} -body {
5434     type dog {
5435         delegate typemethod {comp foo} to comp
5436
5437         typemethod {comp bar} {} {}
5438     }
5439
5440     dog create spot
5441
5442     lsort [spot info typemethods]
5443 } -cleanup {
5444     dog destroy
5445 } -result {{comp bar} {comp foo} create destroy info}
5446
5447
5448 test iinfo-8.1 {info methods, simple case} -body {
5449     type dog { }
5450
5451     dog spot
5452
5453     lsort [spot info methods]
5454 } -cleanup {
5455     dog destroy
5456 } -result {destroy info}
5457
5458 test iinfo-8.2 {info methods, with pattern} -body {
5459     type dog { }
5460
5461     dog spot
5462
5463     spot info methods i*
5464 } -cleanup {
5465     dog destroy
5466 } -result {info}
5467
5468 test iinfo-8.3 {info methods, with explicit methods} -body {
5469     type dog {
5470         method foo {} {}
5471         delegate method bar to comp
5472     }
5473
5474     dog spot
5475
5476     lsort [spot info methods]
5477 } -cleanup {
5478     dog destroy
5479 } -result {bar destroy foo info}
5480
5481 test iinfo-8.4 {info methods, with implicit methods} -body {
5482     type dog {
5483         delegate method * to comp
5484
5485         constructor {args} {
5486             set comp string
5487         }
5488     }
5489
5490     dog create spot
5491
5492     set a [lsort [spot info methods]]
5493
5494     spot length foo
5495     spot is boolean yes
5496
5497     set b [lsort [spot info methods]]
5498
5499     set c [spot info methods len*]
5500
5501     list $a $b $c
5502 } -cleanup {
5503     dog destroy
5504 } -result {{destroy info} {destroy info is length} length}
5505
5506 test iinfo-8.5 {info methods, with hierarchical methods} -body {
5507     type dog {
5508         delegate method {comp foo} to comp
5509
5510         method {comp bar} {} {}
5511     }
5512
5513     dog create spot
5514
5515     lsort [spot info methods]
5516 } -cleanup {
5517     dog destroy
5518 } -result {{comp bar} {comp foo} destroy info}
5519
5520 test iinfo-9.1 {info args} -body {
5521     type dog {
5522         method bark {volume} {}
5523     }
5524
5525     dog spot
5526
5527     spot info args bark
5528 } -cleanup {
5529     dog destroy
5530 } -result {volume}
5531
5532 test iinfo-9.2 {info args, too few args} -body {
5533     type dog {
5534         method bark {volume} {}
5535     }
5536
5537     dog spot
5538
5539     spot info args
5540 } -returnCodes error -cleanup {
5541     dog destroy
5542 } -result [tcltest::wrongNumArgs ::snit::RT.method.info.args {type selfns win self method} 4]
5543
5544 test iinfo-9.3 {info args, too many args} -body {
5545     type dog {
5546         method bark {volume} {}
5547     }
5548
5549     dog spot
5550
5551     spot info args bark wag
5552 } -returnCodes error -cleanup {
5553     dog destroy
5554 } -result [tcltest::tooManyArgs ::snit::RT.method.info.args {type selfns win self method}]
5555
5556 test iinfo-9.4 {info args, unknown method} -body {
5557     type dog {
5558     }
5559
5560     dog spot
5561
5562     spot info args bark
5563 } -returnCodes error -cleanup {
5564     dog destroy
5565 } -result {Unknown method "bark"}
5566
5567 test iinfo-9.5 {info args, delegated method} -body {
5568     type dog {
5569         component x
5570         delegate method bark to x
5571     }
5572
5573     dog spot
5574
5575     spot info args bark
5576 } -returnCodes error -cleanup {
5577     dog destroy
5578 } -result {Delegated method "bark"}
5579
5580 test iinfo-10.1 {info default} -body {
5581     type dog {
5582         method bark {{volume 50}} {}
5583     }
5584
5585     dog spot
5586
5587     list [spot info default bark volume def] $def
5588 } -cleanup {
5589     dog destroy
5590 } -result {1 50}
5591
5592 test iinfo-10.2 {info default, too few args} -body {
5593     type dog {
5594         method bark {volume} {}
5595     }
5596
5597     dog spot
5598
5599     spot info default
5600 } -returnCodes error -cleanup {
5601     dog destroy
5602 } -result [tcltest::wrongNumArgs ::snit::RT.method.info.default {type selfns win self method aname dvar} 4]
5603
5604 test iinfo-10.3 {info default, too many args} -body {
5605     type dog {
5606         method bark {volume} {}
5607     }
5608
5609     dog spot
5610
5611     spot info default bark wag def foo
5612 } -returnCodes error -cleanup {
5613     dog destroy
5614 } -result [tcltest::tooManyArgs ::snit::RT.method.info.default {type selfns win self method aname dvar}]
5615
5616 test iinfo-10.4 {info default, unknown method} -body {
5617     type dog {
5618     }
5619
5620     dog spot
5621
5622     spot info default bark x var
5623 } -returnCodes error -cleanup {
5624     dog destroy
5625 } -result {Unknown method "bark"}
5626
5627 test iinfo-10.5 {info default, delegated method} -body {
5628     type dog {
5629         component x
5630         delegate method bark to x
5631     }
5632
5633     dog spot
5634
5635     spot info default bark x var
5636 } -returnCodes error -cleanup {
5637     dog destroy
5638 } -result {Delegated method "bark"}
5639
5640 test iinfo-11.1 {info body} -body {
5641     type dog {
5642         typevariable x
5643         variable y
5644         method bark {volume} {
5645             speaker on
5646             speaker play bark.snd
5647             speaker off
5648         }
5649     }
5650
5651     dog spot
5652
5653     spot info body bark
5654 } -cleanup {
5655     dog destroy
5656 } -result {
5657             speaker on
5658             speaker play bark.snd
5659             speaker off
5660         }
5661
5662 test iinfo-11.2 {info body, too few args} -body {
5663     type dog {
5664         method bark {volume} {}
5665     }
5666
5667     dog spot
5668
5669     spot info body
5670 } -returnCodes error -cleanup {
5671     dog destroy
5672 } -result [tcltest::wrongNumArgs ::snit::RT.method.info.body {type selfns win self method} 4]
5673
5674 test iinfo-11.3 {info body, too many args} -body {
5675     type dog {
5676         method bark {volume} {}
5677     }
5678
5679     dog spot
5680
5681     spot info body bark wag
5682 } -returnCodes error -cleanup {
5683     dog destroy
5684 } -result [tcltest::tooManyArgs ::snit::RT.method.info.body {type selfns win self method}]
5685
5686 test iinfo-11.4 {info body, unknown method} -body {
5687     type dog {
5688     }
5689
5690     dog spot
5691
5692     spot info body bark
5693 } -returnCodes error -cleanup {
5694     dog destroy
5695 } -result {Unknown method "bark"}
5696
5697 test iinfo-11.5 {info body, delegated method} -body {
5698     type dog {
5699         component x
5700         delegate method bark to x
5701     }
5702
5703     dog spot
5704
5705     spot info body bark
5706 } -returnCodes error -cleanup {
5707     dog destroy
5708 } -result {Delegated method "bark"}
5709
5710 #-----------------------------------------------------------------------
5711 # Type Introspection
5712
5713 # Case 1
5714 test tinfo-1.1 {type info too few args} -constraints {
5715     snit1
5716 } -body {
5717     type dog { }
5718
5719     dog info
5720 } -returnCodes {
5721     error
5722 } -cleanup {
5723     dog destroy
5724 } -result [tcltest::wrongNumArgs ::snit::RT.typemethod.info {type command args} 1]
5725
5726 # Case 2
5727 test tinfo-1.2 {type info too few args} -constraints {
5728     snit2
5729 } -body {
5730     type dog { }
5731
5732     dog info
5733 } -returnCodes {
5734     error
5735 } -cleanup {
5736     dog destroy
5737 } -result [expect \
5738                {wrong # args: should be "dog info command ?arg ...?"} \
5739                {wrong # args: should be "dog info command ..."}]
5740
5741 test tinfo-1.3 {type info too many args} -body {
5742     type dog { }
5743
5744     dog info instances foo bar
5745 } -returnCodes {
5746     error
5747 } -cleanup {
5748     dog destroy
5749 } -result [tcltest::tooManyArgs ::snit::RT.typemethod.info.instances {type ?pattern?}]
5750
5751 test tinfo-2.1 {type info typevars} -body {
5752     type dog {
5753         typevariable thisvar 1
5754
5755         constructor {args} {
5756             typevariable thatvar 2
5757         }
5758     }
5759
5760     dog create spot
5761     lsort [dog info typevars]
5762 } -cleanup {
5763     dog destroy
5764 } -result {::dog::thatvar ::dog::thisvar}
5765
5766 test tinfo-3.1 {type info instances} -body {
5767     type dog { }
5768
5769     dog create spot
5770     dog create fido
5771
5772     lsort [dog info instances]
5773 } -cleanup {
5774     dog destroy
5775 } -result {::fido ::spot}
5776
5777 test tinfo-3.2 {widget info instances} -constraints {
5778     tk
5779 } -body {
5780     widgetadaptor mylabel {
5781         constructor {args} {
5782             installhull [label $self]
5783         }
5784     }
5785
5786     mylabel .lab1
5787     mylabel .lab2
5788
5789     set result [mylabel info instances]
5790
5791     destroy .lab1
5792     destroy .lab2
5793     tkbide
5794
5795     lsort $result
5796 } -cleanup {
5797     mylabel destroy
5798 } -result {.lab1 .lab2}
5799
5800 test tinfo-3.3 {type info instances with non-global namespaces} -body {
5801     type dog { }
5802
5803     dog create ::spot
5804
5805     namespace eval ::dogs:: {
5806         set ::qname [dog create fido]
5807     }
5808
5809     list $qname [lsort [dog info instances]]
5810 } -cleanup {
5811     dog destroy
5812 } -result {::dogs::fido {::dogs::fido ::spot}}
5813
5814 test tinfo-3.4 {type info instances with pattern} -body {
5815     type dog { }
5816
5817     dog create spot
5818     dog create fido
5819
5820     dog info instances "*f*"
5821 } -cleanup {
5822     dog destroy
5823 } -result {::fido}
5824
5825 test tinfo-3.5 {type info instances with unrelated child namespace, bug 2898640} -body {
5826     type dog { }
5827     namespace eval dog::unrelated {}
5828     dog create fido
5829
5830     dog info instances
5831 } -cleanup {
5832     dog destroy
5833 } -result {::fido}
5834
5835 test tinfo-4.1 {type info typevars with pattern} -body {
5836     type dog {
5837         typevariable thisvar 1
5838
5839         constructor {args} {
5840             typevariable thatvar 2
5841         }
5842     }
5843
5844     dog create spot
5845     dog info typevars *this*
5846 } -cleanup {
5847     dog destroy
5848 } -result {::dog::thisvar}
5849
5850 test tinfo-5.1 {type info typemethods, simple case} -body {
5851     type dog { }
5852
5853     lsort [dog info typemethods]
5854 } -cleanup {
5855     dog destroy
5856 } -result {create destroy info}
5857
5858 test tinfo-5.2 {type info typemethods, with pattern} -body {
5859     type dog { }
5860
5861     dog info typemethods i*
5862 } -cleanup {
5863     dog destroy
5864 } -result {info}
5865
5866 test tinfo-5.3 {type info typemethods, with explicit typemethods} -body {
5867     type dog {
5868         typemethod foo {} {}
5869         delegate typemethod bar to comp
5870     }
5871
5872     lsort [dog info typemethods]
5873 } -cleanup {
5874     dog destroy
5875 } -result {bar create destroy foo info}
5876
5877 test tinfo-5.4 {type info typemethods, with implicit typemethods} -body {
5878     type dog {
5879         delegate typemethod * to comp
5880
5881         typeconstructor {
5882             set comp string
5883         }
5884     }
5885
5886     set a [lsort [dog info typemethods]]
5887
5888     dog length foo
5889     dog is boolean yes
5890
5891     set b [lsort [dog info typemethods]]
5892
5893     set c [dog info typemethods len*]
5894
5895     list $a $b $c
5896 } -cleanup {
5897     dog destroy
5898 } -result {{create destroy info} {create destroy info is length} length}
5899
5900 test tinfo-5.5 {info typemethods, with hierarchical typemethods} -body {
5901     type dog {
5902         delegate typemethod {comp foo} to comp
5903
5904         typemethod {comp bar} {} {}
5905     }
5906
5907     lsort [dog info typemethods]
5908 } -cleanup {
5909     dog destroy
5910 } -result {{comp bar} {comp foo} create destroy info}
5911
5912 test tinfo-6.1 {type info args} -body {
5913     type dog {
5914         typemethod bark {volume} {}
5915     }
5916
5917     dog info args bark
5918 } -cleanup {
5919     dog destroy
5920 } -result {volume}
5921
5922 test tinfo-6.2 {type info args, too few args} -body {
5923     type dog {
5924         typemethod bark {volume} {}
5925     }
5926
5927     dog info args
5928 } -returnCodes error -cleanup {
5929     dog destroy
5930 } -result [tcltest::wrongNumArgs ::snit::RT.typemethod.info.args {type method} 1]
5931
5932 test tinfo-6.3 {type info args, too many args} -body {
5933     type dog {
5934         typemethod bark {volume} {}
5935     }
5936
5937     dog info args bark wag
5938 } -returnCodes error -cleanup {
5939     dog destroy
5940 } -result [tcltest::tooManyArgs ::snit::RT.typemethod.info.args {type method}]
5941
5942 test tinfo-6.4 {type info args, unknown method} -body {
5943     type dog {
5944     }
5945
5946     dog info args bark
5947 } -returnCodes error -cleanup {
5948     dog destroy
5949 } -result {Unknown typemethod "bark"}
5950
5951 test tinfo-6.5 {type info args, delegated method} -body {
5952     type dog {
5953         delegate typemethod bark to x
5954     }
5955
5956     dog info args bark
5957 } -returnCodes error -cleanup {
5958     dog destroy
5959 } -result {Delegated typemethod "bark"}
5960
5961 test tinfo-7.1 {type info default} -body {
5962     type dog {
5963         typemethod bark {{volume 50}} {}
5964     }
5965
5966     list [dog info default bark volume def] $def
5967 } -cleanup {
5968     dog destroy
5969 } -result {1 50}
5970
5971 test tinfo-7.2 {type info default, too few args} -body {
5972     type dog {
5973         typemethod bark {volume} {}
5974     }
5975
5976     dog info default
5977 } -returnCodes error -cleanup {
5978     dog destroy
5979 } -result [tcltest::wrongNumArgs ::snit::RT.typemethod.info.default {type method aname dvar} 1]
5980
5981 test tinfo-7.3 {type info default, too many args} -body {
5982     type dog {
5983         typemethod bark {volume} {}
5984     }
5985
5986     dog info default bark wag def foo
5987 } -returnCodes error -cleanup {
5988     dog destroy
5989 } -result [tcltest::tooManyArgs ::snit::RT.typemethod.info.default {type method aname dvar}]
5990
5991 test tinfo-7.4 {type info default, unknown method} -body {
5992     type dog {
5993     }
5994
5995     dog info default bark x var
5996 } -returnCodes error -cleanup {
5997     dog destroy
5998 } -result {Unknown typemethod "bark"}
5999
6000 test tinfo-7.5 {type info default, delegated method} -body {
6001     type dog {
6002         delegate typemethod bark to x
6003     }
6004
6005     dog info default bark x var
6006 } -returnCodes error -cleanup {
6007     dog destroy
6008 } -result {Delegated typemethod "bark"}
6009
6010 test tinfo-8.1 {type info body} -body {
6011     type dog {
6012         typevariable x
6013         variable y
6014         typemethod bark {volume} {
6015             speaker on
6016             speaker play bark.snd
6017             speaker off
6018         }
6019     }
6020
6021     dog info body bark
6022 } -cleanup {
6023     dog destroy
6024 } -result {
6025             speaker on
6026             speaker play bark.snd
6027             speaker off
6028         }
6029
6030 test tinfo-8.2 {type info body, too few args} -body {
6031     type dog {
6032         typemethod bark {volume} {}
6033     }
6034
6035     dog info body
6036 } -returnCodes error -cleanup {
6037     dog destroy
6038 } -result [tcltest::wrongNumArgs ::snit::RT.typemethod.info.body {type method} 1]
6039
6040 test tinfo-8.3 {type info body, too many args} -body {
6041     type dog {
6042         typemethod bark {volume} {}
6043     }
6044
6045     dog info body bark wag
6046 } -returnCodes error -cleanup {
6047     dog destroy
6048 } -result [tcltest::tooManyArgs ::snit::RT.typemethod.info.body {type method}]
6049
6050 test tinfo-8.4 {type info body, unknown method} -body {
6051     type dog {
6052     }
6053
6054     dog info body bark
6055 } -returnCodes error -cleanup {
6056     dog destroy
6057 } -result {Unknown typemethod "bark"}
6058
6059 test tinfo-8.5 {type info body, delegated method} -body {
6060     type dog {
6061         delegate typemethod bark to x
6062     }
6063
6064     dog info body bark
6065 } -returnCodes error -cleanup {
6066     dog destroy
6067 } -result {Delegated typemethod "bark"}
6068
6069 #-----------------------------------------------------------------------
6070 # Setting the widget class explicitly
6071
6072 test widgetclass-1.1 {can't set widgetclass for snit::types} -body {
6073     type dog {
6074         widgetclass Dog
6075     }
6076 } -returnCodes {
6077     error
6078 } -result {widgetclass cannot be set for snit::types}
6079
6080 test widgetclass-1.2 {can't set widgetclass for snit::widgetadaptors} -constraints {
6081     tk
6082 } -body {
6083     widgetadaptor dog {
6084         widgetclass Dog
6085     }
6086 } -returnCodes {
6087     error
6088 } -result {widgetclass cannot be set for snit::widgetadaptors}
6089
6090 test widgetclass-1.3 {widgetclass must begin with uppercase letter} -constraints {
6091     tk
6092 } -body {
6093     widget dog {
6094         widgetclass dog
6095     }
6096 } -returnCodes {
6097     error
6098 } -result {widgetclass "dog" does not begin with an uppercase letter}
6099
6100 test widgetclass-1.4 {widgetclass can only be defined once} -constraints {
6101     tk
6102 } -body {
6103     widget dog {
6104         widgetclass Dog
6105         widgetclass Dog
6106     }
6107 } -returnCodes {
6108     error
6109 } -result {too many widgetclass statements}
6110
6111 test widgetclass-1.5 {widgetclass set successfully} -constraints {
6112     tk
6113 } -body {
6114     widget dog {
6115         widgetclass DogWidget
6116     }
6117
6118     # The test passes if no error is thrown.
6119     list ok
6120 } -cleanup {
6121     dog destroy
6122 } -result {ok}
6123
6124 test widgetclass-1.6 {implicit widgetclass applied to hull} -constraints {
6125     tk
6126 } -body {
6127     widget dog {
6128         typeconstructor {
6129             option add *Dog.background green
6130         }
6131
6132         method background {} {
6133             $hull cget -background
6134         }
6135     }
6136
6137     dog .dog
6138
6139     set bg [.dog background]
6140
6141     destroy .dog
6142
6143     set bg
6144 } -cleanup {
6145     dog destroy
6146 } -result {green}
6147
6148 test widgetclass-1.7 {explicit widgetclass applied to hull} -constraints {
6149     tk
6150 } -body {
6151     widget dog {
6152         widgetclass DogWidget
6153
6154         typeconstructor {
6155             option add *DogWidget.background green
6156         }
6157
6158         method background {} {
6159             $hull cget -background
6160         }
6161     }
6162
6163     dog .dog
6164
6165     set bg [.dog background]
6166
6167     destroy .dog
6168
6169     set bg
6170 } -cleanup {
6171     dog destroy
6172 } -result {green}
6173
6174 #-----------------------------------------------------------------------
6175 # hulltype statement
6176
6177 test hulltype-1.1 {can't set hulltype for snit::types} -body {
6178     type dog {
6179         hulltype Dog
6180     }
6181 } -returnCodes {
6182     error
6183 } -result {hulltype cannot be set for snit::types}
6184
6185 test hulltype-1.2 {can't set hulltype for snit::widgetadaptors} -constraints {
6186     tk
6187 } -body {
6188     widgetadaptor dog {
6189         hulltype Dog
6190     }
6191 } -returnCodes {
6192     error
6193 } -result {hulltype cannot be set for snit::widgetadaptors}
6194
6195 test hulltype-1.3 {hulltype can be frame} -constraints {
6196     tk
6197 } -body {
6198     widget dog {
6199         delegate option * to hull
6200         hulltype frame
6201     }
6202
6203     dog .fido
6204     catch {.fido configure -use} result
6205     destroy .fido
6206     tkbide
6207
6208     set result
6209 } -cleanup {
6210     dog destroy
6211 } -result {unknown option "-use"}
6212
6213 test hulltype-1.4 {hulltype can be toplevel} -constraints {
6214     tk
6215 } -body {
6216     widget dog {
6217         delegate option * to hull
6218         hulltype toplevel
6219     }
6220
6221     dog .fido
6222     catch {.fido configure -use} result
6223     destroy .fido
6224     tkbide
6225
6226     set result
6227 } -cleanup {
6228     dog destroy
6229 } -result {-use use Use {} {}}
6230
6231 test hulltype-1.5 {hulltype can only be defined once} -constraints {
6232     tk
6233 } -body {
6234     widget dog {
6235         hulltype frame
6236         hulltype toplevel
6237     }
6238 } -returnCodes {
6239     error
6240 } -result {too many hulltype statements}
6241
6242 test hulltype-2.1 {list of valid hulltypes} -constraints {
6243     tk
6244 } -body {
6245     lsort $::snit::hulltypes
6246 } -result {frame labelframe tk::frame tk::labelframe tk::toplevel toplevel ttk::frame ttk::labelframe}
6247
6248
6249 #-----------------------------------------------------------------------
6250 # expose statement
6251
6252 test expose-1.1 {can't expose nothing} -body {
6253     type dog {
6254         expose
6255     }
6256 } -constraints {
6257     snit1
6258 } -returnCodes {
6259     error
6260 } -result [tcltest::wrongNumArgs ::snit::Comp.statement.expose {component ?as? ?methodname?} 0]
6261
6262 test expose-1.1a {can't expose nothing} -body {
6263     type dog {
6264         expose
6265     }
6266 } -constraints {
6267     snit2
6268 } -returnCodes {
6269     error
6270 } -result [tcltest::wrongNumArgs expose {component ?as? ?methodname?} 0]
6271
6272 test expose-1.2 {expose a component that's never installed} -body {
6273     type dog {
6274         expose tail
6275     }
6276
6277     dog fido
6278
6279     fido tail wag
6280 } -returnCodes {
6281     error
6282 } -cleanup {
6283     dog destroy
6284 } -result {undefined component "tail"}
6285
6286 test expose-1.3 {exposed method returns component command} -body {
6287     type tail {  }
6288
6289     type dog {
6290         expose tail
6291
6292         constructor {} {
6293             install tail using tail $self.tail
6294         }
6295
6296         destructor {
6297             $tail destroy
6298         }
6299     }
6300
6301     dog fido
6302
6303     fido tail
6304 } -cleanup {
6305     dog destroy
6306     tail destroy
6307 } -result {::fido.tail}
6308
6309 test expose-1.4 {exposed method calls component methods} -body {
6310     type tail {
6311         method wag   {args} {return "wag<$args>"}
6312         method droop {}     {return "droop"}
6313     }
6314
6315     type dog {
6316         expose tail
6317
6318         constructor {} {
6319             install tail using tail $self.tail
6320         }
6321
6322         destructor {
6323             $tail destroy
6324         }
6325     }
6326
6327     dog fido
6328
6329     list [fido tail wag] [fido tail wag abc] [fido tail wag abc def] \
6330         [fido tail droop]
6331 } -cleanup {
6332     dog destroy
6333     tail destroy
6334 } -result {wag<> wag<abc> {wag<abc def>} droop}
6335
6336 #-----------------------------------------------------------------------
6337 # Error handling
6338 #
6339 # This section verifies that errorInfo and errorCode are propagated
6340 # appropriately on error.
6341
6342 test error-1.1 {typemethod errors propagate properly} -body {
6343     type dog {
6344         typemethod generr {} {
6345             error bogusError bogusInfo bogusCode
6346         }
6347     }
6348
6349     catch {dog generr} result
6350
6351     global errorInfo errorCode
6352
6353     list $result [string match "*bogusInfo*" $errorInfo] $errorCode
6354 } -cleanup {
6355     dog destroy
6356 } -result {bogusError 1 bogusCode}
6357
6358 test error-1.2 {snit::type constructor errors propagate properly} -body {
6359     type dog {
6360         constructor {} {
6361             error bogusError bogusInfo bogusCode
6362         }
6363     }
6364
6365     catch {dog fido} result
6366
6367     global errorInfo errorCode
6368
6369     list $result [string match "*bogusInfo*" $errorInfo] $errorCode
6370 } -cleanup {
6371     dog destroy
6372 } -result {{Error in constructor: bogusError} 1 bogusCode}
6373
6374 test error-1.3 {snit::widget constructor errors propagate properly} -constraints {
6375     tk
6376 } -body {
6377     widget dog {
6378         constructor {args} {
6379             error bogusError bogusInfo bogusCode
6380         }
6381     }
6382
6383     catch {dog .fido} result
6384
6385     global errorInfo errorCode
6386
6387     list $result [string match "*bogusInfo*" $errorInfo] $errorCode
6388 } -cleanup {
6389     dog destroy
6390 } -result {{Error in constructor: bogusError} 1 bogusCode}
6391
6392 test error-1.4 {method errors propagate properly} -body {
6393     type dog {
6394         method generr {} {
6395             error bogusError bogusInfo bogusCode
6396         }
6397     }
6398
6399     dog fido
6400     catch {fido generr} result
6401
6402     global errorInfo errorCode
6403
6404     list $result [string match "*bogusInfo*" $errorInfo] $errorCode
6405 } -cleanup {
6406     dog destroy
6407 } -result {bogusError 1 bogusCode}
6408
6409 test error-1.5 {onconfigure errors propagate properly} -body {
6410     type dog {
6411         option -generr
6412
6413         onconfigure -generr {value} {
6414             error bogusError bogusInfo bogusCode
6415         }
6416     }
6417
6418     dog fido
6419     catch {fido configure -generr 0} result
6420
6421     global errorInfo errorCode
6422
6423     list $result [string match "*bogusInfo*" $errorInfo] $errorCode
6424 } -cleanup {
6425     dog destroy
6426 } -result {bogusError 1 bogusCode}
6427
6428 test error-1.6 {oncget errors propagate properly} -body {
6429     type dog {
6430         option -generr
6431
6432         oncget -generr {
6433             error bogusError bogusInfo bogusCode
6434         }
6435     }
6436
6437     dog fido
6438     catch {fido cget -generr} result
6439
6440     global errorInfo errorCode
6441
6442     list $result [string match "*bogusInfo*" $errorInfo] $errorCode
6443 } -cleanup {
6444     dog destroy
6445 } -result {bogusError 1 bogusCode}
6446
6447 #-----------------------------------------------------------------------
6448 # Externally defined typemethods
6449
6450 test etypemethod-1.1 {external typemethods can be called as expected} -body {
6451     type dog { }
6452     typemethod dog foo {a} {return "+$a+"}
6453
6454     dog foo bar
6455 } -cleanup {
6456     dog destroy
6457 } -result {+bar+}
6458
6459 test etypemethod-1.2 {external typemethods can use typevariables} -body {
6460     type dog {
6461         typevariable somevar "Howdy"
6462     }
6463     typemethod dog getvar {} {return $somevar}
6464
6465     dog getvar
6466 } -cleanup {
6467     dog destroy
6468 } -result {Howdy}
6469
6470 test etypemethod-1.3 {typemethods can be redefined dynamically} -body {
6471     type dog {
6472         typemethod foo {} { return "foo" }
6473     }
6474     set a [dog foo]
6475
6476     typemethod dog foo {} { return "bar"}
6477
6478     set b [dog foo]
6479
6480     list $a $b
6481 } -cleanup {
6482     dog destroy
6483 } -result {foo bar}
6484
6485 test etypemethod-1.4 {can't define external typemethod if no type} -body {
6486     typemethod extremelyraredog foo {} { return "bar"}
6487 } -returnCodes {
6488     error
6489 } -result {no such type: "extremelyraredog"}
6490
6491 test etypemethod-2.1 {external hierarchical method, two tokens} -body {
6492     type dog { }
6493     typemethod dog {wag tail} {} {
6494         return "wags tail"
6495     }
6496
6497     dog wag tail
6498 } -cleanup {
6499     dog destroy
6500 } -result {wags tail}
6501
6502 test etypemethod-2.2 {external hierarchical method, three tokens} -body {
6503     type dog { }
6504     typemethod dog {wag tail proudly} {} {
6505         return "wags tail proudly"
6506     }
6507
6508     dog wag tail proudly
6509 } -cleanup {
6510     dog destroy
6511 } -result {wags tail proudly}
6512
6513 test etypemethod-2.3 {external hierarchical method, three tokens} -body {
6514     type dog { }
6515     typemethod dog {wag tail really high} {} {
6516         return "wags tail really high"
6517     }
6518
6519     dog wag tail really high
6520 } -cleanup {
6521     dog destroy
6522 } -result {wags tail really high}
6523
6524 test etypemethod-2.4 {redefinition is OK} -body {
6525     type dog { }
6526     typemethod dog {wag tail} {} {
6527         return "wags tail"
6528     }
6529     typemethod dog {wag tail} {} {
6530         return "wags tail briskly"
6531     }
6532
6533     dog wag tail
6534 } -cleanup {
6535     dog destroy
6536 } -result {wags tail briskly}
6537
6538 test etypemethod-3.1 {prefix/method collision} -body {
6539     type dog {
6540         typemethod wag {} {}
6541     }
6542
6543     typemethod dog {wag tail} {} {}
6544 } -returnCodes {
6545     error
6546 } -cleanup {
6547     dog destroy
6548 } -result {Cannot define "wag tail", "wag" has no submethods.}
6549
6550 test etypemethod-3.2 {prefix/method collision} -body {
6551     type dog {
6552         typemethod {wag tail} {} {}
6553     }
6554
6555     typemethod dog wag {} {}
6556 } -returnCodes {
6557     error
6558 } -cleanup {
6559     dog destroy
6560 } -result {Cannot define "wag", "wag" has submethods.}
6561
6562 test etypemethod-3.3 {prefix/method collision} -body {
6563     type dog {
6564         typemethod {wag tail} {} {}
6565     }
6566
6567     typemethod dog {wag tail proudly} {} {}
6568 } -returnCodes {
6569     error
6570 } -cleanup {
6571     dog destroy
6572 } -result {Cannot define "wag tail proudly", "wag tail" has no submethods.}
6573
6574 test etypemethod-3.4 {prefix/method collision} -body {
6575     type dog {
6576         typemethod {wag tail proudly} {} {}
6577     }
6578
6579     typemethod dog {wag tail} {} {}
6580 } -returnCodes {
6581     error
6582 } -cleanup {
6583     dog destroy
6584 } -result {Cannot define "wag tail", "wag tail" has submethods.}
6585
6586 #-----------------------------------------------------------------------
6587 # Externally defined methods
6588
6589 test emethod-1.1 {external methods can be called as expected} -body {
6590     type dog { }
6591     method dog bark {a} {return "+$a+"}
6592
6593     dog spot
6594     spot bark woof
6595 } -cleanup {
6596     dog destroy
6597 } -result {+woof+}
6598
6599 test emethod-1.2 {external methods can use typevariables} -body {
6600     type dog {
6601         typevariable somevar "Hello"
6602     }
6603     method dog getvar {} {return $somevar}
6604
6605     dog spot
6606     spot getvar
6607 } -cleanup {
6608     dog destroy
6609 } -result {Hello}
6610
6611 test emethod-1.3 {external methods can use variables} -body {
6612     type dog {
6613         variable somevar "Greetings"
6614     }
6615     method dog getvar {} {return $somevar}
6616
6617     dog spot
6618     spot getvar
6619 } -cleanup {
6620     dog destroy
6621 } -result {Greetings}
6622
6623 test emethod-1.4 {methods can be redefined dynamically} -body {
6624     type dog {
6625         method bark {} { return "woof" }
6626     }
6627
6628     dog spot
6629
6630     set a [spot bark]
6631
6632     method dog bark {} { return "arf"}
6633
6634     set b [spot bark]
6635
6636     list $a $b
6637 } -cleanup {
6638     dog destroy
6639 } -result {woof arf}
6640
6641 test emethod-1.5 {delegated methods can't be redefined} -body {
6642     type dog {
6643         delegate method bark to someotherdog
6644     }
6645
6646     method dog bark {} { return "arf"}
6647 } -returnCodes {
6648     error
6649 } -cleanup {
6650     dog destroy
6651 } -result {Cannot define "bark", "bark" has been delegated}
6652
6653 test emethod-1.6 {can't define external method if no type} -body {
6654     method extremelyraredog foo {} { return "bar"}
6655 } -returnCodes {
6656     error
6657 } -result {no such type: "extremelyraredog"}
6658
6659 test emethod-2.1 {external hierarchical method, two tokens} -body {
6660     type dog { }
6661     method dog {wag tail} {} {
6662         return "$self wags tail."
6663     }
6664
6665     dog spot
6666     spot wag tail
6667 } -cleanup {
6668     dog destroy
6669 } -result {::spot wags tail.}
6670
6671 test emethod-2.2 {external hierarchical method, three tokens} -body {
6672     type dog { }
6673     method dog {wag tail proudly} {} {
6674         return "$self wags tail proudly."
6675     }
6676
6677     dog spot
6678     spot wag tail proudly
6679 } -cleanup {
6680     dog destroy
6681 } -result {::spot wags tail proudly.}
6682
6683 test emethod-2.3 {external hierarchical method, three tokens} -body {
6684     type dog { }
6685     method dog {wag tail really high} {} {
6686         return "$self wags tail really high."
6687     }
6688
6689     dog spot
6690     spot wag tail really high
6691 } -cleanup {
6692     dog destroy
6693 } -result {::spot wags tail really high.}
6694
6695 test emethod-2.4 {redefinition is OK} -body {
6696     type dog { }
6697     method dog {wag tail} {} {
6698         return "$self wags tail."
6699     }
6700     method dog {wag tail} {} {
6701         return "$self wags tail briskly."
6702     }
6703
6704     dog spot
6705     spot wag tail
6706 } -cleanup {
6707     dog destroy
6708 } -result {::spot wags tail briskly.}
6709
6710 test emethod-3.1 {prefix/method collision} -body {
6711     type dog {
6712         method wag {} {}
6713     }
6714
6715     method dog {wag tail} {} {
6716         return "$self wags tail."
6717     }
6718 } -returnCodes {
6719     error
6720 } -cleanup {
6721     dog destroy
6722 } -result {Cannot define "wag tail", "wag" has no submethods.}
6723
6724 test emethod-3.2 {prefix/method collision} -body {
6725     type dog {
6726         method {wag tail} {} {
6727             return "$self wags tail."
6728         }
6729     }
6730
6731     method dog wag {} {}
6732 } -returnCodes {
6733     error
6734 } -cleanup {
6735     dog destroy
6736 } -result {Cannot define "wag", "wag" has submethods.}
6737
6738 test emethod-3.3 {prefix/method collision} -body {
6739     type dog {
6740         method {wag tail} {} {}
6741     }
6742
6743     method dog {wag tail proudly} {} {
6744         return "$self wags tail."
6745     }
6746 } -returnCodes {
6747     error
6748 } -cleanup {
6749     dog destroy
6750 } -result {Cannot define "wag tail proudly", "wag tail" has no submethods.}
6751
6752 test emethod-3.4 {prefix/method collision} -body {
6753     type dog {
6754         method {wag tail proudly} {} {
6755             return "$self wags tail."
6756         }
6757     }
6758
6759     method dog {wag tail} {} {}
6760 } -returnCodes {
6761     error
6762 } -cleanup {
6763     dog destroy
6764 } -result {Cannot define "wag tail", "wag tail" has submethods.}
6765
6766
6767 #-----------------------------------------------------------------------
6768 # Macros
6769
6770 test macro-1.1 {can't redefine non-macros} -body {
6771     snit::macro method {} {}
6772 } -returnCodes {
6773     error
6774 } -result {invalid macro name "method"}
6775
6776 test macro-1.2 {can define and use a macro} -body {
6777     snit::macro hello {name} {
6778         method hello {} "return {Hello, $name!}"
6779     }
6780
6781     type dog {
6782         hello World
6783     }
6784
6785     dog spot
6786
6787     spot hello
6788
6789 } -cleanup {
6790     dog destroy
6791 } -result {Hello, World!}
6792
6793 test macro-1.3 {can redefine macro} -body {
6794     snit::macro dup {} {}
6795     snit::macro dup {} {}
6796
6797     set dummy "No error"
6798 } -result {No error}
6799
6800 test macro-1.4 {can define macro in namespace} -body {
6801     snit::macro ::test::goodbye {name} {
6802         method goodbye {} "return {Goodbye, $name!}"
6803     }
6804
6805     type dog {
6806         ::test::goodbye World
6807     }
6808
6809     dog spot
6810
6811     spot goodbye
6812 } -cleanup {
6813     dog destroy
6814 } -result {Goodbye, World!}
6815
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"
6821     }
6822
6823     type dog {
6824         testit
6825     }
6826
6827     dog spot
6828
6829     spot testit
6830 } -cleanup {
6831     dog destroy
6832 } -result {_variable _proc}
6833
6834 test macro-1.6 {_variable works} -body {
6835     snit::macro test1 {} {
6836         _variable myvar "_variable works"
6837     }
6838
6839     snit::macro test2 {} {
6840         _variable myvar
6841
6842         method testit {} "return {$myvar}"
6843     }
6844
6845     type dog {
6846         test1
6847         test2
6848     }
6849
6850     dog spot
6851
6852     spot testit
6853 } -cleanup {
6854     dog destroy
6855 } -result {_variable works}
6856
6857 #-----------------------------------------------------------------------
6858 # Component Statement
6859
6860 test component-1.1 {component defines an instance variable} -body {
6861     type dog {
6862         component tail
6863     }
6864
6865     dog spot
6866
6867     namespace tail [spot info vars tail]
6868 } -cleanup {
6869     dog destroy
6870 } -result {tail}
6871
6872 test component-1.2 {-public exposes the component} -body {
6873     type tail {
6874         method wag {} {
6875             return "Wag, wag"
6876         }
6877     }
6878
6879     type dog {
6880         component tail -public mytail
6881
6882         constructor {} {
6883             set tail [tail %AUTO%]
6884         }
6885     }
6886
6887     dog spot
6888
6889     spot mytail wag
6890 } -cleanup {
6891     dog destroy
6892     tail destroy
6893 } -result {Wag, wag}
6894
6895 test component-1.3 {-inherit requires a boolean value} -body {
6896     type dog {
6897         component animal -inherit foo
6898     }
6899 } -returnCodes {
6900     error
6901 } -result {component animal -inherit: expected boolean value, got "foo"}
6902
6903 test component-1.4 {-inherit delegates unknown methods to the component} -body {
6904     type animal {
6905         method eat {} {
6906             return "Eat, eat."
6907         }
6908     }
6909
6910     type dog {
6911         component animal -inherit yes
6912
6913         constructor {} {
6914             set animal [animal %AUTO%]
6915         }
6916     }
6917
6918     dog spot
6919
6920     spot eat
6921 } -cleanup {
6922     dog destroy
6923     animal destroy
6924 } -result {Eat, eat.}
6925
6926 test component-1.5 {-inherit delegates unknown options to the component} -body {
6927     type animal {
6928         option -size medium
6929     }
6930
6931     type dog {
6932         component animal -inherit yes
6933
6934         constructor {} {
6935             set animal [animal %AUTO%]
6936         }
6937     }
6938
6939     dog spot
6940
6941     spot cget -size
6942 } -cleanup {
6943     dog destroy
6944     animal destroy
6945 } -result {medium}
6946
6947 #-----------------------------------------------------------------------
6948 # Typevariables, Variables, Typecomponents, Components
6949
6950 test typevar_var-1.1 {variable/typevariable collisions not allowed: order 1} -body {
6951     type dog {
6952         typevariable var
6953         variable var
6954     }
6955 } -returnCodes {
6956     error
6957 } -result {Error in "variable var...", "var" is already a typevariable}
6958
6959 test typevar_var-1.2 {variable/typevariable collisions not allowed: order 2} -body {
6960     type dog {
6961         variable var
6962         typevariable var
6963     }
6964 } -returnCodes {
6965     error
6966 } -result {Error in "typevariable var...", "var" is already an instance variable}
6967
6968 test typevar_var-1.3 {component/typecomponent collisions not allowed: order 1} -body {
6969     type dog {
6970         typecomponent comp
6971         component comp
6972     }
6973 } -returnCodes {
6974     error
6975 } -result {Error in "component comp...", "comp" is already a typevariable}
6976
6977 test typevar_var-1.4 {component/typecomponent collisions not allowed: order 2} -body {
6978     type dog {
6979         component comp
6980         typecomponent comp
6981     }
6982 } -returnCodes {
6983     error
6984 } -result {Error in "typecomponent comp...", "comp" is already an instance variable}
6985
6986 test typevar_var-1.5 {can't delegate options to typecomponents} -body {
6987     type dog {
6988         typecomponent comp
6989
6990         delegate option -opt to comp
6991     }
6992 } -returnCodes {
6993     error
6994 } -result {Error in "delegate option -opt...", "comp" is already a typevariable}
6995
6996 test typevar_var-1.6 {can't delegate typemethods to instance components} -body {
6997     type dog {
6998         component comp
6999
7000         delegate typemethod foo to comp
7001     }
7002 } -returnCodes {
7003     error
7004 } -result {Error in "delegate typemethod foo...", "comp" is already an instance variable}
7005
7006 test typevar_var-1.7 {can delegate methods to typecomponents} -body {
7007     proc echo {args} {return [join $args "|"]}
7008
7009     type dog {
7010         typecomponent tail
7011
7012         typeconstructor {
7013             set tail echo
7014         }
7015
7016         delegate method wag to tail
7017     }
7018
7019     dog spot
7020     spot wag briskly
7021 } -cleanup {
7022     dog destroy
7023     rename echo ""
7024 } -result {wag|briskly}
7025
7026 #-----------------------------------------------------------------------
7027 # Option syntax tests.
7028 #
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.
7032 #
7033 # TBD: At some point, this needs to be folded into the regular
7034 # option tests.
7035
7036 test optionsyntax-1.1 {local option names are saved} -body {
7037     type dog {
7038         option -foo
7039         option -bar
7040     }
7041
7042     set ::dog::Snit_optionInfo(local)
7043 } -cleanup {
7044     dog destroy
7045 } -result {-foo -bar}
7046
7047 test optionsyntax-1.2 {islocal flag is set} -body {
7048     type dog {
7049         option -foo
7050     }
7051
7052     set ::dog::Snit_optionInfo(islocal--foo)
7053 } -cleanup {
7054     dog destroy
7055 } -result {1}
7056
7057 test optionsyntax-2.1 {implicit resource and class} -body {
7058     type dog {
7059         option -foo
7060     }
7061
7062     list \
7063         $::dog::Snit_optionInfo(resource--foo) \
7064         $::dog::Snit_optionInfo(class--foo)
7065 } -cleanup {
7066     dog destroy
7067 } -result {foo Foo}
7068
7069 test optionsyntax-2.2 {explicit resource, default class} -body {
7070     type dog {
7071         option {-foo ffoo}
7072     }
7073
7074     list \
7075         $::dog::Snit_optionInfo(resource--foo) \
7076         $::dog::Snit_optionInfo(class--foo)
7077 } -cleanup {
7078     dog destroy
7079 } -result {ffoo Ffoo}
7080
7081 test optionsyntax-2.3 {explicit resource and class} -body {
7082     type dog {
7083         option {-foo ffoo FFoo}
7084     }
7085
7086     list \
7087         $::dog::Snit_optionInfo(resource--foo) \
7088         $::dog::Snit_optionInfo(class--foo)
7089 } -cleanup {
7090     dog destroy
7091 } -result {ffoo FFoo}
7092
7093 test optionsyntax-2.4 {can't redefine explicit resource} -body {
7094     type dog {
7095         option {-foo ffoo}
7096         option {-foo foo}
7097     }
7098 } -returnCodes {
7099     error
7100 } -result {Error in "option {-foo foo}...", resource name redefined from "ffoo" to "foo"}
7101
7102 test optionsyntax-2.5 {can't redefine explicit class} -body {
7103     type dog {
7104         option {-foo ffoo Ffoo}
7105         option {-foo ffoo FFoo}
7106     }
7107 } -returnCodes {
7108     error
7109 } -result {Error in "option {-foo ffoo FFoo}...", class name redefined from "Ffoo" to "FFoo"}
7110
7111 test optionsyntax-2.6 {can redefine implicit resource and class} -body {
7112     type dog {
7113         option -foo
7114         option {-foo ffoo}
7115         option {-foo ffoo FFoo}
7116         option -foo
7117     }
7118 } -cleanup {
7119     dog destroy
7120 } -result {::dog}
7121
7122 test optionsyntax-3.1 {no default value} -body {
7123     type dog {
7124         option -foo
7125     }
7126
7127     set ::dog::Snit_optionInfo(default--foo)
7128 } -cleanup {
7129     dog destroy
7130 } -result {}
7131
7132 test optionsyntax-3.2 {default value, old syntax} -body {
7133     type dog {
7134         option -foo bar
7135     }
7136
7137     set ::dog::Snit_optionInfo(default--foo)
7138 } -cleanup {
7139     dog destroy
7140 } -result {bar}
7141
7142 test optionsyntax-3.3 {option definition options can be set} -body {
7143     type dog {
7144         option -foo \
7145             -default Bar \
7146             -validatemethod Validate \
7147             -configuremethod Configure \
7148             -cgetmethod Cget \
7149             -readonly 1
7150     }
7151
7152     list \
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)
7158 } -cleanup {
7159     dog destroy
7160 } -result {Bar Validate Configure Cget 1}
7161
7162 test optionsyntax-3.4 {option definition option values accumulate} -body {
7163     type dog {
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
7169     }
7170
7171     list \
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)
7177 } -cleanup {
7178     dog destroy
7179 } -result {Bar Validate Configure Cget 1}
7180
7181 test optionsyntax-3.5 {option definition option values can be redefined} -body {
7182     type dog {
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
7193     }
7194
7195     list \
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)
7201 } -cleanup {
7202     dog destroy
7203 } -result {Bar2 Validate2 Configure2 Cget2 0}
7204
7205 test optionsyntax-3.6 {option -readonly defaults to 0} -body {
7206     type dog {
7207         option -foo
7208     }
7209
7210     set ::dog::Snit_optionInfo(readonly--foo)
7211 } -cleanup {
7212     dog destroy
7213 } -result {0}
7214
7215 test optionsyntax-3.7 {option -readonly can be any boolean} -body {
7216     type dog {
7217         option -foo -readonly 0
7218         option -foo -readonly 1
7219         option -foo -readonly y
7220         option -foo -readonly n
7221     }
7222 } -cleanup {
7223     dog destroy
7224 } -result {::dog}
7225
7226 test optionsyntax-3.8 {option -readonly must be a boolean} -body {
7227     type dog {
7228         option -foo -readonly foo
7229     }
7230 } -returnCodes {
7231     error
7232 } -result {Error in "option -foo...", -readonly requires a boolean, got "foo"}
7233
7234 test optionsyntax-3.9 {option -readonly can't be empty} -body {
7235     type dog {
7236         option -foo -readonly {}
7237     }
7238 } -returnCodes {
7239     error
7240 } -result {Error in "option -foo...", -readonly requires a boolean, got ""}
7241
7242 #-----------------------------------------------------------------------
7243 # 'delegate option' Syntax tests.
7244 #
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.
7248 #
7249 # TBD: At some point, this needs to be folded into the regular
7250 # option tests.
7251
7252 test delegateoptionsyntax-1.1 {'delegated' lists delegated option names} -body {
7253     type dog {
7254         delegate option -foo to comp
7255         delegate option -bar to comp
7256     }
7257
7258     set ::dog::Snit_optionInfo(delegated)
7259 } -cleanup {
7260     dog destroy
7261 } -result {-foo -bar}
7262
7263 test delegateoptionsyntax-1.2 {'delegated' does not include '*'} -body {
7264     type dog {
7265         delegate option * to comp
7266     }
7267
7268     set ::dog::Snit_optionInfo(delegated)
7269 } -cleanup {
7270     dog destroy
7271 } -result {}
7272
7273 test delegateoptionsyntax-1.3 {'islocal' is set to 0} -body {
7274     type dog {
7275         delegate option -foo to comp
7276     }
7277
7278     set ::dog::Snit_optionInfo(islocal--foo)
7279 } -cleanup {
7280     dog destroy
7281 } -result {0}
7282
7283 test delegateoptionsyntax-1.4 {'islocal' is not set for '*'} -body {
7284     type dog {
7285         delegate option * to comp
7286     }
7287
7288     info exists ::dog::Snit_optionInfo(islocal-*)
7289 } -cleanup {
7290     dog destroy
7291 } -result {0}
7292
7293 test delegateoptionsyntax-1.5 {'delegated-$comp' lists options for the component} -body {
7294     type dog {
7295         delegate option -foo to comp1
7296         delegate option -bar to comp1
7297         delegate option -baz to comp2
7298
7299         # The * won't show up.
7300         delegate option * to comp2
7301     }
7302
7303     list \
7304         $::dog::Snit_optionInfo(delegated-comp1) \
7305         $::dog::Snit_optionInfo(delegated-comp2)
7306 } -cleanup {
7307     dog destroy
7308 } -result {{-foo -bar} -baz}
7309
7310 test delegateoptionsyntax-1.6 {'except' is empty by default} -body {
7311     type dog {
7312         delegate option -foo to comp
7313     }
7314
7315     set ::dog::Snit_optionInfo(except)
7316 } -cleanup {
7317     dog destroy
7318 } -result {}
7319
7320 test delegateoptionsyntax-1.7 {'except' lists exceptions} -body {
7321     type dog {
7322         delegate option * to comp except {-foo -bar -baz}
7323     }
7324
7325     set ::dog::Snit_optionInfo(except)
7326 } -cleanup {
7327     dog destroy
7328 } -result {-foo -bar -baz}
7329
7330 test delegateoptionsyntax-1.8 {'target-$opt' set with default} -body {
7331     type dog {
7332         delegate option -foo to comp
7333     }
7334
7335     set ::dog::Snit_optionInfo(target--foo)
7336 } -cleanup {
7337     dog destroy
7338 } -result {comp -foo}
7339
7340 test delegateoptionsyntax-1.9 {'target-$opt' set explicitly} -body {
7341     type dog {
7342         delegate option -foo to comp as -bar
7343     }
7344
7345     set ::dog::Snit_optionInfo(target--foo)
7346 } -cleanup {
7347     dog destroy
7348 } -result {comp -bar}
7349
7350 test delegateoptionsyntax-1.10 {'starcomp' is {} by default} -body {
7351     type dog {
7352         delegate option -foo to comp
7353     }
7354
7355     set ::dog::Snit_optionInfo(starcomp)
7356 } -cleanup {
7357     dog destroy
7358 } -result {}
7359
7360 test delegateoptionsyntax-1.11 {'starcomp' set for *} -body {
7361     type dog {
7362         delegate option * to comp
7363     }
7364
7365     set ::dog::Snit_optionInfo(starcomp)
7366 } -cleanup {
7367     dog destroy
7368 } -result {comp}
7369
7370 test delegatedoptionsyntax-2.1 {implicit resource and class} -body {
7371     type dog {
7372         delegate option -foo to comp
7373     }
7374
7375     list \
7376         $::dog::Snit_optionInfo(resource--foo) \
7377         $::dog::Snit_optionInfo(class--foo)
7378 } -cleanup {
7379     dog destroy
7380 } -result {foo Foo}
7381
7382 test delegatedoptionsyntax-2.2 {explicit resource, default class} -body {
7383     type dog {
7384         delegate option {-foo ffoo} to comp
7385     }
7386
7387     list \
7388         $::dog::Snit_optionInfo(resource--foo) \
7389         $::dog::Snit_optionInfo(class--foo)
7390 } -cleanup {
7391     dog destroy
7392 } -result {ffoo Ffoo}
7393
7394 test delegatedoptionsyntax-2.3 {explicit resource and class} -body {
7395     type dog {
7396         delegate option {-foo ffoo FFoo} to comp
7397     }
7398
7399     list \
7400         $::dog::Snit_optionInfo(resource--foo) \
7401         $::dog::Snit_optionInfo(class--foo)
7402 } -cleanup {
7403     dog destroy
7404 } -result {ffoo FFoo}
7405
7406 test delegatedoptionsyntax-2.4 {* doesn't get resource and class} -body {
7407     type dog {
7408         delegate option * to comp
7409     }
7410
7411     list \
7412         [info exist ::dog::Snit_optionInfo(resource-*)] \
7413         [info exist ::dog::Snit_optionInfo(class-*)]
7414 } -cleanup {
7415     dog destroy
7416 } -result {0 0}
7417
7418 #-----------------------------------------------------------------------
7419 # Cget cache
7420
7421 test cgetcache-1.1 {Instance rename invalidates cache} -body {
7422     type dog {
7423         option -foo -default bar -cgetmethod getfoo
7424
7425         method getfoo {option} {
7426             return $options($option)
7427         }
7428     }
7429
7430     dog fido -foo quux
7431
7432     # Cache the cget command.
7433     fido cget -foo
7434
7435     rename fido spot
7436
7437     spot cget -foo
7438 } -cleanup {
7439     dog destroy
7440 } -result {quux}
7441
7442 test cgetcache-1.2 {Component rename invalidates cache} -body {
7443     type tail {
7444         option -foo bar
7445     }
7446
7447     type dog {
7448         delegate option -foo to tail
7449
7450         constructor {args} {
7451             set tail [tail %AUTO%]
7452             $tail configure -foo quux
7453         }
7454
7455         method retail {} {
7456             set tail [tail %AUTO%]
7457         }
7458     }
7459
7460     dog fido
7461
7462     # Cache the cget command.
7463     fido cget -foo
7464
7465     # Invalidate the cache
7466     fido retail
7467
7468     fido cget -foo
7469 } -cleanup {
7470     dog destroy
7471     tail destroy
7472 } -result {bar}
7473
7474 # case 1
7475 test cgetcache-1.3 {Invalid -cgetmethod causes error} -constraints {
7476     snit1
7477 } -body {
7478     type dog {
7479         option -foo -default bar -cgetmethod bogus
7480     }
7481
7482     dog fido -foo quux
7483
7484     fido cget -foo
7485 } -returnCodes {
7486     error
7487 } -cleanup {
7488     dog destroy
7489 } -result {can't cget -foo, "::fido bogus" is not defined}
7490
7491 # case 2
7492 test cgetcache-1.4 {Invalid -cgetmethod causes error} -constraints {
7493     snit2
7494 } -body {
7495     type dog {
7496         option -foo -default bar -cgetmethod bogus
7497     }
7498
7499     dog fido -foo quux
7500
7501     fido cget -foo
7502 } -returnCodes {
7503     error
7504 } -cleanup {
7505     dog destroy
7506 } -result {unknown subcommand "bogus": must be cget, or configurelist}
7507
7508 test cgetcache-1.5 {hierarchical -cgetmethod} -body {
7509     type dog {
7510         option -foo -default bar -cgetmethod {Get Opt}
7511
7512         method {Get Opt} {option} {
7513             return Dummy
7514         }
7515     }
7516
7517     dog fido
7518
7519     fido cget -foo
7520 } -cleanup {
7521     dog destroy
7522 } -result {Dummy}
7523
7524 #-----------------------------------------------------------------------
7525 # Configure cache
7526
7527 test configurecache-1.1 {Instance rename invalidates cache} -body {
7528     type dog {
7529         option -foo -default bar -configuremethod setfoo
7530
7531         method setfoo {option value} {
7532             $self setoption $option $value
7533         }
7534
7535         method setoption {option value} {
7536             set options($option) $value
7537         }
7538     }
7539
7540     # Set the option on creation; this will cache the
7541     # configure command.
7542     dog fido -foo quux
7543
7544     rename fido spot
7545
7546     spot configure -foo baz
7547     spot cget -foo
7548 } -cleanup {
7549     dog destroy
7550 } -result {baz}
7551
7552 test configurecache-1.2 {Component rename invalidates cache} -body {
7553     type tail {
7554         option -foo bar
7555     }
7556
7557     type dog {
7558         delegate option -foo to tail
7559
7560         constructor {args} {
7561             set tail [tail thistail]
7562             $self configurelist $args
7563         }
7564
7565         method retail {} {
7566             # Give it a new component
7567             set tail [tail thattail]
7568         }
7569     }
7570
7571     # Set the tail's -foo, and cache the command.
7572     dog fido -foo quux
7573
7574     # Invalidate the cache
7575     fido retail
7576
7577     # Should recache, and set the new tail's option.
7578     fido configure -foo baz
7579
7580     fido cget -foo
7581 } -cleanup {
7582     dog destroy
7583     tail destroy
7584 } -result {baz}
7585
7586 # Case 1
7587 test configurecache-1.3 {Invalid -configuremethod causes error} -constraints {
7588     snit1
7589 } -body {
7590     type dog {
7591         option -foo -default bar -configuremethod bogus
7592     }
7593
7594     dog fido
7595     fido configure -foo quux
7596 } -returnCodes {
7597     error
7598 } -cleanup {
7599     dog destroy
7600 } -result {can't configure -foo, "::fido bogus" is not defined}
7601
7602 # Case 2
7603 test configurecache-1.4 {Invalid -configuremethod causes error} -constraints {
7604     snit2
7605 } -body {
7606     type dog {
7607         option -foo -default bar -configuremethod bogus
7608     }
7609
7610     dog fido
7611     fido configure -foo quux
7612 } -returnCodes {
7613     error
7614 } -cleanup {
7615     dog destroy
7616 } -result {unknown subcommand "bogus": must be configure, or configurelist}
7617
7618 test configurecache-1.5 {hierarchical -configuremethod} -body {
7619     type dog {
7620         option -foo -default bar -configuremethod {Set Opt}
7621
7622         method {Set Opt} {option value} {
7623             set options($option) Dummy
7624         }
7625     }
7626
7627     dog fido -foo NotDummy
7628     fido cget -foo
7629 } -cleanup {
7630     dog destroy
7631 } -result {Dummy}
7632
7633
7634
7635 #-----------------------------------------------------------------------
7636 # option -validatemethod
7637
7638 test validatemethod-1.1 {Validate method is called} -body {
7639     type dog {
7640         variable flag 0
7641
7642         option -color \
7643             -default black \
7644             -validatemethod ValidateColor
7645
7646         method ValidateColor {option value} {
7647             set flag 1
7648         }
7649
7650         method getflag {} {
7651             return $flag
7652         }
7653     }
7654
7655     dog fido -color brown
7656     fido getflag
7657 } -cleanup {
7658     dog destroy
7659 } -result {1}
7660
7661 test validatemethod-1.2 {Validate method gets correct arguments} -body {
7662     type dog {
7663         option -color \
7664             -default black \
7665             -validatemethod ValidateColor
7666
7667         method ValidateColor {option value} {
7668             if {![string equal $option "-color"] ||
7669                 ![string equal $value "brown"]} {
7670                 error "Expected '-color brown'"
7671             }
7672         }
7673     }
7674
7675     dog fido -color brown
7676 } -cleanup {
7677     dog destroy
7678 } -result {::fido}
7679
7680 # Case 1
7681 test validatemethod-1.3 {Invalid -validatemethod causes error} -constraints {
7682     snit1
7683 } -body {
7684     type dog {
7685         option -foo -default bar -validatemethod bogus
7686     }
7687
7688     dog fido
7689     fido configure -foo quux
7690 } -returnCodes {
7691     error
7692 } -cleanup {
7693     dog destroy
7694 } -result {can't validate -foo, "::fido bogus" is not defined}
7695
7696 # Case 2
7697 test validatemethod-1.4 {Invalid -validatemethod causes error} -constraints {
7698     snit2
7699 } -body {
7700     type dog {
7701         option -foo -default bar -validatemethod bogus
7702     }
7703
7704     dog fido
7705     fido configure -foo quux
7706 } -returnCodes {
7707     error
7708 } -cleanup {
7709     dog destroy
7710 } -result {unknown subcommand "bogus": must be configure, or configurelist}
7711
7712 test validatemethod-1.5 {hierarchical -validatemethod} -body {
7713     type dog {
7714         option -foo -default bar -validatemethod {Val Opt}
7715
7716         method {Val Opt} {option value} {
7717             error "Dummy"
7718         }
7719     }
7720
7721     dog fido -foo value
7722 } -returnCodes {
7723     error
7724 } -cleanup {
7725     dog destroy
7726 } -result {Error in constructor: Dummy}
7727
7728
7729
7730 #-----------------------------------------------------------------------
7731 # option -readonly semantics
7732
7733 test optionreadonly-1.1 {Readonly options can be set at creation time} -body {
7734     type dog {
7735         option -color \
7736             -default black \
7737             -readonly true
7738     }
7739
7740     dog fido -color brown
7741
7742     fido cget -color
7743 } -cleanup {
7744     dog destroy
7745 } -result {brown}
7746
7747 test optionreadonly-1.2 {Readonly options can't be set after creation} -body {
7748     type dog {
7749         option -color \
7750             -default black \
7751             -readonly true
7752     }
7753
7754     dog fido
7755
7756     fido configure -color brown
7757 } -returnCodes {
7758     error
7759 } -cleanup {
7760     dog destroy
7761 } -result {option -color can only be set at instance creation}
7762
7763 test optionreadonly-1.3 {Readonly options can't be set after creation} -body {
7764     type dog {
7765         option -color \
7766             -default black \
7767             -readonly true
7768     }
7769
7770     dog fido -color yellow
7771
7772     fido configure -color brown
7773 } -returnCodes {
7774     error
7775 } -cleanup {
7776     dog destroy
7777 } -result {option -color can only be set at instance creation}
7778
7779 #-----------------------------------------------------------------------
7780 # Pragma -hastypeinfo
7781
7782 test hastypeinfo-1.1 {$type info is defined by default} -body {
7783     type dog {
7784         typevariable foo
7785     }
7786
7787     dog info typevars
7788 } -cleanup {
7789     dog destroy
7790 } -result {::dog::foo}
7791
7792 # Case 1
7793 test hastypeinfo-1.2 {$type info can be disabled} -constraints {
7794     snit1
7795 } -body {
7796     type dog {
7797         pragma -hastypeinfo no
7798         typevariable foo
7799     }
7800
7801     dog info typevars
7802 } -returnCodes {
7803     error
7804 } -cleanup {
7805     dog destroy
7806 } -result {"::dog info" is not defined}
7807
7808 # Case 2
7809 test hastypeinfo-1.3 {$type info can be disabled} -constraints {
7810     snit2
7811 } -body {
7812     type dog {
7813         pragma -hastypeinfo no
7814         typevariable foo
7815     }
7816
7817     dog info typevars
7818 } -returnCodes {
7819     error
7820 } -cleanup {
7821     dog destroy
7822 } -result {unknown subcommand "info": namespace ::dog does not export any commands}
7823
7824
7825 #-----------------------------------------------------------------------
7826 # Pragma -hastypedestroy
7827
7828 test hastypedestroy-1.1 {$type destroy is defined by default} -body {
7829     type dog {
7830         typevariable foo
7831     }
7832
7833     dog destroy
7834
7835     ::dog info typevars
7836 } -returnCodes {
7837     error
7838 } -result {invalid command name "::dog"}
7839
7840 # Case 1
7841 test hastypedestroy-1.2 {$type destroy can be disabled} -constraints {
7842     snit1
7843 } -body {
7844     type dog {
7845         pragma -hastypedestroy no
7846         typevariable foo
7847     }
7848
7849     dog destroy
7850 } -returnCodes {
7851     error
7852 } -cleanup {
7853     rename ::dog ""
7854     namespace delete ::dog
7855 } -result {"::dog destroy" is not defined}
7856
7857 # Case 2
7858 test hastypedestroy-1.3 {$type destroy can be disabled} -constraints {
7859     snit2
7860 } -body {
7861     type dog {
7862         pragma -hastypedestroy no
7863         typevariable foo
7864     }
7865
7866     dog destroy
7867 } -returnCodes {
7868     error
7869 } -cleanup {
7870     rename ::dog ""
7871     namespace delete ::dog
7872 } -result {unknown subcommand "destroy": namespace ::dog does not export any commands}
7873
7874 #-----------------------------------------------------------------------
7875 # Pragma -hasinstances
7876
7877 test hasinstances-1.1 {-hasinstances is true by default} -body {
7878     type dog {
7879         method bark {} {
7880             return "Woof"
7881         }
7882     }
7883
7884     dog fido
7885     fido bark
7886 } -cleanup {
7887     dog destroy
7888 } -result {Woof}
7889
7890 # Case 1
7891 test hasinstances-1.2 {'-hasinstances no' disables explicit object creation} -constraints {
7892     snit1
7893 } -body {
7894     type dog {
7895         pragma -hasinstances no
7896     }
7897
7898     dog create fido
7899 } -returnCodes {
7900     error
7901 } -cleanup {
7902     dog destroy
7903 } -result {"::dog create" is not defined}
7904
7905 # Case 2
7906 test hasinstances-1.3 {'-hasinstances no' disables explicit object creation} -constraints {
7907     snit2
7908 } -body {
7909     type dog {
7910         pragma -hasinstances no
7911     }
7912
7913     dog create fido
7914 } -returnCodes {
7915     error
7916 } -cleanup {
7917     dog destroy
7918 } -result {unknown subcommand "create": namespace ::dog does not export any commands}
7919
7920 # Case 1
7921 test hasinstances-1.4 {'-hasinstances no' disables implicit object creation} -constraints {
7922     snit1
7923 } -body {
7924     type dog {
7925         pragma -hasinstances no
7926     }
7927
7928     dog fido
7929 } -returnCodes {
7930     error
7931 } -result {"::dog fido" is not defined}
7932
7933 # Case 2
7934 test hasinstances-1.5 {'-hasinstances no' disables implicit object creation} -constraints {
7935     snit2
7936 } -body {
7937     type dog {
7938         pragma -hasinstances no
7939     }
7940
7941     dog fido
7942 } -returnCodes {
7943     error
7944 } -result {unknown subcommand "fido": namespace ::dog does not export any commands}
7945
7946 #-----------------------------------------------------------------------
7947 # pragma -canreplace
7948
7949 test canreplace-1.1 {By default, "-canreplace no"} -body {
7950     type dog {
7951         # ...
7952     }
7953
7954     dog fido
7955     dog fido
7956 } -returnCodes {
7957     error
7958 } -cleanup {
7959     dog destroy
7960 } -result {command "::fido" already exists}
7961
7962 test canreplace-1.2 {Can replace commands when "-canreplace yes"} -constraints {
7963     bug8.5a3
7964 } -body {
7965     type dog {
7966         pragma -canreplace yes
7967     }
7968
7969     dog fido
7970     dog fido
7971 } -cleanup {
7972     dog destroy
7973 } -result {::fido}
7974
7975 #-----------------------------------------------------------------------
7976 # pragma -hasinfo
7977
7978 test hasinfo-1.1 {$obj info is defined by default} -body {
7979     type dog {
7980         variable foo ""
7981     }
7982
7983     dog spot
7984     spot info vars
7985 } -cleanup {
7986     dog destroy
7987 } -result {::dog::Snit_inst1::foo}
7988
7989 # Case 1
7990 test hasinfo-1.2 {$obj info can be disabled} -constraints {
7991     snit1
7992 } -body {
7993     type dog {
7994         pragma -hasinfo no
7995         variable foo
7996     }
7997
7998     dog spot
7999     spot info vars
8000 } -returnCodes {
8001     error
8002 } -cleanup {
8003     dog destroy
8004 } -result {"::spot info" is not defined}
8005
8006 # Case 2
8007 test hasinfo-1.3 {$obj info can be disabled} -constraints {
8008     snit2
8009 } -body {
8010     type dog {
8011         pragma -hasinfo no
8012         variable foo
8013     }
8014
8015     dog spot
8016     spot info vars
8017 } -returnCodes {
8018     error
8019 } -cleanup {
8020     dog destroy
8021 } -result {unknown subcommand "info": namespace ::dog::Snit_inst1 does not export any commands}
8022
8023 #-----------------------------------------------------------------------
8024 # pragma -hastypemethods
8025 #
8026 # The "-hastypemethods yes" case is tested by the bulk of this file.
8027 # We'll test the "-hastypemethods no" case here.
8028
8029 test hastypemethods-1.1 {-hastypemethods no, $type foo creates instance.} -body {
8030     type dog {
8031         pragma -hastypemethods no
8032         variable foo
8033     }
8034
8035     dog spot
8036 } -cleanup {
8037     spot destroy
8038     rename ::dog ""
8039     namespace delete ::dog
8040 } -result {::spot}
8041
8042 test hastypemethods-1.2 {-hastypemethods no, $type create foo fails.} -body {
8043     type dog {
8044         pragma -hastypemethods no
8045         variable foo
8046     }
8047
8048     dog create spot
8049 } -returnCodes {
8050     error
8051 } -cleanup {
8052     rename ::dog ""
8053     namespace delete ::dog
8054 } -result "Error in constructor: [tcltest::tooManyArgs ::dog::Snit_constructor {type selfns win self}]"
8055
8056 test hastypemethods-1.3 {-hastypemethods no, $type info fails.} -body {
8057     type dog {
8058         pragma -hastypemethods no
8059         variable foo
8060     }
8061
8062     dog info
8063 } -returnCodes {
8064     error
8065 } -cleanup {
8066     rename ::dog ""
8067     namespace delete ::dog
8068 } -result {command "::info" already exists}
8069
8070 test hastypemethods-1.4 {-hastypemethods no, [$widget] fails.} -constraints {
8071     tk
8072 } -body {
8073     widget dog {
8074         pragma -hastypemethods no
8075         variable foo
8076     }
8077
8078     dog
8079 } -returnCodes {
8080     error
8081 } -cleanup {
8082     rename ::dog ""
8083     namespace delete ::dog
8084 } -result {wrong # args: should be "::dog name args"}
8085
8086 test hastypemethods-1.5 {-hastypemethods no, -hasinstances no fails.} -body {
8087     type dog {
8088         pragma -hastypemethods no
8089         pragma -hasinstances no
8090         variable foo
8091     }
8092 } -returnCodes {
8093     error
8094 } -result {type ::dog has neither typemethods nor instances}
8095
8096 #-----------------------------------------------------------------------
8097 # -simpledispatch yes
8098
8099 test simpledispatch-1.1 {not allowed with method delegation.} -constraints {
8100     snit1
8101 } -body {
8102     type dog {
8103         pragma -simpledispatch yes
8104
8105         delegate method foo to bar
8106     }
8107 } -returnCodes {
8108     error
8109 } -result {type ::dog requests -simpledispatch but delegates methods.}
8110
8111 test simpledispatch-1.2 {normal methods work with simpledispatch.} -constraints {
8112     snit1
8113 } -body {
8114     type dog {
8115         pragma -simpledispatch yes
8116
8117         method barks {how} {
8118             return "$self barks $how."
8119         }
8120     }
8121
8122     dog spot
8123     spot barks loudly
8124 } -cleanup {
8125     dog destroy
8126 } -result {::spot barks loudly.}
8127
8128 test simpledispatch-1.3 {option methods work with simpledispatch.} -constraints {
8129     snit1
8130 } -body {
8131     type dog {
8132         pragma -simpledispatch yes
8133
8134         option -breed mutt
8135     }
8136
8137     dog spot
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]
8143
8144     list $a $b $c
8145 } -cleanup {
8146     dog destroy
8147 } -result {mutt collie sheltie}
8148
8149 test simpledispatch-1.4 {info method works with simpledispatch.} -constraints {
8150     snit1
8151 } -body {
8152     type dog {
8153         pragma -simpledispatch yes
8154
8155         option -breed mutt
8156     }
8157
8158     dog spot
8159
8160     spot info options
8161 } -cleanup {
8162     dog destroy
8163 } -result {-breed}
8164
8165 test simpledispatch-1.5 {destroy method works with simpledispatch.} -constraints {
8166     snit1
8167 } -body {
8168     type dog {
8169         pragma -simpledispatch yes
8170
8171         option -breed mutt
8172     }
8173
8174     dog spot
8175     set a [info commands ::spot]
8176     spot destroy
8177     set b [info commands ::spot]
8178     list $a $b
8179 } -cleanup {
8180     dog destroy
8181 } -result {::spot {}}
8182
8183 test simpledispatch-1.6 {no hierarchical methods with simpledispatch.} -constraints {
8184     snit1
8185 } -body {
8186     type dog {
8187         pragma -simpledispatch yes
8188
8189         method {wag tail} {} {}
8190     }
8191 } -returnCodes {
8192     error
8193 } -result {type ::dog requests -simpledispatch but defines hierarchical methods.}
8194
8195 #-----------------------------------------------------------------------
8196 # Exotic return codes
8197
8198 test break-1.1 {Methods can "return -code break"} -body {
8199     snit::type dog {
8200         method bark {} {return -code break "Breaking"}
8201     }
8202
8203     dog spot
8204
8205     catch {spot bark} result
8206 } -cleanup {
8207     dog destroy
8208 } -result {3}
8209
8210 test break-1.2 {Typemethods can "return -code break"} -body {
8211     snit::type dog {
8212         typemethod bark {} {return -code break "Breaking"}
8213     }
8214
8215     catch {dog bark} result
8216 } -cleanup {
8217     dog destroy
8218 } -result {3}
8219
8220 test break-1.3 {Methods called via mymethod "return -code break"} -body {
8221     snit::type dog {
8222         method bark {} {return -code break "Breaking"}
8223
8224         method getbark {} {
8225             return [mymethod bark]
8226         }
8227     }
8228
8229     dog spot
8230
8231     catch {uplevel \#0 [spot getbark]} result
8232 } -cleanup {
8233     dog destroy
8234 } -result {3}
8235
8236 #-----------------------------------------------------------------------
8237 # Namespace path
8238
8239 test nspath-1.1 {Typemethods call commands from parent namespace} -constraints {
8240     snit2
8241 } -body {
8242     namespace eval ::snit_test:: {
8243         proc bark {} {return "[namespace current]: Woof"}
8244     }
8245
8246     snit::type ::snit_test::dog {
8247         typemethod bark {} {
8248             bark
8249         }
8250     }
8251
8252     ::snit_test::dog bark
8253 } -cleanup {
8254     ::snit_test::dog destroy
8255     namespace forget ::snit_test
8256 } -result {::snit_test: Woof}
8257
8258 test nspath-1.2 {Methods can call commands from parent namespace} -constraints {
8259     snit2
8260 } -body {
8261     namespace eval ::snit_test:: {
8262         proc bark {} {return "[namespace current]: Woof"}
8263     }
8264
8265     snit::type ::snit_test::dog {
8266         method bark {} {
8267             bark
8268         }
8269     }
8270
8271     ::snit_test::dog spot
8272     spot bark
8273 } -cleanup {
8274     ::snit_test::dog destroy
8275     namespace forget ::snit_test
8276 } -result {::snit_test: Woof}
8277
8278 #-----------------------------------------------------------------------
8279 # snit::boolean
8280
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
8290 } -result {off}
8291
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}
8295
8296 test boolean-2.1 {boolean subtype: valid} -body {
8297     snit::boolean subtype
8298     subtype validate 1
8299     subtype validate 0
8300     subtype validate true
8301     subtype validate false
8302     subtype validate yes
8303     subtype validate no
8304     subtype validate on
8305     subtype validate off
8306 } -cleanup {
8307     subtype destroy
8308 } -result {off}
8309
8310 test boolean-2.2 {boolean subtype: invalid} -body {
8311     snit::boolean subtype
8312     codecatch {subtype validate quux}
8313 } -cleanup {
8314     subtype destroy
8315 } -result {INVALID invalid boolean "quux", should be one of: 1, 0, true, false, yes, no, on, off}
8316
8317 #-----------------------------------------------------------------------
8318 # snit::double
8319
8320 test double-1.1 {double: invalid -min} -body {
8321     snit::double obj -min abc
8322 } -returnCodes {
8323     error
8324 } -result {Error in constructor: invalid -min: "abc"}
8325
8326 test double-1.2 {double: invalid -max} -body {
8327     snit::double obj -max abc
8328 } -returnCodes {
8329     error
8330 } -result {Error in constructor: invalid -max: "abc"}
8331
8332 test double-1.3 {double: invalid, max < min} -body {
8333     snit::double obj -min 5 -max 0
8334 } -returnCodes {
8335     error
8336 } -result {Error in constructor: -max < -min}
8337
8338 test double-2.1 {double type: valid} -body {
8339     snit::double validate 1.5
8340 } -result {1.5}
8341
8342 test double-2.2 {double type: invalid} -body {
8343     codecatch {snit::double validate abc}
8344 } -result {INVALID invalid value "abc", expected double}
8345
8346 test double-3.1 {double subtype: valid, no range} -body {
8347     snit::double subtype
8348     subtype validate 1.5
8349 } -cleanup {
8350     subtype destroy
8351 } -result {1.5}
8352
8353 test double-3.2 {double subtype: valid, min but no max} -body {
8354     snit::double subtype -min 0.5
8355     subtype validate 1
8356 } -cleanup {
8357     subtype destroy
8358 } -result {1}
8359
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
8363 } -cleanup {
8364     subtype destroy
8365 } -result {1.5}
8366
8367 test double-4.1 {double subtype: not a number} -body {
8368     snit::double subtype
8369     codecatch {subtype validate quux}
8370 } -cleanup {
8371     subtype destroy
8372 } -result {INVALID invalid value "quux", expected double}
8373
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}
8377 } -cleanup {
8378     subtype destroy
8379 } -result {INVALID invalid value "-1", expected double no less than 0.5}
8380
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}
8384 } -cleanup {
8385     subtype destroy
8386 } -result {INVALID invalid value "-1", expected double in range 0.5, 5.5}
8387
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}
8391 } -cleanup {
8392     subtype destroy
8393 } -result {INVALID invalid value "1", expected double no greater than 0.5}
8394
8395 #-----------------------------------------------------------------------
8396 # snit::enum
8397
8398 test enum-1.1 {enum: valid} -body {
8399     snit::enum validate foo
8400 } -result {foo}
8401
8402 test enum-2.1 {enum subtype: missing -values} -body {
8403     snit::enum subtype
8404 } -returnCodes {
8405     error
8406 } -result {Error in constructor: invalid -values: ""}
8407
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
8413 } -cleanup {
8414     subtype destroy
8415 } -result {baz}
8416
8417 test enum-3.2 {enum subtype: invalid} -body {
8418     snit::enum subtype -values {foo bar baz}
8419     codecatch {subtype validate quux}
8420 } -cleanup {
8421     subtype destroy
8422 } -result {INVALID invalid value "quux", should be one of: foo, bar, baz}
8423
8424
8425 #-----------------------------------------------------------------------
8426 # snit::fpixels
8427
8428 test fpixels-1.1 {no suffix} -constraints tk -body {
8429     snit::fpixels validate 5
8430 } -result {5}
8431
8432 test fpixels-1.2 {suffix} -constraints tk -body {
8433     snit::fpixels validate 5i
8434 } -result {5i}
8435
8436 test fpixels-1.3 {decimal} -constraints tk -body {
8437     snit::fpixels validate 5.5
8438 } -result {5.5}
8439
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}
8443
8444 test fpixels-2.1 {bad -min} -constraints tk -body {
8445     snit::fpixels subtype -min abc
8446 } -returnCodes {
8447     error
8448 } -result {Error in constructor: invalid -min: "abc"}
8449
8450 test fpixels-2.2 {bad -max} -constraints tk -body {
8451     snit::fpixels subtype -max abc
8452 } -returnCodes {
8453     error
8454 } -result {Error in constructor: invalid -max: "abc"}
8455
8456 test fpixels-2.3 {-min > -max} -constraints tk -body {
8457     snit::fpixels subtype -min 10 -max 5
8458 } -returnCodes {
8459     error
8460 } -result {Error in constructor: -max < -min}
8461
8462 test fpixels-3.1 {subtype, no suffix} -constraints tk -body {
8463     snit::fpixels subtype
8464     subtype validate 5
8465 } -cleanup {
8466     subtype destroy
8467 } -result {5}
8468
8469 test fpixels-3.2 {suffix} -constraints tk -body {
8470     snit::fpixels subtype
8471     subtype validate 5i
8472 } -cleanup {
8473     subtype destroy
8474 } -result {5i}
8475
8476 test fpixels-3.3 {decimal} -constraints tk -body {
8477     snit::fpixels subtype
8478     subtype validate 5.5
8479 } -cleanup {
8480     subtype destroy
8481 } -result {5.5}
8482
8483 test fpixels-3.4 {invalid} -constraints tk -body {
8484     snit::fpixels subtype
8485     codecatch {subtype validate 5.5abc}
8486 } -cleanup {
8487     subtype destroy
8488 } -result {INVALID invalid value "5.5abc", expected fpixels}
8489
8490
8491 test fpixels-3.5 {subtype -min} -constraints tk -body {
8492     snit::fpixels subtype -min 5
8493     subtype validate 10
8494 } -cleanup {
8495     subtype destroy
8496 } -result {10}
8497
8498 test fpixels-3.6 {min of min, max} -constraints tk -body {
8499     snit::fpixels subtype -min 5 -max 20
8500     subtype validate 5
8501 } -cleanup {
8502     subtype destroy
8503 } -result {5}
8504
8505 test fpixels-3.7 {max of min, max} -constraints tk -body {
8506     snit::fpixels subtype -min 5 -max 20
8507     subtype validate 20
8508 } -cleanup {
8509     subtype destroy
8510 } -result {20}
8511
8512 test fpixels-3.8 {middle of min, max} -constraints tk -body {
8513     snit::fpixels subtype -min 5 -max 20
8514     subtype validate 15
8515 } -cleanup {
8516     subtype destroy
8517 } -result {15}
8518
8519 test fpixels-3.9 {invalid, < min} -constraints tk -body {
8520     snit::fpixels subtype -min 5
8521     codecatch {subtype validate 4}
8522 } -cleanup {
8523     subtype destroy
8524 } -result {INVALID invalid value "4", expected fpixels no less than 5}
8525
8526 test fpixels-3.10 {invalid, > max} -constraints tk -body {
8527     snit::fpixels subtype -min 5 -max 20
8528     codecatch {subtype validate 21}
8529 } -cleanup {
8530     subtype destroy
8531 } -result {INVALID invalid value "21", expected fpixels in range 5, 20}
8532
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}
8536 } -cleanup {
8537     subtype destroy
8538 } -result {INVALID invalid value "11i", expected fpixels in range 5i, 10i}
8539
8540 #-----------------------------------------------------------------------
8541 # snit::integer
8542
8543 test integer-1.1 {integer: invalid -min} -body {
8544     snit::integer obj -min abc
8545 } -returnCodes {
8546     error
8547 } -result {Error in constructor: invalid -min: "abc"}
8548
8549 test integer-1.2 {integer: invalid -max} -body {
8550     snit::integer obj -max abc
8551 } -returnCodes {
8552     error
8553 } -result {Error in constructor: invalid -max: "abc"}
8554
8555 test integer-1.3 {integer: invalid, max < min} -body {
8556     snit::integer obj -min 5 -max 0
8557 } -returnCodes {
8558     error
8559 } -result {Error in constructor: -max < -min}
8560
8561 test integer-2.1 {integer type: valid} -body {
8562     snit::integer validate 1
8563 } -result {1}
8564
8565 test integer-2.2 {integer type: invalid} -body {
8566     codecatch {snit::integer validate abc}
8567 } -result {INVALID invalid value "abc", expected integer}
8568
8569 test integer-3.1 {integer subtype: valid, no range} -body {
8570     snit::integer subtype
8571     subtype validate 1
8572 } -cleanup {
8573     subtype destroy
8574 } -result {1}
8575
8576 test integer-3.2 {integer subtype: valid, min but no max} -body {
8577     snit::integer subtype -min 0
8578     subtype validate 1
8579 } -cleanup {
8580     subtype destroy
8581 } -result {1}
8582
8583 test integer-3.3 {integer subtype: valid, min and max} -body {
8584     snit::integer subtype -min 0 -max 10
8585     subtype validate 1
8586 } -cleanup {
8587     subtype destroy
8588 } -result {1}
8589
8590 test integer-4.1 {integer subtype: not a number} -body {
8591     snit::integer subtype
8592     codecatch {subtype validate quux}
8593 } -cleanup {
8594     subtype destroy
8595 } -result {INVALID invalid value "quux", expected integer}
8596
8597 test integer-4.2 {integer subtype: less than min, no max} -body {
8598     snit::integer subtype -min 0
8599     codecatch {subtype validate -1}
8600 } -cleanup {
8601     subtype destroy
8602 } -result {INVALID invalid value "-1", expected integer no less than 0}
8603
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}
8607 } -cleanup {
8608     subtype destroy
8609 } -result {INVALID invalid value "-1", expected integer in range 0, 5}
8610
8611 #-----------------------------------------------------------------------
8612 # snit::listtype
8613
8614 test listtype-1.1 {listtype, length 0; valid} -body {
8615     snit::listtype validate ""
8616 } -result {}
8617
8618 test listtype-1.2 {listtype, length 1; valid} -body {
8619     snit::listtype validate a
8620 } -result {a}
8621
8622 test listtype-1.3 {listtype, length 2; valid} -body {
8623     snit::listtype validate {a b}
8624 } -result {a b}
8625
8626 test listtype-2.1 {listtype subtype, length 0; valid} -body {
8627     snit::listtype subtype
8628     subtype validate ""
8629 } -cleanup {
8630     subtype destroy
8631 } -result {}
8632
8633 test listtype-2.2 {listtype, length 1; valid} -body {
8634     snit::listtype subtype
8635     subtype validate a
8636 } -cleanup {
8637     subtype destroy
8638 } -result {a}
8639
8640 test listtype-2.3 {listtype, length 2; valid} -body {
8641     snit::listtype subtype
8642     subtype validate {a b}
8643 } -cleanup {
8644     subtype destroy
8645 } -result {a b}
8646
8647 test listtype-2.4 {listtype, invalid -minlen} -body {
8648     snit::listtype subtype -minlen abc
8649 } -returnCodes {
8650     error
8651 } -result {Error in constructor: invalid -minlen: "abc"}
8652
8653 test listtype-2.5 {listtype, negative -minlen} -body {
8654     snit::listtype subtype -minlen -1
8655 } -returnCodes {
8656     error
8657 } -result {Error in constructor: invalid -minlen: "-1"}
8658
8659 test listtype-2.6 {listtype, invalid -maxlen} -body {
8660     snit::listtype subtype -maxlen abc
8661 } -returnCodes {
8662     error
8663 } -result {Error in constructor: invalid -maxlen: "abc"}
8664
8665 test listtype-2.7 {listtype, -maxlen < -minlen} -body {
8666     snit::listtype subtype -minlen 10 -maxlen 9
8667 } -returnCodes {
8668     error
8669 } -result {Error in constructor: -maxlen < -minlen}
8670
8671 test listtype-3.1 {-minlen 2, length 2; valid} -body {
8672     snit::listtype subtype -minlen 2
8673     subtype validate {a b}
8674 } -cleanup {
8675     subtype destroy
8676 } -result {a b}
8677
8678 test listtype-3.2 {-minlen 2, length 3; valid} -body {
8679     snit::listtype subtype -minlen 2
8680     subtype validate {a b c}
8681 } -cleanup {
8682     subtype destroy
8683 } -result {a b c}
8684
8685 test listtype-3.3 {-minlen 2, length 1; invalid} -body {
8686     snit::listtype subtype -minlen 2
8687     codecatch {subtype validate a}
8688 } -cleanup {
8689     subtype destroy
8690 } -result {INVALID value has too few elements; at least 2 expected}
8691
8692 test listtype-3.4 {range 1 to 3, length 1; valid} -body {
8693     snit::listtype subtype -minlen 1 -maxlen 3
8694     subtype validate a
8695 } -cleanup {
8696     subtype destroy
8697 } -result {a}
8698
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}
8702 } -cleanup {
8703     subtype destroy
8704 } -result {a b c}
8705
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 {}}
8709 } -cleanup {
8710     subtype destroy
8711 } -result {INVALID value has too few elements; at least 1 expected}
8712
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}}
8716 } -cleanup {
8717     subtype destroy
8718 } -result {INVALID value has too many elements; no more than 3 expected}
8719
8720 test listtype-4.1 {boolean list, valid} -body {
8721     snit::listtype subtype -type snit::boolean
8722     subtype validate {yes 1 true}
8723 } -cleanup {
8724     subtype destroy
8725 } -result {yes 1 true}
8726
8727 test listtype-4.2 {boolean list, invalid} -body {
8728     snit::listtype subtype -type snit::boolean
8729     codecatch {subtype validate {yes 1 abc no}}
8730 } -cleanup {
8731     subtype destroy
8732 } -result {INVALID invalid boolean "abc", should be one of: 1, 0, true, false, yes, no, on, off}
8733
8734 #-----------------------------------------------------------------------
8735 # snit::pixels
8736
8737 test pixels-1.1 {no suffix} -constraints tk -body {
8738     snit::pixels validate 5
8739 } -result {5}
8740
8741 test pixels-1.2 {suffix} -constraints tk -body {
8742     snit::pixels validate 5i
8743 } -result {5i}
8744
8745 test pixels-1.3 {decimal} -constraints tk -body {
8746     snit::pixels validate 5.5
8747 } -result {5.5}
8748
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}
8752
8753 test pixels-2.1 {bad -min} -constraints tk -body {
8754     snit::pixels subtype -min abc
8755 } -returnCodes {
8756     error
8757 } -result {Error in constructor: invalid -min: "abc"}
8758
8759 test pixels-2.2 {bad -max} -constraints tk -body {
8760     snit::pixels subtype -max abc
8761 } -returnCodes {
8762     error
8763 } -result {Error in constructor: invalid -max: "abc"}
8764
8765 test pixels-2.3 {-min > -max} -constraints tk -body {
8766     snit::pixels subtype -min 10 -max 5
8767 } -returnCodes {
8768     error
8769 } -result {Error in constructor: -max < -min}
8770
8771 test pixels-3.1 {subtype, no suffix} -constraints tk -body {
8772     snit::pixels subtype
8773     subtype validate 5
8774 } -cleanup {
8775     subtype destroy
8776 } -result {5}
8777
8778 test pixels-3.2 {suffix} -constraints tk -body {
8779     snit::pixels subtype
8780     subtype validate 5i
8781 } -cleanup {
8782     subtype destroy
8783 } -result {5i}
8784
8785 test pixels-3.3 {decimal} -constraints tk -body {
8786     snit::pixels subtype
8787     subtype validate 5.5
8788 } -cleanup {
8789     subtype destroy
8790 } -result {5.5}
8791
8792 test pixels-3.4 {invalid} -constraints tk -body {
8793     snit::pixels subtype
8794     codecatch {subtype validate 5.5abc}
8795 } -cleanup {
8796     subtype destroy
8797 } -result {INVALID invalid value "5.5abc", expected pixels}
8798
8799
8800 test pixels-3.5 {subtype -min} -constraints tk -body {
8801     snit::pixels subtype -min 5
8802     subtype validate 10
8803 } -cleanup {
8804     subtype destroy
8805 } -result {10}
8806
8807 test pixels-3.6 {min of min, max} -constraints tk -body {
8808     snit::pixels subtype -min 5 -max 20
8809     subtype validate 5
8810 } -cleanup {
8811     subtype destroy
8812 } -result {5}
8813
8814 test pixels-3.7 {max of min, max} -constraints tk -body {
8815     snit::pixels subtype -min 5 -max 20
8816     subtype validate 20
8817 } -cleanup {
8818     subtype destroy
8819 } -result {20}
8820
8821 test pixels-3.8 {middle of min, max} -constraints tk -body {
8822     snit::pixels subtype -min 5 -max 20
8823     subtype validate 15
8824 } -cleanup {
8825     subtype destroy
8826 } -result {15}
8827
8828 test pixels-3.9 {invalid, < min} -constraints tk -body {
8829     snit::pixels subtype -min 5
8830     codecatch {subtype validate 4}
8831 } -cleanup {
8832     subtype destroy
8833 } -result {INVALID invalid value "4", expected pixels no less than 5}
8834
8835 test pixels-3.10 {invalid, > max} -constraints tk -body {
8836     snit::pixels subtype -min 5 -max 20
8837     codecatch {subtype validate 21}
8838 } -cleanup {
8839     subtype destroy
8840 } -result {INVALID invalid value "21", expected pixels in range 5, 20}
8841
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}
8845 } -cleanup {
8846     subtype destroy
8847 } -result {INVALID invalid value "11i", expected pixels in range 5i, 10i}
8848
8849 #-----------------------------------------------------------------------
8850 # snit::stringtype
8851
8852 test stringtype-1.1 {stringtype, valid string} -body {
8853     snit::stringtype validate ""
8854 } -result {}
8855
8856 test stringtype-2.1 {stringtype subtype: invalid -regexp} -body {
8857     snit::stringtype subtype -regexp "\[A-Z"
8858 } -returnCodes {
8859     error
8860 } -result {Error in constructor: invalid -regexp: "[A-Z"}
8861
8862 test stringtype-2.2 {stringtype subtype: invalid -minlen} -body {
8863     snit::stringtype subtype -minlen foo
8864 } -returnCodes {
8865     error
8866 } -result {Error in constructor: invalid -minlen: "foo"}
8867
8868 test stringtype-2.3 {stringtype subtype: invalid -maxlen} -body {
8869     snit::stringtype subtype -maxlen foo
8870 } -returnCodes {
8871     error
8872 } -result {Error in constructor: invalid -maxlen: "foo"}
8873
8874 test stringtype-2.4 {stringtype subtype: -maxlen < -minlen} -body {
8875     snit::stringtype subtype -maxlen 1 -minlen 5
8876 } -returnCodes {
8877     error
8878 } -result {Error in constructor: -maxlen < -minlen}
8879
8880 test stringtype-2.5 {stringtype subtype: -minlen < 0} -body {
8881     snit::stringtype subtype -minlen -1
8882 } -returnCodes {
8883     error
8884 } -result {Error in constructor: invalid -minlen: "-1"}
8885
8886 test stringtype-2.6 {stringtype subtype: -maxlen < 0} -body {
8887     snit::stringtype subtype -maxlen -1
8888 } -returnCodes {
8889     error
8890 } -result {Error in constructor: -maxlen < -minlen}
8891
8892 test stringtype-3.1 {stringtype subtype: -glob, valid} -body {
8893     snit::stringtype subtype -glob "*FOO*"
8894     subtype validate 1FOO2
8895 } -cleanup {
8896     subtype destroy
8897 } -result {1FOO2}
8898
8899 test stringtype-3.2 {stringtype subtype: -glob, case-insensitive} -body {
8900     snit::stringtype subtype -nocase yes -glob "*FOO*"
8901     subtype validate 1foo2
8902 } -cleanup {
8903     subtype destroy
8904 } -result {1foo2}
8905
8906 test stringtype-3.3 {stringtype subtype: -glob invalid, case-sensitive} -body {
8907     snit::stringtype subtype -glob "*FOO*"
8908     codecatch {subtype validate 1foo2}
8909 } -cleanup {
8910     subtype destroy
8911 } -result {INVALID invalid value "1foo2"}
8912
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}
8916 } -cleanup {
8917     subtype destroy
8918 } -result {INVALID invalid value "bar"}
8919
8920 test stringtype-5.5 {stringtype subtype: -regexp valid, case-sensitive} -body {
8921     snit::stringtype subtype -regexp {^[A-Z]+$}
8922     subtype validate FOO
8923 } -cleanup {
8924     subtype destroy
8925 } -result {FOO}
8926
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
8930 } -cleanup {
8931     subtype destroy
8932 } -result {foo}
8933
8934 test stringtype-5.7 {stringtype subtype: -regexp invalid, case-sensitive} -body {
8935     snit::stringtype subtype -regexp {^[A-Z]+$}
8936     codecatch {subtype validate foo}
8937 } -cleanup {
8938     subtype destroy
8939 } -result {INVALID invalid value "foo"}
8940
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}
8944 } -cleanup {
8945     subtype destroy
8946 } -result {INVALID invalid value "foo1"}
8947
8948 #-----------------------------------------------------------------------
8949 # snit::window
8950
8951 test window-1.1 {window: valid} -constraints tk -body {
8952     snit::window validate .
8953 } -result {.}
8954
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}
8958
8959 test window-2.1 {window subtype: valid} -constraints tk -body {
8960     snit::window subtype
8961     subtype validate .
8962 } -cleanup {
8963     subtype destroy
8964 } -result {.}
8965
8966 test window-2.2 {window subtype: invalid} -constraints tk -body {
8967     snit::window subtype
8968     codecatch {subtype validate .nonesuch}
8969 } -cleanup {
8970     subtype destroy
8971 } -result {INVALID invalid value ".nonesuch", value is not a window}
8972
8973 #-----------------------------------------------------------------------
8974 # option -type specifications
8975
8976 test optiontype-1.1 {-type is type object name} -body {
8977     type dog {
8978         option -akcflag -default no -type snit::boolean
8979     }
8980
8981     dog create spot
8982
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
8988
8989     # Set -akcflag to an invalid value
8990     spot configure -akcflag offf
8991 } -returnCodes {
8992     error
8993 } -cleanup {
8994     dog destroy
8995 } -result {invalid -akcflag value: invalid boolean "offf", should be one of: 1, 0, true, false, yes, no, on, off}
8996
8997 test optiontype-1.2 {-type is type specification} -body {
8998     type dog {
8999         option -color -default brown \
9000             -type {snit::enum -values {brown black white golden}}
9001     }
9002
9003     dog create spot
9004
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
9010
9011     # Set -color to an invalid value
9012     spot configure -color green
9013 } -returnCodes {
9014     error
9015 } -cleanup {
9016     dog destroy
9017 } -result {invalid -color value: invalid value "green", should be one of: brown, black, white, golden}
9018
9019 test optiontype-1.3 {-type catches invalid defaults} -body {
9020     type dog {
9021         option -color -default green \
9022             -type {snit::enum -values {brown black white golden}}
9023     }
9024
9025     dog spot
9026 } -returnCodes {
9027     error
9028 } -cleanup {
9029     dog destroy
9030 } -result {Error in constructor: invalid -color default: invalid value "green", should be one of: brown, black, white, golden}
9031
9032
9033 #-----------------------------------------------------------------------
9034 # Bug Fixes
9035
9036 test bug-1.1 {Bug 1161779: destructor can't precede constructor} -body {
9037     type dummy {
9038         destructor {
9039             # No content
9040         }
9041
9042         constructor {args} {
9043             $self configurelist $args
9044         }
9045
9046     }
9047 } -cleanup {
9048     rename ::dummy ""
9049 } -result ::dummy
9050
9051 test bug-2.1 {Bug 1106375: Widget Error on failed object's construction} -constraints {
9052     tk
9053 } -body {
9054     ::snit::widgetadaptor mylabel {
9055         delegate method * to hull
9056         delegate option * to hull
9057
9058         constructor {args} {
9059             installhull using label
9060             error "simulated error"
9061         }
9062     }
9063
9064     catch {mylabel .lab} result
9065     list [info commands .lab] $result
9066
9067 } -cleanup {
9068     ::mylabel destroy
9069 } -result {{} {Error in constructor: simulated error}}
9070
9071 test bug-2.2 {Bug 1106375: Widget Error on failed object's construction} -constraints {
9072     tk
9073 } -body {
9074     ::snit::widget myframe {
9075         delegate method * to hull
9076         delegate option * to hull
9077
9078         constructor {args} {
9079             error "simulated error"
9080         }
9081     }
9082
9083     catch {myframe .frm} result
9084     list [info commands .frm] $result
9085  } -cleanup {
9086     ::myframe destroy
9087 } -result {{} {Error in constructor: simulated error}}
9088
9089 test bug-3.1 {Bug 1532791: snit2, snit::widget problem} -constraints {
9090     tk
9091 } -body {
9092     snit::widget mywidget {
9093         delegate method * to mylabel
9094         delegate option * to mylabel
9095
9096         variable mylabel {}
9097     }
9098
9099     mywidget .mylabel
9100 } -cleanup {
9101     destroy .mylabel
9102 } -result {.mylabel}
9103
9104
9105 #---------------------------------------------------------------------
9106 # Clean up
9107
9108 rename expect {}
9109 testsuiteCleanup