# -*- tcl -*-
#---------------------------------------------------------------------
# TITLE:
#	snit.test
#
# AUTHOR:
#	Will Duquette
#
# DESCRIPTION:
#	Test cases for snit.tcl.  Uses the ::tcltest:: harness.
#
#       If Tcl is 8.5, Snit 2.0 is loaded.
#       If Tcl is 8.4, Snit 1.2 is loaded.
#       If Tcl is 8.3, Snit 1.2 is loaded. (Kenneth Green's backport).
#
#    Tests back-ported to Tcl 8.3 for snit 1.2 backport by kmg
#    Backport of test made general by Andreas Kupries.
#
#    The tests assume tcltest 2.2

#-----------------------------------------------------------------------
# Back-port to Tcl8.3 by Kenneth Green (kmg)
#
# Global changes:
#  " eq " => "string equal"
#  " ne " -> "!string equal"
#-----------------------------------------------------------------------

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

testsNeedTcl     8.3
testsNeedTcltest 2.2

#---------------------------------------------------------------------
# Set up a number of constraints. This also determines which
# implementation of snit is loaded and tested.

# WHD: Work around bugs in 8.5a3
tcltest::testConstraint bug8.5a3 [expr {![string equal [info patchlevel] "8.5a3"]}]

# Marks tests which are only for Tk.
tcltest::testConstraint tk [info exists tk_version]

# If Tk is available, require BWidget
tcltest::testConstraint bwidget [expr {
    [tcltest::testConstraint tk] &&
    ![catch {package require BWidget}]
}]

# Determine which Snit version to load.  If Tcl 8.5, use 2.x.
# Otherwise, use 1.x. (Different variants depending on 8.3 vs 8.4)
if {[package vsatisfies [package present Tcl] 8.5]} {
    set snitVersion 2
    set snitFile snit2.tcl
} else {
    set snitVersion 1
    set snitFile snit.tcl
}

# Marks tests which are only for Snit 1
tcltest::testConstraint snit1 [expr {$snitVersion == 1}]

# Marks tests which are only for Snit 2
tcltest::testConstraint snit2 [expr {$snitVersion == 2}]

# Marks tests which are only for Snit 1 with Tcl 8.3
tcltest::testConstraint tcl83 [string equal [info tclversion] "8.3"]
tcltest::testConstraint tcl84 [package vsatisfies [package present Tcl] 8.4]

if {[package vsatisfies [package provide Tcl] 8.6]} {
    # 8.6+
    proc expect {six default} { return $six }
} else {
    # 8.4/8.5
    proc expect {six default} { return $default }
}

#---------------------------------------------------------------------
# Load the snit package.

testing {
    useLocal $snitFile snit
}

#---------------------------------------------------------------------

namespace import ::snit::*

# Set up for Tk tests: Repeat background errors
proc bgerror {msg} {
    global errorInfo
    set ::bideError $msg
    set ::bideErrorInfo $errorInfo
}

# Set up for Tk tests: enter the event loop long enough to catch
# any bgerrors.
proc tkbide {{msg "tkbide"} {msec 500}} {
    set ::bideVar 0
    set ::bideError ""
    set ::bideErrorInfo ""
    # It looks like update idletasks does the job.
    if {0} {
        after $msec {set ::bideVar 1}
        tkwait variable ::bideVar
    }
    update idletasks
    if {"" != $::bideError} {
        error "$msg: $::bideError" $::bideErrorInfo
    }
}

# cleanup type
proc cleanupType {name} {
    if {[namespace exists $name]} {
        if {[catch {$name destroy} result]} {
            global errorInfo
            puts $errorInfo
            error "Could not cleanup $name!"
        }
    }
    tkbide "cleanupType $name"
}

# cleanup before each test
proc cleanup {} {
    global errorInfo

    cleanupType ::dog
    cleanupType ::cat
    cleanupType ::mylabel
    cleanupType ::myframe
    cleanupType ::foo
    cleanupType ::bar
    cleanupType ::tail
    cleanupType ::papers
    cleanupType ::animal
    cleanupType ::confused-dog
    catch {option clear}

    if {![string equal [info commands "spot"] ""]} {
        puts "spot not erased!"
        error "spot not erased!"
    }

    if {![string equal [info commands "fido"] ""]} {
        puts "fido not erased!"
        error "fido not erased!"
    }
}

# catch error code and error

proc codecatch {command} {
    if {![catch {uplevel 1 $command} result]} {
	error "expected error, got OK"
    }

    return "$::errorCode $result"
}


#-----------------------------------------------------------------------
# Internals: tests for Snit utility functions

test Expand-1.1 {template, no arguments} -body {
    snit::Expand "My %TEMPLATE%"
} -result {My %TEMPLATE%}

test Expand-1.2 {template, no matching arguments} -body {
    snit::Expand "My %TEMPLATE%" %FOO% foo
} -result {My %TEMPLATE%}

test Expand-1.3 {template with matching arguments} -body {
    snit::Expand "%FOO% %BAR% %FOO%" %FOO% bar %BAR% foo
} -result {bar foo bar}

test Expand-1.4 {template with odd number of arguments} -body {
    snit::Expand "%FOO% %BAR% %FOO%" %FOO%
} -result {char map list unbalanced} -returnCodes error

test Mappend-1.1 {template, no arguments} -body {
    set text "Prefix: "
    snit::Mappend text "My %TEMPLATE%"
} -cleanup {
    unset text
} -result {Prefix: My %TEMPLATE%}

test Mappend-1.2 {template, no matching arguments} -body {
    set text "Prefix: "
    snit::Mappend text "My %TEMPLATE%" %FOO% foo
} -cleanup {
    unset text
} -result {Prefix: My %TEMPLATE%}

test Mappend-1.3 {template with matching arguments} -body {
    set text "Prefix: "
    snit::Mappend text "%FOO% %BAR% %FOO%" %FOO% bar %BAR% foo
} -cleanup {
    unset text
} -result {Prefix: bar foo bar}

test Mappend-1.4 {template with odd number of arguments} -body {
    set text "Prefix: "
    snit::Mappend text "%FOO% %BAR% %FOO%" %FOO%
} -cleanup {
    unset text
} -returnCodes error -result {char map list unbalanced}

test RT.UniqueName-1.1 {no name collision} -body {
    set counter 0

    # Standard qualified type name.
    set n1 [snit::RT.UniqueName counter ::mytype ::my::%AUTO%]

    # Standard qualified widget name.
    set n2 [snit::RT.UniqueName counter ::mytype .my.%AUTO%]

    list $n1 $n2
} -result {::my::mytype1 .my.mytype2} -cleanup {
    unset counter n1 n2
}

test RT.UniqueName-1.2 {name collision} -body {
    set counter 0

    # Create the first two equivalent procs.
    proc ::mytype1 {} {}
    proc ::mytype2 {} {}

    # Create a new name; it should skip to 3.
    snit::RT.UniqueName counter ::mytype ::%AUTO%
} -cleanup {
    unset counter
    rename ::mytype1 ""
    rename ::mytype2 ""
} -result {::mytype3}

test RT.UniqueName-1.3 {nested type name} -body {
    set counter 0

    snit::RT.UniqueName counter ::thisis::yourtype ::your::%AUTO%
} -cleanup {
    unset counter
} -result {::your::yourtype1}

test RT.UniqueInstanceNamespace-1.1 {no name collision} -setup {
    namespace eval ::mytype:: {}
} -body {
    set counter 0
    snit::RT.UniqueInstanceNamespace counter ::mytype
} -cleanup {
    unset counter
    namespace delete ::mytype::
} -result {::mytype::Snit_inst1}

test RT.UniqueInstanceNamespace-1.2 {name collision} -setup {
    namespace eval ::mytype:: {}
    namespace eval ::mytype::Snit_inst1:: {}
    namespace eval ::mytype::Snit_inst2:: {}
} -body {
    set counter 0

    # Should skip to 3.
    snit::RT.UniqueInstanceNamespace counter ::mytype
} -cleanup {
    unset counter
    namespace delete ::mytype::
} -result {::mytype::Snit_inst3}

test Contains-1.1 {contains element} -constraints {
    snit1
} -setup {
    set mylist {foo bar baz}
} -body {
    snit::Contains baz $mylist
} -cleanup {
    unset mylist
} -result {1}

test Contains-1.2 {does not contain element} -constraints {
    snit1
} -setup {
    set mylist {foo bar baz}
} -body {
    snit::Contains quux $mylist
} -cleanup {
    unset mylist
} -result {0}

#-----------------------------------------------------------------------
# type compilation

# snit::compile returns two values, the qualified type name
# and the script to execute to define the type.  This section
# only checks the length of the list and the type name;
# the content of the script is validated by the remainder
# of this test suite.

test compile-1.1 {compile returns qualified type} -body {
    set compResult [compile type dog { }]

    list [llength $compResult] [lindex $compResult 0]
} -result {2 ::dog}

#-----------------------------------------------------------------------
# type destruction

test typedestruction-1.1 {type command is deleted} -body {
    type dog { }
    dog destroy
    info command ::dog
} -result {}

test typedestruction-1.2 {instance commands are deleted} -body {
    type dog { }

    dog create spot
    dog destroy
    info command ::spot
} -result {}

test typedestruction-1.3 {type namespace is deleted} -body {
    type dog { }
    dog destroy
    namespace exists ::dog
} -result {0}

test typedestruction-1.4 {type proc is destroyed on error} -body {
    catch {type dog {
        error "Error creating dog"
    }} result

    list [namespace exists ::dog] [info command ::dog]
} -result {0 {}}

test typedestruction-1.5 {unrelated namespaces are deleted, bug 2898640} -body {
    type dog {}
    namespace eval dog::unrelated {}
    dog destroy
} -result {}

#-----------------------------------------------------------------------
# type and typemethods

test type-1.1 {type names get qualified} -body {
    type dog {}
} -cleanup {
    dog destroy
} -result {::dog}

test type-1.2 {typemethods can be defined} -body {
    type dog {
        typemethod foo {a b} {
            return [list $a $b]
        }
    }

    dog foo 1 2
} -cleanup {
    dog destroy
} -result {1 2}

test type-1.3 {upvar works in typemethods} -body {
    type dog {
        typemethod goodname {varname} {
            upvar $varname myvar
            set myvar spot
        }
    }

    set thename fido
    dog goodname thename
    set thename
} -cleanup {
    dog destroy
    unset thename
} -result {spot}

test type-1.4 {typemethod args can't include type} -body {
    type dog {
        typemethod foo {a type b} { }
    }
} -returnCodes error -result {typemethod foo's arglist may not contain "type" explicitly}

test type-1.5 {typemethod args can't include self} -body {
    type dog {
        typemethod foo {a self b} { }
    }
} -returnCodes error -result {typemethod foo's arglist may not contain "self" explicitly}

test type-1.6 {typemethod args can span multiple lines} -body {
    # This case caused an error at definition time in 0.9 because the
    # arguments were included in a comment in the compile script, and
    # the subsequent lines weren't commented.
    type dog {
        typemethod foo {
            a
            b
        } { }
    }
} -cleanup {
    dog destroy
} -result {::dog}


#-----------------------------------------------------------------------
# typeconstructor

test typeconstructor-1.1 {a typeconstructor can be defined} -body {
    type dog {
        typevariable a

        typeconstructor {
            set a 1
        }

        typemethod aget {} {
            return $a
        }
    }

    dog aget
} -cleanup {
    dog destroy
} -result {1}

test typeconstructor-1.2 {only one typeconstructor can be defined} -body {
    type dog {
        typevariable a

        typeconstructor {
            set a 1
        }

        typeconstructor {
            set a 2
        }
    }
} -returnCodes error -result {too many typeconstructors}

test typeconstructor-1.3 {type proc is destroyed on error} -body {
    catch {
        type dog {
            typeconstructor {
                error "Error creating dog"
            }
        }
    } result

    list [namespace exists ::dog] [info command ::dog]
} -result {0 {}}

#-----------------------------------------------------------------------
# Type components

test typecomponent-1.1 {typecomponent defines typevariable} -body {
    type dog {
        typecomponent mycomp

        typemethod test {} {
            return $mycomp
        }
    }

    dog test
} -cleanup {
    dog destroy
} -result {}

test typecomponent-1.2 {typecomponent trace executes} -body {
    type dog {
        typecomponent mycomp

        typemethod test {} {
            typevariable Snit_typecomponents
            set mycomp foo
            return $Snit_typecomponents(mycomp)
        }
    }

    dog test
} -cleanup {
    dog destroy
} -result {foo}

test typecomponent-1.3 {typecomponent -public works} -body {
    type dog {
        typecomponent mycomp -public string

        typeconstructor {
            set mycomp string
        }
    }

    dog string length foo
} -cleanup {
    dog destroy
} -result {3}

test typecomponent-1.4 {typecomponent -inherit yes} -body {
    type dog {
        typecomponent mycomp -inherit yes

        typeconstructor {
            set mycomp string
        }
    }

    dog length foo
} -cleanup {
    dog destroy
} -result {3}


#-----------------------------------------------------------------------
# hierarchical type methods

test htypemethod-1.1 {hierarchical method, two tokens} -body {
    type dog {
        typemethod {wag tail} {} {
            return "wags tail"
        }
    }

    dog wag tail
} -cleanup {
    dog destroy
} -result {wags tail}

test htypemethod-1.2 {hierarchical method, three tokens} -body {
    type dog {
        typemethod {wag tail proudly} {} {
            return "wags tail proudly"
        }
    }

    dog wag tail proudly
} -cleanup {
    dog destroy
} -result {wags tail proudly}

test htypemethod-1.3 {hierarchical method, four tokens} -body {
    type dog {
        typemethod {wag tail really high} {} {
            return "wags tail really high"
        }
    }

    dog wag tail really high
} -cleanup {
    dog destroy
} -result {wags tail really high}

test htypemethod-1.4 {redefinition is OK} -body {
    type dog {
        typemethod {wag tail} {} {
            return "wags tail"
        }
        typemethod {wag tail} {} {
            return "wags tail briskly"
        }
    }

    dog wag tail
} -cleanup {
    dog destroy
} -result {wags tail briskly}

# Case 1
test htypemethod-1.5 {proper error on missing submethod} -constraints {
    snit1
} -body {
    cleanup

    type dog {
        typemethod {wag tail} {} { }
    }

    dog wag
} -returnCodes {
    error
}  -cleanup {
    dog destroy
} -result {wrong number args: should be "::dog wag method args"}

# Case 2
test htypemethod-1.6 {proper error on missing submethod} -constraints {
    snit2
} -body {
    cleanup

    type dog {
        typemethod {wag tail} {} { }
    }

    dog wag
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result [expect \
	       {wrong # args: should be "dog wag subcommand ?arg ...?"} \
	       {wrong # args: should be "dog wag subcommand ?argument ...?"}]

# Case 1
test htypemethod-1.7 {proper error on bogus submethod} -constraints {
    snit1
} -body {
    cleanup

    type dog {
        typemethod {wag tail} {} { }
    }

    dog wag ears
} -returnCodes {
    error
}  -cleanup {
    dog destroy
} -result {"::dog wag ears" is not defined}

# Case 2
test htypemethod-1.8 {proper error on bogus submethod} -constraints {
    snit2
} -body {
    cleanup

    type dog {
        typemethod {wag tail} {} { }
    }

    dog wag ears
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result {unknown subcommand "ears": namespace ::dog does not export any commands}

test htypemethod-2.1 {prefix/method collision, level 1, order 1} -body {
    type dog {
        typemethod wag {} {}
        typemethod {wag tail} {} {}
    }
} -returnCodes {
    error
} -result {Error in "typemethod {wag tail}...", "wag" has no submethods.}

test htypemethod-2.2 {prefix/method collision, level 1, order 2} -body {
    type dog {
        typemethod {wag tail} {} {}
        typemethod wag {} {}
    }
} -returnCodes {
    error
} -result {Error in "typemethod wag...", "wag" has submethods.}

test htypemethod-2.3 {prefix/method collision, level 2, order 1} -body {
    type dog {
        typemethod {wag tail} {} {}
        typemethod {wag tail proudly} {} {}
    }
} -returnCodes {
    error
} -result {Error in "typemethod {wag tail proudly}...", "wag tail" has no submethods.}

test htypemethod-2.4 {prefix/method collision, level 2, order 2} -body {
    type dog {
        typemethod {wag tail proudly} {} {}
        typemethod {wag tail} {} {}
    }
} -returnCodes {
    error
} -result {Error in "typemethod {wag tail}...", "wag tail" has submethods.}

#-----------------------------------------------------------------------
# Typemethod delegation

test dtypemethod-1.1 {delegate typemethod to non-existent component} -body {
    set result ""

    type dog {
        delegate typemethod foo to bar
    }

    dog foo
} -returnCodes {
    error
} -result {::dog delegates typemethod "foo" to undefined typecomponent "bar"}

test dtypemethod-1.2 {delegating to existing typecomponent} -body {
    type dog {
        delegate typemethod length to string

        typeconstructor {
            set string string
        }
    }

    dog length foo
} -cleanup {
    dog destroy
} -result {3}

# Case 1
test dtypemethod-1.3 {delegating to existing typecomponent with error} -constraints {
    snit1
} -body {
    type dog {
        delegate typemethod length to string

        typeconstructor {
            set string string
        }
    }

    dog length foo bar
} -returnCodes {
    error
} -result {wrong # args: should be "string length string"}

# Case 2
test dtypemethod-1.4 {delegating to existing typecomponent with error} -constraints {
    snit2
} -body {
    type dog {
        delegate typemethod length to string

        typeconstructor {
            set string string
        }
    }

    dog length foo bar
} -returnCodes {
    error
} -result {wrong # args: should be "dog length string"}

test dtypemethod-1.5 {delegating unknown typemethods to existing typecomponent} -body {
    type dog {
        delegate typemethod * to string

        typeconstructor {
            set string string
        }
    }

    dog length foo
} -cleanup {
    dog destroy
} -result {3}

# Case 1
test dtypemethod-1.6 {delegating unknown typemethod to existing typecomponent with error} -body {
    type dog {
        delegate typemethod * to stringhandler

        typeconstructor {
            set stringhandler string
        }
    }

    dog foo bar
} -constraints {
    snit1
} -returnCodes {
    error
} -result {bad option "foo": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, tolower, toupper, totitle, trim, trimleft, trimright, wordend, or wordstart}

test dtypemethod-1.6a {delegating unknown typemethod to existing typecomponent with error} -body {
    type dog {
        delegate typemethod * to stringhandler

        typeconstructor {
            set stringhandler string
        }
    }

    dog foo bar
} -constraints {
    snit2
} -returnCodes {
    error
} -result {unknown or ambiguous subcommand "foo": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}

test dtypemethod-1.7 {can't delegate local typemethod: order 1} -body {
    type dog {
        typemethod foo {} {}
        delegate typemethod foo to bar
    }
} -returnCodes {
    error
} -result {Error in "delegate typemethod foo...", "foo" has been defined locally.}

test dtypemethod-1.8 {can't delegate local typemethod: order 2} -body {
    type dog {
        delegate typemethod foo to bar
        typemethod foo {} {}
    }
} -returnCodes {
    error
} -result {Error in "typemethod foo...", "foo" has been delegated}

# Case 1
test dtypemethod-1.9 {excepted methods are caught properly} -constraints {
    snit1
} -body {
    type dog {
        delegate typemethod * to string except {match index}

        typeconstructor {
            set string string
        }
    }

    catch {dog length foo} a
    catch {dog match foo}  b
    catch {dog index foo}  c

    list $a $b $c
} -cleanup {
    dog destroy
} -result {3 {"::dog match" is not defined} {"::dog index" is not defined}}

# Case 2
test dtypemethod-1.10 {excepted methods are caught properly} -constraints {
    snit2
} -body {
    type dog {
        delegate typemethod * to string except {match index}

        typeconstructor {
            set string string
        }
    }

    catch {dog length foo} a
    catch {dog match foo}  b
    catch {dog index foo}  c

    list $a $b $c
} -cleanup {
    dog destroy
} -result {3 {unknown subcommand "match": must be length} {unknown subcommand "index": must be length}}

test dtypemethod-1.11 {as clause can include arguments} -body {
    proc tail {a b} {
        return "<$a $b>"
    }

    type dog {
        delegate typemethod wag to tail as {wag briskly}

        typeconstructor {
            set tail tail
        }
    }

    dog wag
} -cleanup {
    dog destroy
    rename tail ""
} -result {<wag briskly>}

test dtypemethod-2.1 {'using "%c %m"' gets normal behavior} -body {
    type dog {
        delegate typemethod length to string using {%c %m}

        typeconstructor {
            set string string
        }
    }

    dog length foo
} -cleanup {
    dog destroy
} -result {3}

test dtypemethod-2.2 {All relevant 'using' conversions are converted} -body {
    proc echo {args} {
        return $args
    }

    type dog {
        delegate typemethod {tail wag} using {echo %% %t %M %m %j %n %w %s %c}
    }

    dog tail wag
} -cleanup {
    dog destroy
    rename echo ""
} -result {% ::dog {tail wag} wag tail_wag %n %w %s %c}

test dtypemethod-2.3 {"%%" is handled properly} -body {
    proc echo {args} { join $args "|" }

    type dog {
        delegate typemethod wag using {echo %%m %%%m}
    }

    dog wag
} -cleanup {
    dog destroy
    rename echo ""
} -result {%m|%wag}

test dtypemethod-2.4 {Method "*" and "using"} -body {
    proc echo {args} { join $args "|" }

    type dog {
        delegate typemethod * using {echo %m}
    }

    list [dog wag] [dog bark loudly]
} -cleanup {
    dog destroy
    rename echo ""
} -result {wag bark|loudly}

test dtypemethod-3.1 {typecomponent names can be changed dynamically} -body {
    proc echo {args} { join $args "|" }

    type dog {
        delegate typemethod length to mycomp

        typeconstructor {
            set mycomp string
        }

        typemethod switchit {} {
            set mycomp echo
        }
    }

    set a [dog length foo]
    dog switchit
    set b [dog length foo]

    list $a $b
} -cleanup {
    dog destroy
    rename echo ""
} -result {3 length|foo}

test dtypemethod-4.1 {hierarchical typemethod, two tokens} -body {
    type tail {
        method wag {} {return "wags tail"}
    }

    type dog {
        typeconstructor {
            set tail [tail %AUTO%]
        }
        delegate typemethod {wag tail} to tail as wag
    }

    dog wag tail
} -cleanup {
    dog destroy
    tail destroy
} -result {wags tail}

test dtypemethod-4.2 {hierarchical typemethod, three tokens} -body {
    type tail {
        method wag {} {return "wags tail"}
    }

    type dog {
        typeconstructor {
            set tail [tail %AUTO%]
        }
        delegate typemethod {wag tail proudly} to tail as wag
    }

    dog wag tail proudly
} -cleanup {
    dog destroy
    tail destroy
} -result {wags tail}

test dtypemethod-4.3 {hierarchical typemethod, four tokens} -body {
    type tail {
        method wag {} {return "wags tail"}
    }

    type dog {
        typeconstructor {
            set tail [tail %AUTO%]
        }
        delegate typemethod {wag tail really high} to tail as wag
    }

    dog wag tail really high
} -cleanup {
    dog destroy
    tail destroy
} -result {wags tail}

test dtypemethod-4.4 {redefinition is OK} -body {
    type tail {
        method {wag tail}    {} {return "wags tail"}
        method {wag briskly} {} {return "wags tail briskly"}
    }

    type dog {
        typeconstructor {
            set tail [tail %AUTO%]
        }
        delegate typemethod {wag tail} to tail as {wag tail}
        delegate typemethod {wag tail} to tail as {wag briskly}
    }

    dog wag tail
} -cleanup {
    dog destroy
    tail destroy
} -result {wags tail briskly}

test dtypemethod-4.5 {last token is used by default} -body {
    type tail {
        method wag {} {return "wags tail"}
    }

    type dog {
        typeconstructor {
            set tail [tail %AUTO%]
        }
        delegate typemethod {tail wag} to tail
    }

    dog tail wag
} -cleanup {
    dog destroy
    tail destroy
} -result {wags tail}

test dtypemethod-4.6 {last token can be *} -body {
    type tail {
        method wag {} {return "wags"}
        method droop {} {return "droops"}
    }

    type dog {
        typeconstructor {
            set tail [tail %AUTO%]
        }
        delegate typemethod {tail *} to tail
    }

    list [dog tail wag] [dog tail droop]
} -cleanup {
    dog destroy
    tail destroy
} -result {wags droops}

# Case 2
test dtypemethod-4.7 {except with multiple tokens} -constraints {
    snit1
} -body {
    type tail {
        method wag {} {return "wags"}
        method droop {} {return "droops"}
    }

    type dog {
        typeconstructor {
            set tail [tail %AUTO%]
        }
        delegate typemethod {tail *} to tail except droop
    }

    catch {dog tail droop} result

    list [dog tail wag] $result
} -cleanup {
    dog destroy
    tail destroy
} -result {wags {"::dog tail droop" is not defined}}

# Case 2
test dtypemethod-4.8 {except with multiple tokens} -constraints {
    snit2
} -body {
    type tail {
        method wag {} {return "wags"}
        method droop {} {return "droops"}
    }

    type dog {
        typeconstructor {
            set tail [tail %AUTO%]
        }
        delegate typemethod {tail *} to tail except droop
    }

    catch {dog tail droop} result

    list [dog tail wag] $result
} -cleanup {
    dog destroy
    tail destroy
} -result {wags {unknown subcommand "droop": namespace ::dog does not export any commands}}

test dtypemethod-4.9 {"*" in the wrong spot} -body {
    type dog {
        delegate typemethod {tail * wag} to tail
    }
} -returnCodes {
    error
} -result {Error in "delegate typemethod {tail * wag}...", "*" must be the last token.}

test dtypemethod-5.1 {prefix/typemethod collision} -body {
    type dog {
        delegate typemethod wag to tail
        delegate typemethod {wag tail} to tail as wag
    }
} -returnCodes {
    error
} -result {Error in "delegate typemethod {wag tail}...", "wag" has no submethods.}

test dtypemethod-5.2 {prefix/typemethod collision} -body {
    type dog {
        delegate typemethod {wag tail} to tail as wag
        delegate typemethod wag to tail
    }
} -returnCodes {
    error
} -result {Error in "delegate typemethod wag...", "wag" has submethods.}

test dtypemethod-5.3 {prefix/typemethod collision} -body {
    type dog {
        delegate typemethod {wag tail} to tail
        delegate typemethod {wag tail proudly} to tail as wag
    }
} -returnCodes {
    error
} -result {Error in "delegate typemethod {wag tail proudly}...", "wag tail" has no submethods.}

test dtypemethod-5.4 {prefix/typemethod collision} -body {
    type dog {
        delegate typemethod {wag tail proudly} to tail as wag
        delegate typemethod {wag tail} to tail
    }
} -returnCodes {
    error
} -result {Error in "delegate typemethod {wag tail}...", "wag tail" has submethods.}

#-----------------------------------------------------------------------
# type creation

test creation-1.1 {type instance names get qualified} -body {
    type dog { }

    dog create spot
} -cleanup {
    dog destroy
} -result {::spot}

test creation-1.2 {type instance names can be generated} -body {
    type dog { }

    dog create my%AUTO%
} -cleanup {
    dog destroy
} -result {::mydog1}

test creation-1.3 {"create" method is optional} -body {
    type dog { }

    dog fido
} -cleanup {
    dog destroy
} -result {::fido}

test creation-1.4 {constructor arg can't be type} -body {
    type dog {
        constructor {type} { }
    }
} -returnCodes {
    error
} -result {constructor's arglist may not contain "type" explicitly}

test creation-1.5 {constructor arg can't be self} -body {
    type dog {
        constructor {self} { }
    }
} -returnCodes {
    error
} -result {constructor's arglist may not contain "self" explicitly}

test creation-1.6 {weird names are OK} -body {
    # I.e., names with non-identifier characters
    type confused-dog {
        method meow {} {
            return "$self meows."
        }
    }

    confused-dog spot
    spot meow
} -cleanup {
    confused-dog destroy
} -result {::spot meows.}

# Case 1
test creation-1.7 {If -hasinstances yes, [$type] == [$type create %AUTO%]} -constraints {
    snit1
} -body {
    type dog {
        variable dummy
    }

    set mydog [dog]
} -cleanup {
    $mydog destroy
    dog destroy
} -result {::dog1}

# Case 2
test creation-1.8 {If -hasinstances yes, [$type] == [$type create %AUTO%]} -constraints {
    snit2
} -body {
    type dog {
        # WHD: In Snit 1.0, this pragma was not needed.
        pragma -hastypemethods no
        variable dummy
    }

    set mydog [dog]
} -cleanup {
    # [dog destroy] doesn't exist
    $mydog destroy
    namespace delete ::dog
} -result {::dog1}

# Case 1
test creation-1.9 {If -hasinstances no, [$type] != [$type create %AUTO%]} -constraints {
    snit1
} -body {
    type dog {
        pragma -hasinstances no
    }

    set mydog [dog]
} -cleanup {
    dog destroy
} -returnCodes {
    error
} -result {wrong # args: should be "::dog method args"}

# Case 2
test creation-1.10 {If -hasinstances no, [$type] != [$type create %AUTO%]} -constraints {
    snit2
} -body {
    type dog {
        pragma -hasinstances no
    }

    set mydog [dog]
} -cleanup {
    dog destroy
} -returnCodes {
    error
} -result [expect \
	       {wrong # args: should be "dog subcommand ?arg ...?"} \
	       {wrong # args: should be "dog subcommand ?argument ...?"}]

# Case 1
test creation-1.11 {If widget, [$type] != [$type create %AUTO%]} -constraints {
    snit1 tk
} -body {
    widget dog {
        variable dummy
    }

    set mydog [dog]
} -cleanup {
    dog destroy
} -returnCodes {
    error
} -result {wrong # args: should be "::dog method args"}

# Case 2
test creation-1.12 {If widget, [$type] != [$type create %AUTO%]} -constraints {
    snit2 tk
} -body {
    widget dog {
        variable dummy
    }

    set mydog [dog]
} -cleanup {
    dog destroy
} -returnCodes {
    error
} -result [expect \
	       {wrong # args: should be "dog subcommand ?arg ...?"} \
	       {wrong # args: should be "dog subcommand ?argument ...?"}]

test creation-1.13 {If -hastypemethods yes, [$type] == [$type create %AUTO%]} -constraints {
    snit1
} -body {
    type dog {
        variable dummy
    }

    set mydog [dog]
} -cleanup {
    dog destroy
} -result {::dog1}

test creation-1.14 {If -hastypemethods yes, [$type] != [$type create %AUTO%]} -constraints {
    snit2
} -body {
    type dog {
        variable dummy
    }

    set mydog [dog]
} -cleanup {
    dog destroy
} -returnCodes {
    error
} -result [expect \
	       {wrong # args: should be "dog subcommand ?arg ...?"} \
	       {wrong # args: should be "dog subcommand ?argument ...?"}]

test creation-2.1 {Can't call "destroy" in constructor} -body {
    type dog {
        constructor {} {
            $self destroy
        }
    }

    dog spot
} -cleanup {
    dog destroy
} -returnCodes {
    error
} -result {Error in constructor: Called 'destroy' method in constructor}

#-----------------------------------------------------------------------
# procs

test proc-1.1 {proc args can span multiple lines} -body {
    # This case caused an error at definition time in 0.9 because the
    # arguments were included in a comment in the compile script, and
    # the subsequent lines weren't commented.
    type dog {
        proc foo {
            a
            b
        } { }
    }
} -cleanup {
    dog destroy
} -result {::dog}


#-----------------------------------------------------------------------
# methods

test method-1.1 {methods get called} -body {
    type dog {
        method bark {} {
            return "$self barks"
        }
    }

    dog create spot
    spot bark
} -cleanup {
    dog destroy
} -result {::spot barks}

test method-1.2 {methods can call other methods} -body {
    type dog {
        method bark {} {
            return "$self barks."
        }

        method chase {quarry} {
            return "$self chases $quarry; [$self bark]"
        }
    }

    dog create spot
    spot chase cat
} -cleanup {
    dog destroy
} -result {::spot chases cat; ::spot barks.}

test method-1.3 {instances can call one another} -body {
    type dog {
        method bark {} {
            return "$self barks."
        }

        method chase {quarry} {
            return "$self chases $quarry; [$quarry bark] [$self bark]"
        }
    }

    dog create spot
    dog create fido
    spot chase ::fido
} -cleanup {
    dog destroy
} -result {::spot chases ::fido; ::fido barks. ::spot barks.}

test method-1.4 {upvar works in methods} -body {
    type dog {
        method goodname {varname} {
            upvar $varname myvar
            set myvar spot
        }
    }

    dog create fido
    set thename fido
    fido goodname thename
    set thename
} -cleanup {
    dog destroy
} -result {spot}

# Case 1
test method-1.5 {unknown methods get an error} -constraints {
    snit1
} -body {
    type dog { }

    dog create spot
    set result ""
    spot chase
} -cleanup {
    dog destroy
} -returnCodes {
    error
} -result {"::spot chase" is not defined}

# Case 2
test method-1.6 {unknown methods get an error} -constraints {
    snit2
} -body {
    type dog { }

    dog create spot
    set result ""
    spot chase
} -cleanup {
    dog destroy
} -returnCodes {
    error
} -result {unknown subcommand "chase": namespace ::dog::Snit_inst1 does not export any commands}

test method-1.7 {info type method returns the object's type} -body {
    type dog { }

    dog create spot
    spot info type
} -cleanup {
    dog destroy
} -result {::dog}

test method-1.8 {instance method can call type method} -body {
    type dog {
        typemethod hello {} {
            return "Hello"
        }
        method helloworld {} {
            return "[$type hello], World!"
        }
    }

    dog create spot
    spot helloworld
} -cleanup {
    dog destroy
} -result {Hello, World!}

test method-1.9 {type methods must be qualified} -body {
    type dog {
        typemethod hello {} {
            return "Hello"
        }
        method helloworld {} {
            return "[hello], World!"
        }
    }

    dog create spot
    spot helloworld
} -cleanup {
    dog destroy
} -returnCodes {
    error
} -result {invalid command name "hello"}

# Case 1
test method-1.10 {too few arguments} -constraints {
    snit1
} -body {
    type dog {
	method bark {volume} { }
    }

    dog create spot
    spot bark
} -cleanup {
    dog destroy
} -returnCodes {
    error
} -result [tcltest::wrongNumArgs ::dog::Snit_methodbark {type selfns win self volume} 4]

# Case 2
test method-1.11 {too few arguments} -constraints {
    snit2
} -body {
    type dog {
        method bark {volume} { }
    }

    dog create spot
    spot bark
} -cleanup {
    dog destroy
} -returnCodes {
    error
} -result {wrong # args: should be "spot bark volume"}

# Case 1
test method-1.12 {too many arguments} -constraints {
    snit1
} -body {
    type dog {
	method bark {volume} { }
    }

    dog create spot

    spot bark really loud
} -returnCodes {
    error
} -result [tcltest::tooManyArgs ::dog::Snit_methodbark {type selfns win self volume}]

# Case 2
test method-1.13 {too many arguments} -constraints {
    snit2
} -body {
    type dog {
        method bark {volume} { }
    }

    dog create spot

    spot bark really loud
} -cleanup {
    dog destroy
} -returnCodes {
    error
} -result {wrong # args: should be "spot bark volume"}

test method-1.14 {method args can't include type} -body {
    type dog {
        method foo {a type b} { }
    }
} -returnCodes {
    error
} -result {method foo's arglist may not contain "type" explicitly}

test method-1.15 {method args can't include self} -body {
    type dog {
        method foo {a self b} { }
    }
} -returnCodes {
    error
} -result {method foo's arglist may not contain "self" explicitly}

test method-1.16 {method args can span multiple lines} -body {
    # This case caused an error at definition time in 0.9 because the
    # arguments were included in a comment in the compile script, and
    # the subsequent lines weren't commented.
    type dog {
        method foo {
                    a
                    b
                } { }
    }
} -cleanup {
    dog destroy
} -result {::dog}

#-----------------------------------------------------------------------
# hierarchical methods

test hmethod-1.1 {hierarchical method, two tokens} -body {
    type dog {
        method {wag tail} {} {
            return "$self wags tail."
        }
    }

    dog spot
    spot wag tail
} -cleanup {
    dog destroy
} -result {::spot wags tail.}

test hmethod-1.2 {hierarchical method, three tokens} -body {
    type dog {
        method {wag tail proudly} {} {
            return "$self wags tail proudly."
        }
    }

    dog spot
    spot wag tail proudly
} -cleanup {
    dog destroy
} -result {::spot wags tail proudly.}

test hmethod-1.3 {hierarchical method, three tokens} -body {
    type dog {
        method {wag tail really high} {} {
            return "$self wags tail really high."
        }
    }

    dog spot
    spot wag tail really high
} -cleanup {
    dog destroy
} -result {::spot wags tail really high.}

test hmethod-1.4 {redefinition is OK} -body {
    type dog {
        method {wag tail} {} {
            return "$self wags tail."
        }
        method {wag tail} {} {
            return "$self wags tail briskly."
        }
    }

    dog spot
    spot wag tail
} -cleanup {
    dog destroy
} -result {::spot wags tail briskly.}

# Case 1
test hmethod-1.5 {proper error on missing submethod} -constraints {
    snit1
} -body {
    type dog {
        method {wag tail} {} { }
    }

    dog spot
    spot wag
} -cleanup {
    dog destroy
} -returnCodes {
    error
} -result {wrong number args: should be "::spot wag method args"}

# Case 2
test hmethod-1.6 {proper error on missing submethod} -constraints {
    snit2
} -body {
    type dog {
        method {wag tail} {} { }
    }

    dog spot
    spot wag
} -cleanup {
    dog destroy
} -returnCodes {
    error
} -result [expect \
	       {wrong # args: should be "spot wag subcommand ?arg ...?"} \
	       {wrong # args: should be "spot wag subcommand ?argument ...?"}]

test hmethod-1.7 {submethods called in proper objects} -body {
    # NOTE: This test was added in response to a bug report by
    # Anton Kovalenko.  In Snit 2.0, submethod ensembles were
    # created in the type namespace.  If a type defines a submethod
    # ensemble, then all objects of that type would end up sharing
    # a single ensemble.  Ensembles are created lazily, so in this
    # test, the first call to "fido this tail wag" and "spot this tail wag"
    # will yield the correct result, but the second call to
    # "fido this tail wag" will yield the same as the call to
    # "spot this tail wag", because spot's submethod ensemble has
    # displaced fido's.  Until the bug is fixed, that is.
    #
    # Fortunately, Anton provided the fix as well.
    type tail {
        option -manner

        method wag {} {
            return "wags tail $options(-manner)"
        }
    }

    type dog {
        delegate option -manner to tail
        delegate method {this tail wag} to tail

        constructor {args} {
            set tail [tail %AUTO%]
            $self configurelist $args
        }
    }

    dog fido -manner briskly
    dog spot -manner slowly

    list [fido this tail wag] [spot this tail wag] [fido this tail wag]
} -cleanup {
    dog destroy
    tail destroy
} -result {{wags tail briskly} {wags tail slowly} {wags tail briskly}}

test hmethod-2.1 {prefix/method collision} -body {
    type dog {
        method wag {} {}
        method {wag tail} {} {
            return "$self wags tail."
        }
    }
} -returnCodes {
    error
} -result {Error in "method {wag tail}...", "wag" has no submethods.}

test hmethod-2.2 {prefix/method collision} -body {
    type dog {
        method {wag tail} {} {
            return "$self wags tail."
        }
        method wag {} {}
    }
} -returnCodes {
    error
} -result {Error in "method wag...", "wag" has submethods.}

test hmethod-2.3 {prefix/method collision} -body {
    type dog {
        method {wag tail} {} {}
        method {wag tail proudly} {} {
            return "$self wags tail."
        }
    }
} -returnCodes {
    error
} -result {Error in "method {wag tail proudly}...", "wag tail" has no submethods.}

test hmethod-2.4 {prefix/method collision} -body {
    type dog {
        method {wag tail proudly} {} {
            return "$self wags tail."
        }
        method {wag tail} {} {}
    }
} -returnCodes {
    error
} -result {Error in "method {wag tail}...", "wag tail" has submethods.}

#-----------------------------------------------------------------------
# mymethod and renaming

test rename-1.1 {mymethod uses name of instance name variable} -body {
    type dog {
        method mymethod {} {
            list [mymethod] [mymethod "A B"] [mymethod A B]
        }
    }

    dog fido
    fido mymethod
} -cleanup {
    dog destroy
} -result {{::snit::RT.CallInstance ::dog::Snit_inst1} {::snit::RT.CallInstance ::dog::Snit_inst1 {A B}} {::snit::RT.CallInstance ::dog::Snit_inst1 A B}}

test rename-1.2 {instances can be renamed} -body {
    type dog {
        method names {} {
            list [mymethod] $selfns $win $self
        }
    }

    dog fido
    set a [fido names]
    rename fido spot
    set b [spot names]

    concat $a $b
} -cleanup {
    dog destroy
} -result {{::snit::RT.CallInstance ::dog::Snit_inst1} ::dog::Snit_inst1 ::fido ::fido {::snit::RT.CallInstance ::dog::Snit_inst1} ::dog::Snit_inst1 ::fido ::spot}

test rename-1.3 {rename to "" deletes an instance} -constraints {
    bug8.5a3
} -body {
    type dog { }

    dog fido
    rename fido ""
    namespace children ::dog
} -cleanup {
    dog destroy
} -result {}

test rename-1.4 {rename to "" deletes an instance even after a rename} -constraints {
    bug8.5a3
} -body {
    type dog { }

    dog fido
    rename fido spot
    rename spot ""
    namespace children ::dog
} -cleanup {
    dog destroy
} -result {}

test rename-1.5 {creating an object twice destroys the first instance} -constraints {
    bug8.5a3
} -body {
    type dog {
        # Can't even test this normally.
        pragma -canreplace yes
    }

    dog fido
    set a [namespace children ::dog]
    dog fido
    set b [namespace children ::dog]
    fido destroy
    set c [namespace children ::dog]

    list $a $b $c
} -cleanup {
    dog destroy
} -result {::dog::Snit_inst1 ::dog::Snit_inst2 {}}

#-----------------------------------------------------------------------
# mymethod actually works

test mymethod-1.1 {run mymethod handler} -body {
    type foo {
	option -command {}
	method runcmd {} {
	    eval [linsert $options(-command) end $self snarf]
	    return
	}
    }
    type bar {
	variable sub
	constructor {args} {
	    set sub [foo fubar -command [mymethod Handler]]
	    return
	}

	method Handler {args} {
	    set ::RES $args
	}

	method test {} {
	    $sub runcmd
	    return
	}
    }

    set ::RES {}
    bar boogle
    boogle test
    set ::RES
} -cleanup {
    bar destroy
    foo destroy
} -result {::bar::fubar snarf}

#-----------------------------------------------------------------------
# myproc

test myproc-1.1 {myproc qualifies proc names} -body {
    type dog {
        proc foo {} {}

        typemethod getit {} {
            return [myproc foo]
        }
    }

    dog getit
} -cleanup {
    dog destroy
} -result {::dog::foo}

test myproc-1.2 {myproc adds arguments} -body {
    type dog {
        proc foo {} {}

        typemethod getit {} {
            return [myproc foo "a b"]
        }
    }

    dog getit
} -cleanup {
    dog destroy
} -result {::dog::foo {a b}}

test myproc-1.3 {myproc adds arguments} -body {
    type dog {
        proc foo {} {}

        typemethod getit {} {
            return [myproc foo "a b" c d]
        }
    }

    dog getit
} -cleanup {
    dog destroy
} -result {::dog::foo {a b} c d}

test myproc-1.4 {procs with selfns work} -body {
    type dog {
        variable datum foo

        method qualify {} {
            return [myproc getdatum $selfns]
        }
        proc getdatum {selfns} {
            return $datum
        }
    }
    dog create spot
    eval [spot qualify]
} -cleanup {
    dog destroy
} -result {foo}


#-----------------------------------------------------------------------
# mytypemethod

test mytypemethod-1.1 {mytypemethod qualifies typemethods} -body {
    type dog {
        typemethod this {} {}

        typemethod a {} {
            return [mytypemethod this]
        }
        typemethod b {} {
            return [mytypemethod this x]
        }
        typemethod c {} {
            return [mytypemethod this "x y"]
        }
        typemethod d {} {
            return [mytypemethod this x y]
        }
    }

    list [dog a] [dog b] [dog c] [dog d]
} -cleanup {
    dog destroy
} -result {{::dog this} {::dog this x} {::dog this {x y}} {::dog this x y}}

#-----------------------------------------------------------------------
# typevariable

test typevariable-1.1 {typevarname qualifies typevariables} -body {
    # Note: typevarname is DEPRECATED.  Real code should use
    # mytypevar instead.
    type dog {
        method tvname {name} {
            typevarname $name
        }
    }

    dog create spot
    spot tvname myvar
} -cleanup {
    dog destroy
} -result {::dog::myvar}

test typevariable-1.2 {undefined typevariables are OK} -body {
    type dog {
        method tset {value} {
            typevariable theValue

            set theValue $value
        }

        method tget {} {
            typevariable theValue

            return $theValue
        }
    }

    dog create spot
    dog create fido
    spot tset Howdy

    list [spot tget] [fido tget] [set ::dog::theValue]
} -cleanup {
    dog destroy
} -result {Howdy Howdy Howdy}

test typevariable-1.3 {predefined typevariables are OK} -body {
    type dog {
        typevariable greeting Hello

        method tget {} {
            return $greeting
        }
    }

    dog create spot
    dog create fido

    list [spot tget] [fido tget] [set ::dog::greeting]
} -cleanup {
    dog destroy
} -result {Hello Hello Hello}

test typevariable-1.4 {typevariables can be arrays} -body {
    type dog {
        typevariable greetings

        method fill {} {
            set greetings(a) Hi
            set greetings(b) Howdy
        }
    }

    dog create spot
    spot fill
    list $::dog::greetings(a) $::dog::greetings(b)
} -cleanup {
    dog destroy
} -result {Hi Howdy}

test typevariable-1.5 {typevariables can used in typemethods} -body {
    type dog {
        typevariable greetings Howdy

        typemethod greet {} {
            return $greetings
        }
    }

    dog greet
} -cleanup {
    dog destroy
} -result {Howdy}

test typevariable-1.6 {typevariables can used in procs} -body {
    type dog {
        typevariable greetings Howdy

        method greet {} {
            return [realGreet]
        }

        proc realGreet {} {
            return $greetings
        }
    }

    dog create spot
    spot greet
} -cleanup {
    dog destroy
} -result {Howdy}

test typevariable-1.7 {mytypevar qualifies typevariables} -body {
    type dog {
        method tvname {name} {
            mytypevar $name
        }
    }

    dog create spot
    spot tvname myvar
} -cleanup {
    dog destroy
} -result {::dog::myvar}

test typevariable-1.8 {typevariable with too many initializers throws an error} -body {
    type dog {
        typevariable color dark brown
    }
} -returnCodes {
    error
} -result {Error in "typevariable color...", too many initializers}

test typevariable-1.9 {typevariable with too many initializers throws an error} -body {
    type dog {
        typevariable color -array dark brown
    }

    set result
} -returnCodes {
    error
} -result {Error in "typevariable color...", too many initializers}

test typevariable-1.10 {typevariable can initialize array variables} -body {
    type dog {
        typevariable data -array {
            family jones
            color brown
        }

        typemethod getdata {item} {
            return $data($item)
        }
    }

    list [dog getdata family] [dog getdata color]
} -cleanup {
    dog destroy
} -result {jones brown}

#-----------------------------------------------------------------------
# instance variable

test ivariable-1.1 {myvar qualifies instance variables} -body {
    type dog {
        method vname {name} {
            myvar $name
        }
    }

    dog create spot
    spot vname somevar
} -cleanup {
    dog destroy
} -result {::dog::Snit_inst1::somevar}

test ivariable-1.2 {undefined instance variables are OK} -body {
    type dog {
        method setgreeting {value} {
            variable greeting

            set greeting $value
        }

        method getgreeting {} {
            variable greeting

            return $greeting
        }
    }

    set spot [dog create spot]
    spot setgreeting Hey

    dog create fido
    fido setgreeting Howdy

    list [spot getgreeting] [fido getgreeting] [set ::dog::Snit_inst1::greeting]
} -cleanup {
    dog destroy
} -result {Hey Howdy Hey}

test ivariable-1.3 {instance variables are destroyed automatically} -body {
    type dog {
        constructor {args} {
            variable greeting

            set greeting Hi
        }
    }

    dog create spot
    set g1 $::dog::Snit_inst1::greeting

    spot destroy
    list $g1 [info exists ::dog::Snit_inst1::greeting]
} -cleanup {
    dog destroy
} -result {Hi 0}

test ivariable-1.4 {defined instance variables need not be declared} -body {
    type dog {
        variable greetings

        method put {} {
            set greetings Howdy
        }

        method get {} {
            return $greetings
        }
    }

    dog create spot
    spot put
    spot get
} -cleanup {
    dog destroy
} -result {Howdy}

test ivariable-1.5 {instance variables can be arrays} -body {
    type dog {
        variable greetings

        method fill {} {
            set greetings(a) Hi
            set greetings(b) Howdy
        }

        method vname {} {
            return [myvar greetings]
        }
    }

    dog create spot
    spot fill
    list [set [spot vname](a)] [set [spot vname](b)]
} -cleanup {
    dog destroy
} -result {Hi Howdy}

test ivariable-1.6 {instance variables can be initialized in the definition} -body {
    type dog {
        variable greetings {Hi Howdy}
        variable empty {}

        method list {} {
            list $greetings $empty
        }
    }

    dog create spot
    spot list
} -cleanup {
    dog destroy
} -result {{Hi Howdy} {}}

test ivariable-1.7 {variable is illegal when selfns is undefined} -body {
    type dog {
        method caller {} {
            callee
        }
        proc callee {} {
            variable foo
        }
    }

    dog create spot

    spot caller
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result {can't read "selfns": no such variable}

test ivariable-1.8 {myvar is illegal when selfns is undefined} -body {
    type dog {
        method caller {} {
            callee
        }
        proc callee {} {
            myvar foo
        }
    }

    dog create spot

    spot caller
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result {can't read "selfns": no such variable}

test ivariable-1.9 {procs which define selfns see instance variables} -body {
    type dog {
        variable greeting Howdy

        method caller {} {
            return [callee $selfns]
        }

        proc callee {selfns} {
            return $greeting
        }
    }

    dog create spot

    spot caller
} -cleanup {
    dog destroy
} -result {Howdy}

test ivariable-1.10 {in methods, variable works with fully qualified names} -body {
    namespace eval ::somenamespace:: {
        set somevar somevalue
    }

    type dog {
        method get {} {
            variable ::somenamespace::somevar
            return $somevar
        }
    }

    dog create spot

    spot get
} -cleanup {
    dog destroy
} -result {somevalue}

test ivariable-1.11 {variable with too many initializers throws an error} -body {
    type dog {
        variable color dark brown
    }
} -returnCodes {
    error
} -result {Error in "variable color...", too many initializers}

test ivariable-1.12 {variable with too many initializers throws an error} -body {
    type dog {
        variable color -array dark brown
    }
} -returnCodes {
    error
} -result {Error in "variable color...", too many initializers}

test ivariable-1.13 {variable can initialize array variables} -body {
    type dog {
        variable data -array {
            family jones
            color brown
        }

        method getdata {item} {
            return $data($item)
        }
    }

    dog spot
    list [spot getdata family] [spot getdata color]
} -cleanup {
    dog destroy
} -result {jones brown}

#-----------------------------------------------------------------------
# codename
#
# NOTE: codename is deprecated; myproc should be used instead.

test codename-1.1 {codename qualifies procs} -body {
    type dog {
        method qualify {} {
            return [codename myproc]
        }
        proc myproc {} { }
    }
    dog create spot
    spot qualify
} -cleanup {
    dog destroy
} -result {::dog::myproc}

test codename-1.2 {procs with selfns work} -body {
    type dog {
        variable datum foo

        method qualify {} {
            return [list [codename getdatum] $selfns]
        }
        proc getdatum {selfns} {
            return $datum
        }
    }
    dog create spot
    eval [spot qualify]
} -cleanup {
    dog destroy
} -result {foo}

#-----------------------------------------------------------------------
# Options

test option-1.1 {options get default values} -body {
    type dog {
        option -color golden
    }

    dog create spot
    spot cget -color
} -cleanup {
    dog destroy
} -result {golden}

test option-1.2 {options can be set} -body {
    type dog {
        option -color golden
    }

    dog create spot
    spot configure -color black
    spot cget -color
} -cleanup {
    dog destroy
} -result {black}

test option-1.3 {multiple options can be set} -body {
    type dog {
        option -color golden
        option -akc 0
    }

    dog create spot
    spot configure -color brown -akc 1
    list [spot cget -color] [spot cget -akc]
} -cleanup {
    dog destroy
} -result {brown 1}

test option-1.4 {options can be retrieved as instance variable} -body {
    type dog {
        option -color golden
        option -akc 0

        method listopts {} {
            list $options(-color) $options(-akc)
        }
    }

    dog create spot
    spot configure -color black -akc 1
    spot listopts
} -cleanup {
    dog destroy
} -result {black 1}

test option-1.5 {options can be set as an instance variable} -body {
    type dog {
        option -color golden
        option -akc 0

        method setopts {} {
            set options(-color) black
            set options(-akc) 1
        }
    }

    dog create spot
    spot setopts
    list [spot cget -color] [spot cget -akc]
} -cleanup {
    dog destroy
} -result {black 1}

test option-1.6 {options can be set at creation time} -body {
    type dog {
        option -color golden
        option -akc 0
    }

    dog create spot -color white -akc 1
    list [spot cget -color] [spot cget -akc]
} -cleanup {
    dog destroy
} -result {white 1}

test option-1.7 {undefined option: cget} -body {
    type dog {
        option -color golden
        option -akc 0
    }

    dog create spot
    spot cget -colour
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result {unknown option "-colour"}

test option-1.8 {undefined option: configure} -body {
    type dog {
        option -color golden
        option -akc 0
    }

    dog create spot
    spot configure -colour blue
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result {unknown option "-colour"}

test option-1.9 {options default to ""} -body {
    type dog {
        option -color
    }

    dog create spot
    spot cget -color
} -cleanup {
    dog destroy
} -result {}

test option-1.10 {spaces allowed in option defaults} -body {
    type dog {
        option -breed "golden retriever"
    }
    dog fido
    fido cget -breed
} -cleanup {
    dog destroy
} -result {golden retriever}

test option-1.11 {brackets allowed in option defaults} -body {
    type dog {
        option -regexp {[a-z]+}
    }

    dog fido
    fido cget -regexp
} -cleanup {
    dog destroy
} -result {[a-z]+}

test option-2.1 {configure returns info, local options only} -body {
    type dog {
        option -color black
        option -akc 1
    }

    dog create spot
    spot configure -color red
    spot configure -akc 0
    spot configure
} -cleanup {
    dog destroy
} -result {{-color color Color black red} {-akc akc Akc 1 0}}

test option-2.2 {configure -opt returns info, local options only} -body {
    type dog {
        option -color black
        option -akc 1
    }

    dog create spot
    spot configure -color red
    spot configure -color
} -cleanup {
    dog destroy
} -result {-color color Color black red}

test option-2.3 {configure -opt returns info, explicit options} -body {
    type papers {
        option -akcflag 1
    }

    type dog {
        option -color black
        delegate option -akc to papers as -akcflag
        constructor {args} {
            set papers [papers create $self.papers]
        }

        destructor {
            catch {$self.papers destroy}
        }
    }

    dog create spot
    spot configure -akc 0
    spot configure -akc
} -cleanup {
    dog destroy
} -result {-akc akc Akc 1 0}

test option-2.4 {configure -unknownopt} -body {
    type papers {
        option -akcflag 1
    }

    type dog {
        option -color black
        delegate option -akc to papers as -akcflag
        constructor {args} {
            set papers [papers create $self.papers]
        }

        destructor {
            catch {$self.papers destroy}
        }
    }

    dog create spot
    spot configure -foo
} -returnCodes {
    error
} -cleanup {
    dog destroy
    papers destroy
} -result {unknown option "-foo"}

test option-2.5 {configure returns info, unknown options} -constraints {
    tk
} -body {
    widgetadaptor myframe {
        option -foo a
        delegate option -width to hull
        delegate option * to hull
        constructor {args} {
            installhull [frame $self]
        }
    }

    myframe .frm
    set a [.frm configure -foo]
    set b [.frm configure -width]
    set c [.frm configure -height]
    destroy .frm
    tkbide

    list $a $b $c

} -cleanup {
    myframe destroy
} -result {{-foo foo Foo a a} {-width width Width 0 0} {-height height Height 0 0}}

test option-2.6 {configure -opt unknown to implicit component} -constraints {
    tk
} -body {
    widgetadaptor myframe {
        delegate option * to hull
        constructor {args} {
            installhull [frame $self]
        }
    }
    myframe .frm
    catch {.frm configure -quux} result
    destroy .frm
    tkbide
    set result
} -cleanup {
    myframe destroy
} -result {unknown option "-quux"}

test option-3.1 {set option resource name explicitly} -body {
    type dog {
        option {-tailcolor tailColor} black
    }

    dog fido

    fido configure -tailcolor
} -cleanup {
    dog destroy
} -result {-tailcolor tailColor TailColor black black}

test option-3.2 {set option class name explicitly} -body {
    type dog {
        option {-tailcolor tailcolor TailColor} black
    }

    dog fido

    fido configure -tailcolor
} -cleanup {
    dog destroy
} -result {-tailcolor tailcolor TailColor black black}

test option-3.3 {delegated option's names come from owner} -body {
    type tail {
        option -color black
    }

    type dog {
        delegate option -tailcolor to tail as -color

        constructor {args} {
            set tail [tail fidotail]
        }
    }

    dog fido

    fido configure -tailcolor
} -cleanup {
    dog destroy
    tail destroy
} -result {-tailcolor tailcolor Tailcolor black black}

test option-3.4 {delegated option's resource name set explicitly} -body {
    type tail {
        option -color black
    }

    type dog {
        delegate option {-tailcolor tailColor} to tail as -color

        constructor {args} {
            set tail [tail fidotail]
        }
    }

    dog fido

    fido configure -tailcolor
} -cleanup {
    dog destroy
    tail destroy
} -result {-tailcolor tailColor TailColor black black}

test option-3.5 {delegated option's class name set explicitly} -body {
    type tail {
        option -color black
    }

    type dog {
        delegate option {-tailcolor tailcolor TailColor} to tail as -color

        constructor {args} {
            set tail [tail fidotail]
        }
    }

    dog fido

    fido configure -tailcolor
} -cleanup {
    dog destroy
    tail destroy
} -result {-tailcolor tailcolor TailColor black black}

test option-3.6 {delegated option's default comes from component} -body {
    type tail {
        option -color black
    }

    type dog {
        delegate option -tailcolor to tail as -color

        constructor {args} {
            set tail [tail fidotail -color red]
        }
    }

    dog fido

    fido configure -tailcolor
} -cleanup {
    dog destroy
    tail destroy
} -result {-tailcolor tailcolor Tailcolor black red}

test option-4.1 {local option name must begin with hyphen} -body {
    type dog {
        option nohyphen
    }
} -returnCodes {
    error
} -result {Error in "option nohyphen...", badly named option "nohyphen"}

test option-4.2 {local option name must be lower case} -body {
    type dog {
        option -Upper
    }
} -returnCodes {
    error
} -result {Error in "option -Upper...", badly named option "-Upper"}

test option-4.3 {local option name may not contain spaces} -body {
    type dog {
        option {"-with space"}
    }
} -returnCodes {
    error
} -result {Error in "option {"-with space"}...", badly named option "-with space"}

test option-4.4 {delegated option name must begin with hyphen} -body {
    type dog {
        delegate option nohyphen to tail
    }
} -returnCodes {
    error
} -result {Error in "delegate option nohyphen...", badly named option "nohyphen"}

test option-4.5 {delegated option name must be lower case} -body {
    type dog {
        delegate option -Upper to tail
    }
} -returnCodes {
    error
} -result {Error in "delegate option -Upper...", badly named option "-Upper"}

test option-4.6 {delegated option name may not contain spaces} -body {
    type dog {
        delegate option {"-with space"} to tail
    }
} -returnCodes {
    error
} -result {Error in "delegate option {"-with space"}...", badly named option "-with space"}

test option-5.1 {local widget options read from option database} -constraints {
    tk
} -body {
    widget dog {
        option -foo a
        option -bar b

        typeconstructor {
            option add *Dog.bar bb
        }
    }

    dog .fido
    set a [.fido cget -foo]
    set b [.fido cget -bar]
    destroy .fido
    tkbide

    list $a $b

} -cleanup {
    dog destroy
} -result {a bb}

test option-5.2 {local option database values available in constructor} -constraints {
    tk
} -body {
    widget dog {
        option -bar b
        variable saveit

        typeconstructor {
            option add *Dog.bar bb
        }

        constructor {args} {
            set saveit $options(-bar)
        }

        method getit {} {
            return $saveit
        }
    }

    dog .fido
    set result [.fido getit]
    destroy .fido
    tkbide

    set result
} -cleanup {
    dog destroy
} -result {bb}

test option-6.1 {if no options, no options variable} -body {
    type dog {
        variable dummy
    }

    dog spot
    spot info vars options
} -cleanup {
    dog destroy
} -result {}

test option-6.2 {if no options, no options methods} -body {
    type dog {
        variable dummy
    }

    dog spot
    spot info methods c*
} -cleanup {
    dog destroy
} -result {}

#-----------------------------------------------------------------------
# onconfigure

test onconfigure-1.1 {invalid onconfigure methods are caught} -body {
    type dog {
        onconfigure -color {value} { }
    }
} -returnCodes {
    error
} -result {onconfigure -color: option "-color" unknown}

test onconfigure-1.2 {onconfigure methods take one argument} -body {
    type dog {
        option -color golden

        onconfigure -color {value badarg} { }
    }
} -returnCodes {
    error
} -result {onconfigure -color handler should have one argument, got "value badarg"}

test onconfigure-1.3 {onconfigure methods work} -body {
    type dog {
        option -color golden

        onconfigure -color {value} {
            set options(-color) "*$value*"
        }
    }

    dog create spot
    spot configure -color brown
    spot cget -color
} -cleanup {
    dog destroy
} -result {*brown*}

test onconfigure-1.4 {onconfigure arg can't be type} -body {
    type dog {
        option -color
        onconfigure -color {type} { }
    }
} -returnCodes {
    error
} -result {onconfigure -color's arglist may not contain "type" explicitly}

test onconfigure-1.5 {onconfigure arg can't be self} -body {
    type dog {
        option -color
        onconfigure -color {self} { }
    }
} -returnCodes {
    error
} -result {onconfigure -color's arglist may not contain "self" explicitly}

#-----------------------------------------------------------------------
# oncget

test oncget-1.1 {invalid oncget methods are caught} -body {
    type dog {
        oncget -color { }
    }
} -returnCodes {
    error
} -result {Error in "oncget -color...", option "-color" unknown}

test oncget-1.2 {oncget methods work} -body {
    cleanup

    type dog {
        option -color golden

        oncget -color {
            return "*$options(-color)*"
        }
    }

    dog create spot
    spot configure -color brown
    spot cget -color
} -cleanup {
    dog destroy
} -result {*brown*}

#-----------------------------------------------------------------------
# constructor


test constructor-1.1 {constructor can do things} -body {
    type dog {
        variable a
        variable b
        constructor {args} {
            set a 1
            set b 2
        }
        method foo {} {
            list $a $b
        }
    }

    dog create spot
    spot foo
} -cleanup {
    dog destroy
} -result {1 2}

test constructor-1.2 {constructor with no configurelist ignores args} -body {
    type dog {
        constructor {args} { }
        option -color golden
        option -akc 0
    }

    dog create spot -color white -akc 1
    list [spot cget -color] [spot cget -akc]
} -cleanup {
    dog destroy
} -result {golden 0}

test constructor-1.3 {constructor with configurelist gets args} -body {
    type dog {
        constructor {args} {
            $self configurelist $args
        }
        option -color golden
        option -akc 0
    }

    dog create spot -color white -akc 1
    list [spot cget -color] [spot cget -akc]
} -cleanup {
    dog destroy
} -result {white 1}

test constructor-1.4 {constructor with specific args} -body {
    type dog {
        option -value ""
        constructor {a b args} {
            set options(-value) [list $a $b $args]
        }
    }

    dog spot retriever golden -akc 1
    spot cget -value
} -cleanup {
    dog destroy
} -result {retriever golden {-akc 1}}

test constructor-1.5 {constructor with list as one list arg} -body {
    type dog {
        option -value ""
        constructor {args} {
            set options(-value) $args
        }
    }

    dog spot {retriever golden}
    spot cget -value
} -cleanup {
    dog destroy
} -result {{retriever golden}}

test constructor-1.6 {default constructor configures options} -body {
    type dog {
        option -color brown
        option -breed mutt
    }

    dog spot -color golden -breed retriever
    list [spot cget -color] [spot cget -breed]
} -cleanup {
    dog destroy
} -result {golden retriever}

test constructor-1.7 {default constructor takes no args if no options} -body {
    type dog {
	variable color
    }

    dog spot -color golden
} -returnCodes {
    error
} -result "Error in constructor: [tcltest::tooManyArgs ::dog::Snit_constructor {type selfns win self}]"

#-----------------------------------------------------------------------
# destroy

test destroy-1.1 {destroy cleans up the instance} -body {
    type dog {
        option -color golden
    }

    set a [namespace children ::dog::]
    dog create spot
    set b [namespace children ::dog::]
    spot destroy
    set c [namespace children ::dog::]
    list $a $b $c [info commands ::dog::spot]
} -cleanup {
    dog destroy
} -result {{} ::dog::Snit_inst1 {} {}}

test destroy-1.2 {incomplete objects are destroyed} -body {
    array unset ::dog::snit_ivars

    type dog {
        option -color golden

        constructor {args} {
            $self configurelist $args

            if {"red" == [$self cget -color]} {
                error "No Red Dogs!"
            }
        }
    }

    catch {dog create spot -color red} result
    set names [array names ::dog::snit_ivars]
    list $result $names [info commands ::dog::spot]
} -cleanup {
    dog destroy
} -result {{Error in constructor: No Red Dogs!} {} {}}

test destroy-1.3 {user-defined destructors are called} -body {
    type dog {
        typevariable flag ""

        constructor {args} {
            set flag "created $self"
        }

        destructor {
            set flag "destroyed $self"
        }

        typemethod getflag {} {
            return $flag
        }
    }

    dog create spot
    set a [dog getflag]
    spot destroy
    list $a [dog getflag]
} -cleanup {
    dog destroy
} -result {{created ::spot} {destroyed ::spot}}

#-----------------------------------------------------------------------
# delegate: general syntax tests

test delegate-1.1 {can only delegate methods or options} -body {
    type dog {
        delegate foo bar to baz
    }
} -returnCodes {
    error
} -result {Error in "delegate foo bar...", "foo"?}

test delegate-1.2 {"to" must appear in the right place} -body {
    type dog {
        delegate method foo from bar
    }
} -returnCodes {
    error
} -result {Error in "delegate method foo...", unknown delegation option "from"}

test delegate-1.3 {"as" must have a target} -body {
    type dog {
        delegate method foo to bar as
    }
} -returnCodes {
    error
} -result {Error in "delegate method foo...", invalid syntax}

test delegate-1.4 {"as" must have a single target} -body {
    type dog {
        delegate method foo to bar as baz quux
    }
} -returnCodes {
    error
} -result {Error in "delegate method foo...", unknown delegation option "quux"}

test delegate-1.5 {"as" doesn't work with "*"} -body {
    type dog {
        delegate method * to hull as foo
    }
} -returnCodes {
    error
} -result {Error in "delegate method *...", cannot specify "as" with "*"}

test delegate-1.6 {"except" must have a target} -body {
    type dog {
        delegate method * to bar except
    }
} -returnCodes {
    error
} -result {Error in "delegate method *...", invalid syntax}

test delegate-1.7 {"except" must have a single target} -body {
    type dog {
        delegate method * to bar except baz quux
    }
} -returnCodes {
    error
} -result {Error in "delegate method *...", unknown delegation option "quux"}

test delegate-1.8 {"except" works only with "*"} -body {
    type dog {
        delegate method foo to hull except bar
    }
} -returnCodes {
    error
} -result {Error in "delegate method foo...", can only specify "except" with "*"}

test delegate-1.9 {only "as" or "except"} -body {
    type dog {
        delegate method foo to bar with quux
    }
} -returnCodes {
    error
} -result {Error in "delegate method foo...", unknown delegation option "with"}


#-----------------------------------------------------------------------
# delegated methods

test dmethod-1.1 {delegate method to non-existent component} -body {
    type dog {
        delegate method foo to bar
    }

    dog create spot
    spot foo
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result {::dog ::spot delegates method "foo" to undefined component "bar"}

test dmethod-1.2 {delegating to existing component} -body {
    type dog {
        constructor {args} {
            set string string
        }

        delegate method length to string
    }

    dog create spot
    spot length foo
} -cleanup {
    dog destroy
} -result {3}

# Case 1
test dmethod-1.3 {delegating to existing component with error} -constraints {
    snit1
} -body {
    type dog {
        constructor {args} {
            set string string
        }

        delegate method length to string
    }

    dog create spot
    spot length foo bar
} -cleanup {
    dog destroy
} -returnCodes {
    error
} -result {wrong # args: should be "string length string"}

# Case 2
test dmethod-1.4 {delegating to existing component with error} -constraints {
    snit2
} -body {
    type dog {
        constructor {args} {
            set string string
        }

        delegate method length to string
    }

    dog create spot
    spot length foo bar
} -cleanup {
    dog destroy
} -returnCodes {
    error
} -result {wrong # args: should be "spot length string"}

test dmethod-1.5 {delegating unknown methods to existing component} -body {
    type dog {
        constructor {args} {
            set string string
        }

        delegate method * to string
    }

    dog create spot
    spot length foo
} -cleanup {
    dog destroy
} -result {3}

test dmethod-1.6 {delegating unknown method to existing component with error} -body {
    type dog {
        constructor {args} {
            set stringhandler string
        }

        delegate method * to stringhandler
    }

    dog create spot
    spot foo bar
} -constraints {
    snit1
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result {bad option "foo": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, tolower, toupper, totitle, trim, trimleft, trimright, wordend, or wordstart}

test dmethod-1.6a {delegating unknown method to existing component with error} -body {
    type dog {
        constructor {args} {
            set stringhandler string
        }

        delegate method * to stringhandler
    }

    dog create spot
    spot foo bar
} -constraints {
    snit2
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result {unknown or ambiguous subcommand "foo": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}

test dmethod-1.7 {can't delegate local method: order 1} -body {
    type cat {
        method foo {} {}
        delegate method foo to hull
    }
} -returnCodes {
    error
} -result {Error in "delegate method foo...", "foo" has been defined locally.}

test dmethod-1.8 {can't delegate local method: order 2} -body {
    type cat {
        delegate method foo to hull
        method foo {} {}
    }
} -returnCodes {
    error
} -result {Error in "method foo...", "foo" has been delegated}

# Case 1
test dmethod-1.9 {excepted methods are caught properly} -constraints {
    snit1
} -body {
    type tail {
        method wag {}    {return "wagged"}
        method flaunt {} {return "flaunted"}
        method tuck {}   {return "tuck"}
    }

    type cat {
        method meow {} {}
        delegate method * to tail except {wag tuck}

        constructor {args} {
            set tail [tail %AUTO%]
        }
    }

    cat fifi

    catch {fifi flaunt} a
    catch {fifi wag}    b
    catch {fifi tuck}   c

    list $a $b $c
} -cleanup {
    cat destroy
    tail destroy
} -result {flaunted {"::fifi wag" is not defined} {"::fifi tuck" is not defined}}

# Case 2
test dmethod-1.10 {excepted methods are caught properly} -constraints {
    snit2
} -body {
    type tail {
        method wag {}    {return "wagged"}
        method flaunt {} {return "flaunted"}
        method tuck {}   {return "tuck"}
    }

    type cat {
        method meow {} {}
        delegate method * to tail except {wag tuck}

        constructor {args} {
            set tail [tail %AUTO%]
        }
    }

    cat fifi

    catch {fifi flaunt} a
    catch {fifi wag}    b
    catch {fifi tuck}   c

    list $a $b $c
} -cleanup {
    cat destroy
    tail destroy
} -result {flaunted {unknown subcommand "wag": must be flaunt} {unknown subcommand "tuck": must be flaunt}}

test dmethod-1.11 {as clause can include arguments} -body {
    type tail {
        method wag {adverb}    {return "wagged $adverb"}
    }

    type dog {
        delegate method wag to tail as {wag briskly}

        constructor {args} {
            set tail [tail %AUTO%]
        }
    }

    dog spot

    spot wag
} -cleanup {
    dog destroy
    tail destroy
} -result {wagged briskly}

test dmethod-2.1 {'using "%c %m"' gets normal behavior} -body {
    type tail {
        method wag {adverb}    {return "wagged $adverb"}
    }

    type dog {
        delegate method wag to tail using {%c %m}

        constructor {args} {
            set tail [tail %AUTO%]
        }
    }

    dog spot

    spot wag briskly
} -cleanup {
    dog destroy
    tail destroy
} -result {wagged briskly}

test dmethod-2.2 {All 'using' conversions are converted} -body {
    proc echo {args} { return $args }

    type dog {
        delegate method {tail wag} using {echo %% %t %M %m %j %n %w %s %c}
    }

    dog spot

    spot tail wag
} -cleanup {
    dog destroy
    rename echo ""
} -result {% ::dog {tail wag} wag tail_wag ::dog::Snit_inst1 ::spot ::spot %c}

test dmethod-2.3 {"%%" is handled properly} -body {
    proc echo {args} { join $args "|" }

    type dog {
        delegate method wag using {echo %%m %%%m}
    }

    dog spot

    spot wag
} -cleanup {
    dog destroy
    rename echo ""
} -result {%m|%wag}

test dmethod-2.4 {Method "*" and "using"} -body {
    proc echo {args} { join $args "|" }

    type dog {
        delegate method * using {echo %m}
    }

    dog spot

    list [spot wag] [spot bark loudly]
} -cleanup {
    dog destroy
    rename echo ""
} -result {wag bark|loudly}


test dmethod-3.1 {component names can be changed dynamically} -body {
    type tail1 {
        method wag {}    {return "wagged"}
    }

    type tail2 {
        method wag {}    {return "drooped"}
    }

    type dog {
        delegate method wag to tail

        constructor {args} {
            set tail [tail1 %AUTO%]
        }

        method switchit {} {
            set tail [tail2 %AUTO%]
        }
    }

    dog fido

    set a [fido wag]
    fido switchit
    set b [fido wag]

    list $a $b
} -cleanup {
    dog destroy
    tail1 destroy
    tail2 destroy
} -result {wagged drooped}

test dmethod-4.1 {hierarchical method, two tokens} -body {
    type tail {
        method wag {} {return "wags tail"}
    }

    type dog {
        constructor {} {
            set tail [tail %AUTO%]
        }
        delegate method {wag tail} to tail as wag
    }

    dog spot
    spot wag tail
} -cleanup {
    dog destroy
    tail destroy
} -result {wags tail}

test dmethod-4.2 {hierarchical method, three tokens} -body {
    type tail {
        method wag {} {return "wags tail"}
    }

    type dog {
        constructor {} {
            set tail [tail %AUTO%]
        }
        delegate method {wag tail proudly} to tail as wag
    }

    dog spot
    spot wag tail proudly
} -cleanup {
    dog destroy
    tail destroy
} -result {wags tail}

test dmethod-4.3 {hierarchical method, three tokens} -body {
    type tail {
        method wag {} {return "wags tail"}
    }

    type dog {
        constructor {} {
            set tail [tail %AUTO%]
        }
        delegate method {wag tail really high} to tail as wag
    }

    dog spot
    spot wag tail really high
} -cleanup {
    dog destroy
    tail destroy
} -result {wags tail}

test dmethod-4.4 {redefinition is OK} -body {
    type tail {
        method {wag tail}    {} {return "wags tail"}
        method {wag briskly} {} {return "wags tail briskly"}
    }

    type dog {
        constructor {} {
            set tail [tail %AUTO%]
        }
        delegate method {wag tail} to tail as {wag tail}
        delegate method {wag tail} to tail as {wag briskly}
    }

    dog spot
    spot wag tail
} -cleanup {
    dog destroy
    tail destroy
} -result {wags tail briskly}

test dmethod-4.5 {all tokens are used by default} -body {
    type tail {
        method wag {} {return "wags tail"}
    }

    type dog {
        constructor {} {
            set tail [tail %AUTO%]
        }
        delegate method {tail wag} to tail
    }

    dog spot
    spot tail wag
} -cleanup {
    dog destroy
    tail destroy
} -result {wags tail}

test dmethod-4.6 {last token can be *} -body {
    type tail {
        method wag {} {return "wags"}
        method droop {} {return "droops"}
    }

    type dog {
        constructor {} {
            set tail [tail %AUTO%]
        }
        delegate method {tail *} to tail
    }

    dog spot

    list [spot tail wag] [spot tail droop]
} -cleanup {
    dog destroy
    tail destroy
} -result {wags droops}

# Case 1
test dmethod-4.7 {except with multiple tokens} -constraints {
    snit1
} -body {
    type tail {
        method wag {} {return "wags"}
        method droop {} {return "droops"}
    }

    type dog {
        constructor {} {
            set tail [tail %AUTO%]
        }
        delegate method {tail *} to tail except droop
    }

    dog spot

    catch {spot tail droop} result

    list [spot tail wag] $result
} -cleanup {
    dog destroy
    tail destroy
} -result {wags {"::spot tail droop" is not defined}}

# Case 2
test dmethod-4.8 {except with multiple tokens} -constraints {
    snit2
} -body {
    type tail {
        method wag {} {return "wags"}
        method droop {} {return "droops"}
    }

    type dog {
        constructor {} {
            set tail [tail %AUTO%]
        }
        delegate method {tail *} to tail except droop
    }

    dog spot

    catch {spot tail droop} result

    list [spot tail wag] $result
} -cleanup {
    dog destroy
    tail destroy
} -result {wags {unknown subcommand "droop": namespace ::dog::Snit_inst1 does not export any commands}}

test dmethod-4.9 {"*" in the wrong spot} -body {
    type dog {
        delegate method {tail * wag} to tail
    }
} -returnCodes {
    error
} -result {Error in "delegate method {tail * wag}...", "*" must be the last token.}

test dmethod-5.1 {prefix/method collision} -body {
    type dog {
        delegate method wag to tail
        delegate method {wag tail} to tail as wag
    }
} -returnCodes {
    error
} -result {Error in "delegate method {wag tail}...", "wag" has no submethods.}

test dmethod-5.2 {prefix/method collision} -body {
    type dog {
        delegate method {wag tail} to tail as wag
        delegate method wag to tail
    }
} -returnCodes {
    error
} -result {Error in "delegate method wag...", "wag" has submethods.}

test dmethod-5.3 {prefix/method collision} -body {
    type dog {
        delegate method {wag tail} to tail
        delegate method {wag tail proudly} to tail as wag
    }
} -returnCodes {
    error
} -result {Error in "delegate method {wag tail proudly}...", "wag tail" has no submethods.}

test dmethod-5.4 {prefix/method collision} -body {
    type dog {
        delegate method {wag tail proudly} to tail as wag
        delegate method {wag tail} to tail
    }
} -returnCodes {
    error
} -result {Error in "delegate method {wag tail}...", "wag tail" has submethods.}

#-----------------------------------------------------------------------
# delegated options

test doption-1.1 {delegate option to non-existent component} -body {
    type dog {
        delegate option -foo to bar
    }

    dog create spot
    spot cget -foo
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result {component "bar" is undefined in ::dog ::spot}

test doption-1.2 {delegating option to existing component: cget} -body {
    type cat {
        option -color "black"
    }

    cat create hershey

    type dog {
        constructor {args} {
            set catthing ::hershey
        }

        delegate option -color to catthing
    }

    dog create spot
    spot cget -color
} -cleanup {
    dog destroy
    cat destroy
} -result {black}

test doption-1.3 {delegating option to existing component: configure} -body {
    type cat {
        option -color "black"
    }

    cat create hershey

    type dog {
        constructor {args} {
            set catthing ::hershey
            $self configurelist $args
        }

        delegate option -color to catthing
    }

    dog create spot -color blue
    list [spot cget -color] [hershey cget -color]
} -cleanup {
    dog destroy
    cat destroy
} -result {blue blue}

test doption-1.4 {delegating unknown options to existing component} -body {
    type cat {
        option -color "black"
    }

    cat create hershey

    type dog {
        constructor {args} {
            set catthing ::hershey

            # Note: must do this after components are defined; this
            # may be a problem.
            $self configurelist $args
        }

        delegate option * to catthing
    }

    dog create spot -color blue
    list [spot cget -color] [hershey cget -color]
} -cleanup {
    dog destroy
    cat destroy
} -result {blue blue}

test doption-1.5 {can't oncget for delegated option} -body {
    type dog {
        delegate option -color to catthing

        oncget -color { }
    }
} -returnCodes {
    error
} -result {Error in "oncget -color...", option "-color" is delegated}

test doption-1.6 {can't onconfigure for delegated option} -body {
    type dog {
        delegate option -color to catthing

        onconfigure -color {value} { }
    }
} -returnCodes {
    error
} -result {onconfigure -color: option "-color" is delegated}

test doption-1.7 {delegating unknown options to existing component: error} -body {
    type cat {
        option -color "black"
    }

    cat create hershey

    type dog {
        constructor {args} {
            set catthing ::hershey
            $self configurelist $args
        }

        delegate option * to catthing
    }

    dog create spot -colour blue
} -returnCodes {
    error
} -cleanup {
    dog destroy
    cat destroy
} -result {Error in constructor: unknown option "-colour"}

test doption-1.8 {can't delegate local option: order 1} -body {
    type cat {
        option -color "black"
        delegate option -color to hull
    }
} -returnCodes {
    error
} -result {Error in "delegate option -color...", "-color" has been defined locally}

test doption-1.9 {can't delegate local option: order 2} -body {
    type cat {
        delegate option -color to hull
        option -color "black"
    }
} -returnCodes {
    error
} -result {Error in "option -color...", cannot define "-color" locally, it has been delegated}

test doption-1.10 {excepted options are caught properly on cget} -body {
    type tail {
        option -a a
        option -b b
        option -c c
    }

    type cat {
        delegate option * to tail except {-b -c}

        constructor {args} {
            set tail [tail %AUTO%]
        }
    }

    cat fifi

    catch {fifi cget -a} a
    catch {fifi cget -b} b
    catch {fifi cget -c} c

    list $a $b $c
} -cleanup {
    cat destroy
    tail destroy
} -result {a {unknown option "-b"} {unknown option "-c"}}

test doption-1.11 {excepted options are caught properly on configurelist} -body {
    type tail {
        option -a a
        option -b b
        option -c c
    }

    type cat {
        delegate option * to tail except {-b -c}

        constructor {args} {
            set tail [tail %AUTO%]
        }
    }

    cat fifi

    catch {fifi configurelist {-a 1}} a
    catch {fifi configurelist {-b 1}} b
    catch {fifi configurelist {-c 1}} c

    list $a $b $c
} -cleanup {
    cat destroy
    tail destroy
} -result {{} {unknown option "-b"} {unknown option "-c"}}

test doption-1.12 {excepted options are caught properly on configure, 1} -body {
    type tail {
        option -a a
        option -b b
        option -c c
    }

    type cat {
        delegate option * to tail except {-b -c}

        constructor {args} {
            set tail [tail %AUTO%]
        }
    }

    cat fifi

    catch {fifi configure -a 1} a
    catch {fifi configure -b 1} b
    catch {fifi configure -c 1} c

    list $a $b $c
} -cleanup {
    cat destroy
    tail destroy
} -result {{} {unknown option "-b"} {unknown option "-c"}}

test doption-1.13 {excepted options are caught properly on configure, 2} -body {
    type tail {
        option -a a
        option -b b
        option -c c
    }

    type cat {
        delegate option * to tail except {-b -c}

        constructor {args} {
            set tail [tail %AUTO%]
        }
    }

    cat fifi

    catch {fifi configure -a} a
    catch {fifi configure -b} b
    catch {fifi configure -c} c

    list $a $b $c
} -cleanup {
    cat destroy
    tail destroy
} -result {{-a a A a a} {unknown option "-b"} {unknown option "-c"}}

test doption-1.14 {configure query skips excepted options} -body {
    type tail {
        option -a a
        option -b b
        option -c c
    }

    type cat {
        option -d d
        delegate option * to tail except {-b -c}

        constructor {args} {
            set tail [tail %AUTO%]
        }
    }

    cat fifi

    fifi configure
} -cleanup {
    cat destroy
    tail destroy
} -result {{-d d D d d} {-a a A a a}}


#-----------------------------------------------------------------------
# from

test from-1.1 {getting default values} -body {
    type dog {
        option -foo FOO
        option -bar BAR

        constructor {args} {
            $self configure -foo  [from args -foo AAA]
            $self configure -bar  [from args -bar]
        }
    }

    dog create spot
    list [spot cget -foo] [spot cget -bar]
} -cleanup {
    dog destroy
} -result {AAA BAR}

test from-1.2 {getting non-default values} -body {
    type dog {
        option -foo FOO
        option -bar BAR
        option -args

        constructor {args} {
            $self configure -foo [from args -foo]
            $self configure -bar [from args -bar]
            $self configure -args $args
        }
    }

    dog create spot -foo quux -baz frobnitz -bar frobozz
    list [spot cget -foo] [spot cget -bar] [spot cget -args]
} -cleanup {
    dog destroy
} -result {quux frobozz {-baz frobnitz}}

#-----------------------------------------------------------------------
# Widgetadaptors

test widgetadaptor-1.1 {creating a widget: hull hijacking} -constraints {
    tk
} -body {
    widgetadaptor mylabel {
        constructor {args} {
            installhull [label $self]
            $self configurelist $args
        }

        delegate method * to hull
        delegate option * to hull
    }

    mylabel create .label -text "My Label"

    set a [.label cget -text]
    set b [hull1.label cget -text]

    destroy .label
    tkbide
    list $a $b
} -cleanup {
    mylabel destroy
} -result {{My Label} {My Label}}

test widgetadaptor-1.2 {destroying a widget with destroy} -constraints {
    tk
} -body {
    widgetadaptor mylabel {
        constructor {} {
            installhull [label $self]
        }
    }

    mylabel create .label
    set a [namespace children ::mylabel]
    destroy .label
    set b [namespace children ::mylabel]
    tkbide
    list $a $b
} -cleanup {
    mylabel destroy
} -result {::mylabel::Snit_inst1 {}}

test widgetadaptor-1.3 {destroying two widgets of the same type with destroy} -constraints {
    tk
} -body {
    widgetadaptor mylabel {
        constructor {} {
            installhull [label $self]
        }
    }

    mylabel create .lab1
    mylabel create .lab2
    set a [namespace children ::mylabel]
    destroy .lab1
    destroy .lab2
    set b [namespace children ::mylabel]
    tkbide
    list $a $b
} -cleanup {
    mylabel destroy
} -result {{::mylabel::Snit_inst1 ::mylabel::Snit_inst2} {}}

test widgetadaptor-1.4 {destroying a widget with rename, then destroy type} -constraints {
    tk bug8.5a3
} -body {
    widgetadaptor mylabel {
        constructor {} {
            installhull [label $self]
        }
    }

    mylabel create .label
    set a [namespace children ::mylabel]
    rename .label ""
    set b [namespace children ::mylabel]

    mylabel destroy
    tkbide
    list $a $b
} -result {::mylabel::Snit_inst1 {}}

test widgetadaptor-1.5 {destroying two widgets of the same type with rename} -constraints {
    tk bug8.5a3
} -body {
    widgetadaptor mylabel {
        constructor {} {
            installhull [label $self]
        }
    }

    mylabel create .lab1
    mylabel create .lab2
    set a [namespace children ::mylabel]
    rename .lab1 ""
    rename .lab2 ""
    set b [namespace children ::mylabel]
    mylabel destroy
    tkbide
    list $a $b
} -result {{::mylabel::Snit_inst1 ::mylabel::Snit_inst2} {}}

test widgetadaptor-1.6 {create/destroy twice, with destroy} -constraints {
    tk
} -body {
    widgetadaptor mylabel {
        constructor {} {
            installhull [label $self]
        }
    }

    mylabel create .lab1
    set a [namespace children ::mylabel]
    destroy .lab1

    mylabel create .lab1
    set b [namespace children ::mylabel]
    destroy .lab1

    set c [namespace children ::mylabel]
    mylabel destroy
    tkbide
    list $a $b $c
} -result {::mylabel::Snit_inst1 ::mylabel::Snit_inst2 {}}

test widgetadaptor-1.7 {create/destroy twice, with rename} -constraints {
    tk bug8.5a3
} -body {
    widgetadaptor mylabel {
        constructor {} {
            installhull [label $self]
        }
    }

    mylabel create .lab1
    set a [namespace children ::mylabel]
    rename .lab1 ""

    mylabel create .lab1
    set b [namespace children ::mylabel]
    rename .lab1 ""

    set c [namespace children ::mylabel]
    mylabel destroy
    tkbide
    list $a $b $c
} -result {::mylabel::Snit_inst1 ::mylabel::Snit_inst2 {}}

test widgetadaptor-1.8 {"create" is optional} -constraints {
    tk
} -body {
    widgetadaptor mylabel {
        constructor {args} {
            installhull [label $self]
        }
        method howdy {} {return "Howdy!"}
    }

    mylabel .label
    set a [.label howdy]

    destroy .label
    tkbide
    set a
} -cleanup {
    mylabel destroy
} -result {Howdy!}

# Case 1
test widgetadaptor-1.9 {"create" is optional, but must be a valid name} -constraints {
    snit1
    tk
} -body {
    widgetadaptor mylabel {
        constructor {args} {
            installhull [label $self]
        }
        method howdy {} {return "Howdy!"}
    }

    catch {mylabel foo} result
    tkbide
    set result
} -cleanup {
    mylabel destroy
} -result {"::mylabel foo" is not defined}

# Case 2
test widgetadaptor-1.10 {"create" is optional, but must be a valid name} -constraints {
    snit2
    tk
} -body {
    widgetadaptor mylabel {
        constructor {args} {
            installhull [label $self]
        }
        method howdy {} {return "Howdy!"}
    }

    catch {mylabel foo} result
    tkbide
    set result
} -cleanup {
    mylabel destroy
} -result {unknown subcommand "foo": namespace ::mylabel does not export any commands}

test widgetadaptor-1.11 {user-defined destructors are called} -constraints {
    tk
} -body {
    widgetadaptor mylabel {
        typevariable flag ""

        constructor {args} {
            installhull [label $self]
            set flag "created $self"
        }

        destructor {
            set flag "destroyed $self"
        }

        typemethod getflag {} {
            return $flag
        }
    }

    mylabel .label
    set a [mylabel getflag]
    destroy .label
    tkbide
    list $a [mylabel getflag]
} -cleanup {
    mylabel destroy
} -result {{created .label} {destroyed .label}}

# Case 1
test widgetadaptor-1.12 {destroy method not defined for widget types} -constraints {
    snit1
    tk
} -body {
    widgetadaptor mylabel {
        constructor {args} {
            installhull [label $self]
        }
    }

    mylabel .label
    catch {.label destroy} result
    destroy .label
    tkbide
    set result
} -cleanup {
    mylabel destroy
} -result {".label destroy" is not defined}

# Case 2
test widgetadaptor-1.13 {destroy method not defined for widget types} -constraints {
    snit2
    tk
} -body {
    widgetadaptor mylabel {
        constructor {args} {
            installhull [label $self]
        }
    }

    mylabel .label
    catch {.label destroy} result
    destroy .label
    tkbide
    set result
} -cleanup {
    mylabel destroy
} -result {unknown subcommand "destroy": namespace ::mylabel::Snit_inst1 does not export any commands}

test widgetadaptor-1.14 {hull can be repeatedly renamed} -constraints {
    tk
} -body {
    widgetadaptor basetype {
        constructor {args} {
            installhull [label $self]
        }

        method basemethod {} { return "basemethod" }
    }

    widgetadaptor w1 {
        constructor {args} {
            installhull [basetype create $self]
        }
    }

    widgetadaptor w2 {
        constructor {args} {
            installhull [w1 $self]
        }
    }

    set a [w2 .foo]
    destroy .foo
    tkbide
    set a
} -cleanup {
    w2 destroy
    w1 destroy
    basetype destroy
} -result {.foo}

test widgetadaptor-1.15 {widget names can be generated} -constraints {
    tk
} -body {
    widgetadaptor unique {
        constructor {args} {
            installhull [label $self]
        }
    }

    set w [unique .%AUTO%]
    destroy $w
    tkbide
    set w
} -cleanup {
    unique destroy
} -result {.unique1}

test widgetadaptor-1.16 {snit::widgetadaptor as hull} -constraints {
    tk
} -body {
    widgetadaptor mylabel {
        constructor {args} {
            installhull [label $self]
            $self configurelist $args
        }
        method method1 {} {
            return "method1"
        }
        delegate option * to hull
    }

    widgetadaptor mylabel2 {
        constructor {args} {
            installhull [mylabel $self]
            $self configurelist $args
        }
        method method2 {} {
            return "method2: [$hull method1]"
        }
        delegate option * to hull
    }

    mylabel2 .label -text "Some Text"
    set a [.label method2]
    set b [.label cget -text]
    .label configure -text "More Text"
    set c [.label cget -text]
    set d [namespace children ::mylabel2]
    set e [namespace children ::mylabel]

    destroy .label

    set f [namespace children ::mylabel2]
    set g [namespace children ::mylabel]

    mylabel2 destroy
    mylabel destroy

    tkbide
    list $a $b $c $d $e $f $g
} -result {{method2: method1} {Some Text} {More Text} ::mylabel2::Snit_inst1 ::mylabel::Snit_inst1 {} {}}

test widgetadaptor-1.17 {snit::widgetadaptor as hull; use rename} -constraints {
    tk bug8.5a3
} -body {
    widgetadaptor mylabel {
        constructor {args} {
            installhull [label $self]
            $self configurelist $args
        }
        method method1 {} {
            return "method1"
        }
        delegate option * to hull
    }

    widgetadaptor mylabel2 {
        constructor {args} {
            installhull [mylabel $self]
            $self configurelist $args
        }
        method method2 {} {
            return "method2: [$hull method1]"
        }
        delegate option * to hull
    }

    mylabel2 .label -text "Some Text"
    set a [.label method2]
    set b [.label cget -text]
    .label configure -text "More Text"
    set c [.label cget -text]
    set d [namespace children ::mylabel2]
    set e [namespace children ::mylabel]

    rename .label ""

    set f [namespace children ::mylabel2]
    set g [namespace children ::mylabel]

    mylabel2 destroy
    mylabel destroy

    tkbide
    list $a $b $c $d $e $f $g
} -result {{method2: method1} {Some Text} {More Text} ::mylabel2::Snit_inst1 ::mylabel::Snit_inst1 {} {}}

test widgetadaptor-1.18 {BWidget Label as hull} -constraints {
    bwidget
} -body {
    widgetadaptor mylabel {
        constructor {args} {
            installhull [Label $win]
            $self configurelist $args
        }
        delegate option * to hull
    }

    mylabel .label -text "Some Text"
    set a [.label cget -text]

    .label configure -text "More Text"
    set b [.label cget -text]

    set c [namespace children ::mylabel]

    destroy .label

    set d [namespace children ::mylabel]

    mylabel destroy

    tkbide
    list $a $b $c $d
} -result {{Some Text} {More Text} ::mylabel::Snit_inst1 {}}

test widgetadaptor-1.19 {error in widgetadaptor constructor} -constraints {
    tk
} -body {
    widgetadaptor mylabel {
        constructor {args} {
            error "Simulated Error"
        }
    }

    mylabel .lab
} -returnCodes {
    error
} -cleanup {
    mylabel destroy
} -result {Error in constructor: Simulated Error}


#-----------------------------------------------------------------------
# Widgets

# A widget is just a widgetadaptor with an automatically created hull
# component (a Tk frame).  So the widgetadaptor tests apply; all we
# need to test here is the frame creation.

test widget-1.1 {creating a widget} -constraints {
    tk
} -body {
    widget myframe {
        method hull {} { return $hull }

        delegate method * to hull
        delegate option * to hull
    }

    myframe create .frm -background green

    set a [.frm cget -background]
    set b [.frm hull]

    destroy .frm
    tkbide
    list $a $b
} -cleanup {
    myframe destroy
} -result {green ::hull1.frm}

test widget-2.1 {can't redefine hull} -constraints {
    tk
} -body {
    widget myframe {
        method resethull {} { set hull "" }
    }

    myframe .frm

    .frm resethull
} -returnCodes {
    error
} -cleanup {
    myframe destroy
} -result {can't set "hull": The hull component cannot be redefined}

#-----------------------------------------------------------------------
# install
#
# The install command is used to install widget components, while getting
# options for the option database.

test install-1.1 {installed components are created properly} -constraints {
    tk
} -body {
    widget myframe {
        # Delegate an option just to make sure the component variable
        # exists.
        delegate option -font to text

        constructor {args} {
            install text using text $win.text -background green
        }

        method getit {} {
            $win.text cget -background
        }
    }

    myframe .frm
    set a [.frm getit]
    destroy .frm
    tkbide
    set a
} -cleanup {
    myframe destroy
} -result {green}

test install-1.2 {installed components are saved properly} -constraints {
    tk
} -body {
    widget myframe {
        # Delegate an option just to make sure the component variable
        # exists.
        delegate option -font to text

        constructor {args} {
            install text using text $win.text -background green
        }

        method getit {} {
            $text cget -background
        }
    }

    myframe .frm
    set a [.frm getit]
    destroy .frm
    tkbide
    set a
} -cleanup {
    myframe destroy
} -result {green}

test install-1.3 {can't install until hull exists} -constraints {
    tk
} -body {
    widgetadaptor myframe {
        # Delegate an option just to make sure the component variable
        # exists.
        delegate option -font to text

        constructor {args} {
            install text using text $win.text -background green
        }
    }

    myframe .frm
} -returnCodes {
    error
} -cleanup {
    myframe destroy
} -result {Error in constructor: tried to install "text" before the hull exists}

test install-1.4 {install queries option database} -constraints {
    tk
} -body {
    widget myframe {
        delegate option -font to text

        typeconstructor {
            option add *Myframe.font Courier
        }

        constructor {args} {
            install text using text $win.text
        }
    }

    myframe .frm
    set a [.frm cget -font]
    destroy .frm
    tkbide
    set a
} -cleanup {
    myframe destroy
} -result {Courier}

test install-1.5 {explicit options override option database} -constraints {
    tk
} -body {
    widget myframe {
        delegate option -font to text

        typeconstructor {
            option add *Myframe.font Courier
        }

        constructor {args} {
            install text using text $win.text -font Times
        }
    }

    myframe .frm
    set a [.frm cget -font]
    destroy .frm
    tkbide
    set a
} -cleanup {
    myframe destroy
} -result {Times}

test install-1.6 {option db works with targetted options} -constraints {
    tk
} -body {
    widget myframe {
        delegate option -textfont to text as -font

        typeconstructor {
            option add *Myframe.textfont Courier
        }

        constructor {args} {
            install text using text $win.text
        }
    }

    myframe .frm
    set a [.frm cget -textfont]
    destroy .frm
    tkbide
    set a
} -cleanup {
    myframe destroy
} -result {Courier}

test install-1.7 {install works for snit::types} -body {
    type tail {
        option -tailcolor black
    }

    type dog {
        delegate option -tailcolor to tail

        constructor {args} {
            install tail using tail $self.tail
        }
    }

    dog fido
    fido cget -tailcolor
} -cleanup {
    dog destroy
    tail destroy
} -result {black}

test install-1.8 {install can install non-widget components} -constraints {
    tk
} -body {
    type dog {
        option -tailcolor black
    }

    widget myframe {
        delegate option -tailcolor to thedog

        typeconstructor {
            option add *Myframe.tailcolor green
        }

        constructor {args} {
            install thedog using dog $win.dog
        }
    }

    myframe .frm
    set a [.frm cget -tailcolor]
    destroy .frm
    tkbide
    set a

} -cleanup {
    dog destroy
    myframe destroy
} -result {green}

test install-1.9 {ok if no options are delegated to component} -constraints {
    tk
} -body {
    type dog {
        option -tailcolor black
    }

    widget myframe {
        constructor {args} {
            install thedog using dog $win.dog
        }
    }

    myframe .frm
    destroy .frm
    tkbide

    # Test passes if no error is raised.
    list ok
} -cleanup {
    myframe destroy
    dog destroy
} -result {ok}

test install-2.1 {
    delegate option * for a non-shadowed option.  The text widget's
    -foreground and -font options should be set according to what's
    in the option database on the widgetclass.
} -constraints {
    tk
} -body {
    widget myframe {
        delegate option * to text

        typeconstructor {
            option add *Myframe.foreground red
            option add *Myframe.font {Times 14}
        }

        constructor {args} {
            install text using text $win.text
        }
    }

    myframe .frm
    set a [.frm cget -foreground]
    set b [.frm cget -font]
    destroy .frm
    tkbide

    list $a $b
} -cleanup {
    myframe destroy
} -result {red {Times 14}}

test install-2.2 {
    Delegate option * for a shadowed option.  Foreground is declared
    as a non-delegated option, hence it will pick up the option database
    default.  -foreground is not included in the "delegate option *", so
    the text widget's -foreground option will not be set from the
    option database.
} -constraints {
    tk
} -body {
    widget myframe {
        option -foreground white
        delegate option * to text

        typeconstructor {
            option add *Myframe.foreground red
        }

        constructor {args} {
            install text using text $win.text
        }

        method getit {} {
            $text cget -foreground
        }
    }

    myframe .frm
    set a [.frm cget -foreground]
    set b [.frm getit]
    destroy .frm
    tkbide

    expr {![string equal $a $b]}
} -cleanup {
    myframe destroy
} -result {1}

test install-2.3 {
    Delegate option * for a creation option.  Because the text widget's
    -foreground is set explicitly by the constructor, that always
    overrides the option database.
} -constraints {
    tk
} -body {
    widget myframe {
        delegate option * to text

        typeconstructor {
            option add *Myframe.foreground red
        }

        constructor {args} {
            install text using text $win.text -foreground blue
        }
    }

    myframe .frm
    set a [.frm cget -foreground]
    destroy .frm
    tkbide

    set a
} -cleanup {
    myframe destroy
} -result {blue}

test install-2.4 {
    Delegate option * with an excepted option.  Because the text widget's
    -state is excepted, it won't be set from the option database.
} -constraints {
    tk
} -body {
    widget myframe {
        delegate option * to text except -state

        typeconstructor {
            option add *Myframe.foreground red
            option add *Myframe.state disabled
        }

        constructor {args} {
            install text using text $win.text
        }

        method getstate {} {
            $text cget -state
        }
    }

    myframe .frm
    set a [.frm getstate]
    destroy .frm
    tkbide

    set a
} -cleanup {
    myframe destroy
} -result {normal}

#-----------------------------------------------------------------------
# Advanced installhull tests
#
# installhull is used to install the hull widget for both widgets and
# widget adaptors.  It has two forms.  In one form it installs a widget
# created by some third party; in this form no querying of the option
# database is needed, because we haven't taken responsibility for creating
# it.  But in the other form (installhull using) installhull actually
# creates the widget, and takes responsibility for querying the
# option database as needed.
#
# NOTE: "installhull using" is always used to create a widget's hull frame.
#
# That options passed into installhull override those from the
# option database.

test installhull-1.1 {
    options delegated to a widget's hull frame with the same name are
    initialized from the option database.  Note that there's no
    explicit code in Snit to do this; it happens because we set the
    -class when the widget was created.  In fact, it happens whether
    we delegate the option name or not.
} -constraints {
    tk
} -body {
    widget myframe {
        delegate option -background to hull

        typeconstructor {
            option add *Myframe.background red
            option add *Myframe.width 123
        }

        method getwid {} {
            $hull cget -width
        }
    }

    myframe .frm
    set a [.frm cget -background]
    set b [.frm getwid]
    destroy .frm
    tkbide
    list $a $b
} -cleanup {
    myframe destroy
} -result {red 123}

test installhull-1.2 {
    Options delegated to a widget's hull frame with a different name are
    initialized from the option database.
} -constraints {
    tk
} -body {
    widget myframe {
        delegate option -mainbackground to hull as -background

        typeconstructor {
            option add *Myframe.mainbackground red
        }
    }

    myframe .frm
    set a [.frm cget -mainbackground]
    destroy .frm
    tkbide
    set a
} -cleanup {
    myframe destroy
} -result {red}

test installhull-1.3 {
    options delegated to a widgetadaptor's hull frame with the same name are
    initialized from the option database.  Note that there's no
    explicit code in Snit to do this; there's no way to change the
    adapted hull widget's -class, so the widget is simply being
    initialized normally.
} -constraints {
    tk
} -body {
    widgetadaptor myframe {
        delegate option -background to hull

        typeconstructor {
            option add *Frame.background red
            option add *Frame.width 123
        }

        constructor {args} {
            installhull using frame
        }

        method getwid {} {
            $hull cget -width
        }
    }

    myframe .frm
    set a [.frm cget -background]
    set b [.frm getwid]
    destroy .frm
    tkbide
    list $a $b
} -cleanup {
    myframe destroy
} -result {red 123}

test installhull-1.4 {
    Options delegated to a widget's hull frame with a different name are
    initialized from the option database.
} -constraints {
    tk
} -body {
    widgetadaptor myframe {
        delegate option -mainbackground to hull as -background

        typeconstructor {
            option add *Frame.mainbackground red
        }

        constructor {args} {
            installhull using frame
        }
    }

    myframe .frm
    set a [.frm cget -mainbackground]
    destroy .frm
    tkbide
    set a
} -cleanup {
    myframe destroy
} -result {red}

test installhull-1.5 {
    Option values read from the option database are overridden by options
    explicitly passed, even if delegated under a different name.
} -constraints {
    tk
} -body {
    widgetadaptor myframe {
        delegate option -mainbackground to hull as -background

        typeconstructor {
            option add *Frame.mainbackground red
            option add *Frame.width 123
        }

        constructor {args} {
            installhull using frame -background green -width 321
        }

        method getwid {} {
            $hull cget -width
        }
    }

    myframe .frm
    set a [.frm cget -mainbackground]
    set b [.frm getwid]
    destroy .frm
    tkbide
    list $a $b
} -cleanup {
    myframe destroy
} -result {green 321}


#-----------------------------------------------------------------------
# Instance Introspection

# Case 1
test iinfo-1.1 {object info too few args} -constraints {
    snit1
} -body {
    type dog { }

    dog create spot

    spot info
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result [tcltest::wrongNumArgs ::snit::RT.method.info {type selfns win self command args} 4]

# Case 2
test iinfo-1.2 {object info too few args} -constraints {
    snit2
} -body {
    type dog { }

    dog create spot

    spot info
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result [expect \
	       {wrong # args: should be "spot info command ?arg ...?"} \
	       {wrong # args: should be "spot info command ..."}]

test iinfo-1.3 {object info too many args} -body {
    type dog { }

    dog create spot

    spot info type foo
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result [tcltest::tooManyArgs ::snit::RT.method.info.type {type selfns win self}]

test iinfo-2.1 {object info type} -body {
    type dog { }

    dog create spot
    spot info type
} -cleanup {
    dog destroy
} -result {::dog}

test iinfo-3.1 {object info typevars} -body {
    type dog {
        typevariable thisvar 1

        constructor {args} {
            typevariable thatvar 2
        }
    }

    dog create spot
    lsort [spot info typevars]
} -cleanup {
    dog destroy
} -result {::dog::thatvar ::dog::thisvar}

test iinfo-3.2 {object info typevars with pattern} -body {
    type dog {
        typevariable thisvar 1

        constructor {args} {
            typevariable thatvar 2
        }
    }

    dog create spot
    spot info typevars *this*
} -cleanup {
    dog destroy
} -result {::dog::thisvar}

test iinfo-4.1 {object info vars} -body {
    type dog {
        variable hisvar 1

        constructor {args} {
            variable hervar
            set hervar 2
        }
    }

    dog create spot
    lsort [spot info vars]
} -cleanup {
    dog destroy
} -result {::dog::Snit_inst1::hervar ::dog::Snit_inst1::hisvar}

test iinfo-4.2 {object info vars with pattern} -body {
    type dog {
        variable hisvar 1

        constructor {args} {
            variable hervar
            set hervar 2
        }
    }

    dog create spot
    spot info vars "*his*"
} -cleanup {
    dog destroy
} -result {::dog::Snit_inst1::hisvar}

test iinfo-5.1 {object info no vars defined} -body {
    type dog { }

    dog create spot
    list [spot info vars] [spot info typevars]
} -cleanup {
    dog destroy
} -result {{} {}}

test iinfo-6.1 {info options with no options} -body {
    type dog { }
    dog create spot

    llength [spot info options]
} -cleanup {
    dog destroy
} -result {0}

test iinfo-6.2 {info options with only local options} -body {
    type dog {
        option -foo a
        option -bar b
    }
    dog create spot

    lsort [spot info options]
} -cleanup {
    dog destroy
} -result {-bar -foo}

test iinfo-6.3 {info options with local and delegated options} -body {
    type dog {
        option -foo a
        option -bar b
        delegate option -quux to sibling
    }
    dog create spot

    lsort [spot info options]
} -cleanup {
    dog destroy
} -result {-bar -foo -quux}

test iinfo-6.4 {info options with unknown delegated options} -constraints {
    tk tcl83
} -body {
    widgetadaptor myframe {
        option -foo a
        delegate option * to hull
        constructor {args} {
            installhull [frame $self]
        }
    }
    myframe .frm

    set a [lsort [.frm info options]]
    destroy .frm
    tkbide
    set a
} -cleanup {
    myframe destroy
} -result {-background -bd -bg -borderwidth -class -colormap -container -cursor -foo -height -highlightbackground -highlightcolor -highlightthickness -relief -takefocus -visual -width}

test iinfo-6.5 {info options with unknown delegated options} -constraints {
    tk tcl84
} -body {
    widgetadaptor myframe {
        option -foo a
        delegate option * to hull
        constructor {args} {
            installhull [frame $self]
        }
    }
    myframe .frm

    set a [lsort [.frm info options]]
    destroy .frm
    tkbide
    set a
} -cleanup {
    myframe destroy
} -result {-background -bd -bg -borderwidth -class -colormap -container -cursor -foo -height -highlightbackground -highlightcolor -highlightthickness -padx -pady -relief -takefocus -visual -width}

test iinfo-6.6 {info options with exceptions} -constraints {
    tk tcl83
} -body {
    widgetadaptor myframe {
        option -foo a
        delegate option * to hull except -background
        constructor {args} {
            installhull [frame $self]
        }
    }
    myframe .frm

    set a [lsort [.frm info options]]
    destroy .frm
    tkbide
    set a
} -cleanup {
    myframe destroy
} -result {-bd -bg -borderwidth -class -colormap -container -cursor -foo -height -highlightbackground -highlightcolor -highlightthickness -relief -takefocus -visual -width}

test iinfo-6.7 {info options with exceptions} -constraints {
    tk tcl84
} -body {
    widgetadaptor myframe {
        option -foo a
        delegate option * to hull except -background
        constructor {args} {
            installhull [frame $self]
        }
    }
    myframe .frm

    set a [lsort [.frm info options]]
    destroy .frm
    tkbide
    set a
} -cleanup {
    myframe destroy
} -result {-bd -bg -borderwidth -class -colormap -container -cursor -foo -height -highlightbackground -highlightcolor -highlightthickness -padx -pady -relief -takefocus -visual -width}

test iinfo-6.8 {info options with pattern} -constraints {
    tk
} -body {
    widgetadaptor myframe {
        option -foo a
        delegate option * to hull
        constructor {args} {
            installhull [frame $self]
        }
    }
    myframe .frm

    set a [lsort [.frm info options -c*]]
    destroy .frm
    tkbide
    set a
} -cleanup {
    myframe destroy
} -result {-class -colormap -container -cursor}

test iinfo-7.1 {info typemethods, simple case} -body {
    type dog { }

    dog spot

    lsort [spot info typemethods]
} -cleanup {
    dog destroy
} -result {create destroy info}

test iinfo-7.2 {info typemethods, with pattern} -body {
    type dog { }

    dog spot

    spot info typemethods i*
} -cleanup {
    dog destroy
} -result {info}

test iinfo-7.3 {info typemethods, with explicit typemethods} -body {
    type dog {
        typemethod foo {} {}
        delegate typemethod bar to comp
    }

    dog spot

    lsort [spot info typemethods]
} -cleanup {
    dog destroy
} -result {bar create destroy foo info}

test iinfo-7.4 {info typemethods, with implicit typemethods} -body {
    type dog {
        delegate typemethod * to comp

        typeconstructor {
            set comp string
        }
    }

    dog create spot

    set a [lsort [spot info typemethods]]

    dog length foo
    dog is boolean yes

    set b [lsort [spot info typemethods]]

    set c [spot info typemethods len*]

    list $a $b $c
} -cleanup {
    dog destroy
} -result {{create destroy info} {create destroy info is length} length}

test iinfo-7.5 {info typemethods, with hierarchical typemethods} -body {
    type dog {
        delegate typemethod {comp foo} to comp

        typemethod {comp bar} {} {}
    }

    dog create spot

    lsort [spot info typemethods]
} -cleanup {
    dog destroy
} -result {{comp bar} {comp foo} create destroy info}


test iinfo-8.1 {info methods, simple case} -body {
    type dog { }

    dog spot

    lsort [spot info methods]
} -cleanup {
    dog destroy
} -result {destroy info}

test iinfo-8.2 {info methods, with pattern} -body {
    type dog { }

    dog spot

    spot info methods i*
} -cleanup {
    dog destroy
} -result {info}

test iinfo-8.3 {info methods, with explicit methods} -body {
    type dog {
        method foo {} {}
        delegate method bar to comp
    }

    dog spot

    lsort [spot info methods]
} -cleanup {
    dog destroy
} -result {bar destroy foo info}

test iinfo-8.4 {info methods, with implicit methods} -body {
    type dog {
        delegate method * to comp

        constructor {args} {
            set comp string
        }
    }

    dog create spot

    set a [lsort [spot info methods]]

    spot length foo
    spot is boolean yes

    set b [lsort [spot info methods]]

    set c [spot info methods len*]

    list $a $b $c
} -cleanup {
    dog destroy
} -result {{destroy info} {destroy info is length} length}

test iinfo-8.5 {info methods, with hierarchical methods} -body {
    type dog {
        delegate method {comp foo} to comp

        method {comp bar} {} {}
    }

    dog create spot

    lsort [spot info methods]
} -cleanup {
    dog destroy
} -result {{comp bar} {comp foo} destroy info}

test iinfo-9.1 {info args} -body {
    type dog {
	method bark {volume} {}
    }

    dog spot

    spot info args bark
} -cleanup {
    dog destroy
} -result {volume}

test iinfo-9.2 {info args, too few args} -body {
    type dog {
	method bark {volume} {}
    }

    dog spot

    spot info args
} -returnCodes error -cleanup {
    dog destroy
} -result [tcltest::wrongNumArgs ::snit::RT.method.info.args {type selfns win self method} 4]

test iinfo-9.3 {info args, too many args} -body {
    type dog {
	method bark {volume} {}
    }

    dog spot

    spot info args bark wag
} -returnCodes error -cleanup {
    dog destroy
} -result [tcltest::tooManyArgs ::snit::RT.method.info.args {type selfns win self method}]

test iinfo-9.4 {info args, unknown method} -body {
    type dog {
    }

    dog spot

    spot info args bark
} -returnCodes error -cleanup {
    dog destroy
} -result {Unknown method "bark"}

test iinfo-9.5 {info args, delegated method} -body {
    type dog {
	component x
	delegate method bark to x
    }

    dog spot

    spot info args bark
} -returnCodes error -cleanup {
    dog destroy
} -result {Delegated method "bark"}

test iinfo-10.1 {info default} -body {
    type dog {
	method bark {{volume 50}} {}
    }

    dog spot

    list [spot info default bark volume def] $def
} -cleanup {
    dog destroy
} -result {1 50}

test iinfo-10.2 {info default, too few args} -body {
    type dog {
	method bark {volume} {}
    }

    dog spot

    spot info default
} -returnCodes error -cleanup {
    dog destroy
} -result [tcltest::wrongNumArgs ::snit::RT.method.info.default {type selfns win self method aname dvar} 4]

test iinfo-10.3 {info default, too many args} -body {
    type dog {
	method bark {volume} {}
    }

    dog spot

    spot info default bark wag def foo
} -returnCodes error -cleanup {
    dog destroy
} -result [tcltest::tooManyArgs ::snit::RT.method.info.default {type selfns win self method aname dvar}]

test iinfo-10.4 {info default, unknown method} -body {
    type dog {
    }

    dog spot

    spot info default bark x var
} -returnCodes error -cleanup {
    dog destroy
} -result {Unknown method "bark"}

test iinfo-10.5 {info default, delegated method} -body {
    type dog {
	component x
	delegate method bark to x
    }

    dog spot

    spot info default bark x var
} -returnCodes error -cleanup {
    dog destroy
} -result {Delegated method "bark"}

test iinfo-11.1 {info body} -body {
    type dog {
	typevariable x
	variable y
	method bark {volume} {
	    speaker on
	    speaker play bark.snd
	    speaker off
	}
    }

    dog spot

    spot info body bark
} -cleanup {
    dog destroy
} -result {
	    speaker on
	    speaker play bark.snd
	    speaker off
	}

test iinfo-11.2 {info body, too few args} -body {
    type dog {
	method bark {volume} {}
    }

    dog spot

    spot info body
} -returnCodes error -cleanup {
    dog destroy
} -result [tcltest::wrongNumArgs ::snit::RT.method.info.body {type selfns win self method} 4]

test iinfo-11.3 {info body, too many args} -body {
    type dog {
	method bark {volume} {}
    }

    dog spot

    spot info body bark wag
} -returnCodes error -cleanup {
    dog destroy
} -result [tcltest::tooManyArgs ::snit::RT.method.info.body {type selfns win self method}]

test iinfo-11.4 {info body, unknown method} -body {
    type dog {
    }

    dog spot

    spot info body bark
} -returnCodes error -cleanup {
    dog destroy
} -result {Unknown method "bark"}

test iinfo-11.5 {info body, delegated method} -body {
    type dog {
	component x
	delegate method bark to x
    }

    dog spot

    spot info body bark
} -returnCodes error -cleanup {
    dog destroy
} -result {Delegated method "bark"}

#-----------------------------------------------------------------------
# Type Introspection

# Case 1
test tinfo-1.1 {type info too few args} -constraints {
    snit1
} -body {
    type dog { }

    dog info
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result [tcltest::wrongNumArgs ::snit::RT.typemethod.info {type command args} 1]

# Case 2
test tinfo-1.2 {type info too few args} -constraints {
    snit2
} -body {
    type dog { }

    dog info
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result [expect \
	       {wrong # args: should be "dog info command ?arg ...?"} \
	       {wrong # args: should be "dog info command ..."}]

test tinfo-1.3 {type info too many args} -body {
    type dog { }

    dog info instances foo bar
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result [tcltest::tooManyArgs ::snit::RT.typemethod.info.instances {type ?pattern?}]

test tinfo-2.1 {type info typevars} -body {
    type dog {
        typevariable thisvar 1

        constructor {args} {
            typevariable thatvar 2
        }
    }

    dog create spot
    lsort [dog info typevars]
} -cleanup {
    dog destroy
} -result {::dog::thatvar ::dog::thisvar}

test tinfo-3.1 {type info instances} -body {
    type dog { }

    dog create spot
    dog create fido

    lsort [dog info instances]
} -cleanup {
    dog destroy
} -result {::fido ::spot}

test tinfo-3.2 {widget info instances} -constraints {
    tk
} -body {
    widgetadaptor mylabel {
        constructor {args} {
            installhull [label $self]
        }
    }

    mylabel .lab1
    mylabel .lab2

    set result [mylabel info instances]

    destroy .lab1
    destroy .lab2
    tkbide

    lsort $result
} -cleanup {
    mylabel destroy
} -result {.lab1 .lab2}

test tinfo-3.3 {type info instances with non-global namespaces} -body {
    type dog { }

    dog create ::spot

    namespace eval ::dogs:: {
        set ::qname [dog create fido]
    }

    list $qname [lsort [dog info instances]]
} -cleanup {
    dog destroy
} -result {::dogs::fido {::dogs::fido ::spot}}

test tinfo-3.4 {type info instances with pattern} -body {
    type dog { }

    dog create spot
    dog create fido

    dog info instances "*f*"
} -cleanup {
    dog destroy
} -result {::fido}

test tinfo-3.5 {type info instances with unrelated child namespace, bug 2898640} -body {
    type dog { }
    namespace eval dog::unrelated {}
    dog create fido

    dog info instances
} -cleanup {
    dog destroy
} -result {::fido}

test tinfo-4.1 {type info typevars with pattern} -body {
    type dog {
        typevariable thisvar 1

        constructor {args} {
            typevariable thatvar 2
        }
    }

    dog create spot
    dog info typevars *this*
} -cleanup {
    dog destroy
} -result {::dog::thisvar}

test tinfo-5.1 {type info typemethods, simple case} -body {
    type dog { }

    lsort [dog info typemethods]
} -cleanup {
    dog destroy
} -result {create destroy info}

test tinfo-5.2 {type info typemethods, with pattern} -body {
    type dog { }

    dog info typemethods i*
} -cleanup {
    dog destroy
} -result {info}

test tinfo-5.3 {type info typemethods, with explicit typemethods} -body {
    type dog {
        typemethod foo {} {}
        delegate typemethod bar to comp
    }

    lsort [dog info typemethods]
} -cleanup {
    dog destroy
} -result {bar create destroy foo info}

test tinfo-5.4 {type info typemethods, with implicit typemethods} -body {
    type dog {
        delegate typemethod * to comp

        typeconstructor {
            set comp string
        }
    }

    set a [lsort [dog info typemethods]]

    dog length foo
    dog is boolean yes

    set b [lsort [dog info typemethods]]

    set c [dog info typemethods len*]

    list $a $b $c
} -cleanup {
    dog destroy
} -result {{create destroy info} {create destroy info is length} length}

test tinfo-5.5 {info typemethods, with hierarchical typemethods} -body {
    type dog {
        delegate typemethod {comp foo} to comp

        typemethod {comp bar} {} {}
    }

    lsort [dog info typemethods]
} -cleanup {
    dog destroy
} -result {{comp bar} {comp foo} create destroy info}

test tinfo-6.1 {type info args} -body {
    type dog {
	typemethod bark {volume} {}
    }

    dog info args bark
} -cleanup {
    dog destroy
} -result {volume}

test tinfo-6.2 {type info args, too few args} -body {
    type dog {
	typemethod bark {volume} {}
    }

    dog info args
} -returnCodes error -cleanup {
    dog destroy
} -result [tcltest::wrongNumArgs ::snit::RT.typemethod.info.args {type method} 1]

test tinfo-6.3 {type info args, too many args} -body {
    type dog {
	typemethod bark {volume} {}
    }

    dog info args bark wag
} -returnCodes error -cleanup {
    dog destroy
} -result [tcltest::tooManyArgs ::snit::RT.typemethod.info.args {type method}]

test tinfo-6.4 {type info args, unknown method} -body {
    type dog {
    }

    dog info args bark
} -returnCodes error -cleanup {
    dog destroy
} -result {Unknown typemethod "bark"}

test tinfo-6.5 {type info args, delegated method} -body {
    type dog {
	delegate typemethod bark to x
    }

    dog info args bark
} -returnCodes error -cleanup {
    dog destroy
} -result {Delegated typemethod "bark"}

test tinfo-7.1 {type info default} -body {
    type dog {
	typemethod bark {{volume 50}} {}
    }

    list [dog info default bark volume def] $def
} -cleanup {
    dog destroy
} -result {1 50}

test tinfo-7.2 {type info default, too few args} -body {
    type dog {
	typemethod bark {volume} {}
    }

    dog info default
} -returnCodes error -cleanup {
    dog destroy
} -result [tcltest::wrongNumArgs ::snit::RT.typemethod.info.default {type method aname dvar} 1]

test tinfo-7.3 {type info default, too many args} -body {
    type dog {
	typemethod bark {volume} {}
    }

    dog info default bark wag def foo
} -returnCodes error -cleanup {
    dog destroy
} -result [tcltest::tooManyArgs ::snit::RT.typemethod.info.default {type method aname dvar}]

test tinfo-7.4 {type info default, unknown method} -body {
    type dog {
    }

    dog info default bark x var
} -returnCodes error -cleanup {
    dog destroy
} -result {Unknown typemethod "bark"}

test tinfo-7.5 {type info default, delegated method} -body {
    type dog {
	delegate typemethod bark to x
    }

    dog info default bark x var
} -returnCodes error -cleanup {
    dog destroy
} -result {Delegated typemethod "bark"}

test tinfo-8.1 {type info body} -body {
    type dog {
	typevariable x
	variable y
	typemethod bark {volume} {
	    speaker on
	    speaker play bark.snd
	    speaker off
	}
    }

    dog info body bark
} -cleanup {
    dog destroy
} -result {
	    speaker on
	    speaker play bark.snd
	    speaker off
	}

test tinfo-8.2 {type info body, too few args} -body {
    type dog {
	typemethod bark {volume} {}
    }

    dog info body
} -returnCodes error -cleanup {
    dog destroy
} -result [tcltest::wrongNumArgs ::snit::RT.typemethod.info.body {type method} 1]

test tinfo-8.3 {type info body, too many args} -body {
    type dog {
	typemethod bark {volume} {}
    }

    dog info body bark wag
} -returnCodes error -cleanup {
    dog destroy
} -result [tcltest::tooManyArgs ::snit::RT.typemethod.info.body {type method}]

test tinfo-8.4 {type info body, unknown method} -body {
    type dog {
    }

    dog info body bark
} -returnCodes error -cleanup {
    dog destroy
} -result {Unknown typemethod "bark"}

test tinfo-8.5 {type info body, delegated method} -body {
    type dog {
	delegate typemethod bark to x
    }

    dog info body bark
} -returnCodes error -cleanup {
    dog destroy
} -result {Delegated typemethod "bark"}

#-----------------------------------------------------------------------
# Setting the widget class explicitly

test widgetclass-1.1 {can't set widgetclass for snit::types} -body {
    type dog {
        widgetclass Dog
    }
} -returnCodes {
    error
} -result {widgetclass cannot be set for snit::types}

test widgetclass-1.2 {can't set widgetclass for snit::widgetadaptors} -constraints {
    tk
} -body {
    widgetadaptor dog {
        widgetclass Dog
    }
} -returnCodes {
    error
} -result {widgetclass cannot be set for snit::widgetadaptors}

test widgetclass-1.3 {widgetclass must begin with uppercase letter} -constraints {
    tk
} -body {
    widget dog {
        widgetclass dog
    }
} -returnCodes {
    error
} -result {widgetclass "dog" does not begin with an uppercase letter}

test widgetclass-1.4 {widgetclass can only be defined once} -constraints {
    tk
} -body {
    widget dog {
        widgetclass Dog
        widgetclass Dog
    }
} -returnCodes {
    error
} -result {too many widgetclass statements}

test widgetclass-1.5 {widgetclass set successfully} -constraints {
    tk
} -body {
    widget dog {
        widgetclass DogWidget
    }

    # The test passes if no error is thrown.
    list ok
} -cleanup {
    dog destroy
} -result {ok}

test widgetclass-1.6 {implicit widgetclass applied to hull} -constraints {
    tk
} -body {
    widget dog {
        typeconstructor {
            option add *Dog.background green
        }

        method background {} {
            $hull cget -background
        }
    }

    dog .dog

    set bg [.dog background]

    destroy .dog

    set bg
} -cleanup {
    dog destroy
} -result {green}

test widgetclass-1.7 {explicit widgetclass applied to hull} -constraints {
    tk
} -body {
    widget dog {
        widgetclass DogWidget

        typeconstructor {
            option add *DogWidget.background green
        }

        method background {} {
            $hull cget -background
        }
    }

    dog .dog

    set bg [.dog background]

    destroy .dog

    set bg
} -cleanup {
    dog destroy
} -result {green}

#-----------------------------------------------------------------------
# hulltype statement

test hulltype-1.1 {can't set hulltype for snit::types} -body {
    type dog {
        hulltype Dog
    }
} -returnCodes {
    error
} -result {hulltype cannot be set for snit::types}

test hulltype-1.2 {can't set hulltype for snit::widgetadaptors} -constraints {
    tk
} -body {
    widgetadaptor dog {
        hulltype Dog
    }
} -returnCodes {
    error
} -result {hulltype cannot be set for snit::widgetadaptors}

test hulltype-1.3 {hulltype can be frame} -constraints {
    tk
} -body {
    widget dog {
        delegate option * to hull
        hulltype frame
    }

    dog .fido
    catch {.fido configure -use} result
    destroy .fido
    tkbide

    set result
} -cleanup {
    dog destroy
} -result {unknown option "-use"}

test hulltype-1.4 {hulltype can be toplevel} -constraints {
    tk
} -body {
    widget dog {
        delegate option * to hull
        hulltype toplevel
    }

    dog .fido
    catch {.fido configure -use} result
    destroy .fido
    tkbide

    set result
} -cleanup {
    dog destroy
} -result {-use use Use {} {}}

test hulltype-1.5 {hulltype can only be defined once} -constraints {
    tk
} -body {
    widget dog {
        hulltype frame
        hulltype toplevel
    }
} -returnCodes {
    error
} -result {too many hulltype statements}

test hulltype-2.1 {list of valid hulltypes} -constraints {
    tk
} -body {
    lsort $::snit::hulltypes
} -result {frame labelframe tk::frame tk::labelframe tk::toplevel toplevel ttk::frame ttk::labelframe}


#-----------------------------------------------------------------------
# expose statement

test expose-1.1 {can't expose nothing} -body {
    type dog {
	expose
    }
} -constraints {
    snit1
} -returnCodes {
    error
} -result [tcltest::wrongNumArgs ::snit::Comp.statement.expose {component ?as? ?methodname?} 0]

test expose-1.1a {can't expose nothing} -body {
    type dog {
	expose
    }
} -constraints {
    snit2
} -returnCodes {
    error
} -result [tcltest::wrongNumArgs expose {component ?as? ?methodname?} 0]

test expose-1.2 {expose a component that's never installed} -body {
    type dog {
        expose tail
    }

    dog fido

    fido tail wag
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result {undefined component "tail"}

test expose-1.3 {exposed method returns component command} -body {
    type tail {  }

    type dog {
        expose tail

        constructor {} {
            install tail using tail $self.tail
        }

        destructor {
            $tail destroy
        }
    }

    dog fido

    fido tail
} -cleanup {
    dog destroy
    tail destroy
} -result {::fido.tail}

test expose-1.4 {exposed method calls component methods} -body {
    type tail {
        method wag   {args} {return "wag<$args>"}
        method droop {}     {return "droop"}
    }

    type dog {
        expose tail

        constructor {} {
            install tail using tail $self.tail
        }

        destructor {
            $tail destroy
        }
    }

    dog fido

    list [fido tail wag] [fido tail wag abc] [fido tail wag abc def] \
        [fido tail droop]
} -cleanup {
    dog destroy
    tail destroy
} -result {wag<> wag<abc> {wag<abc def>} droop}

#-----------------------------------------------------------------------
# Error handling
#
# This section verifies that errorInfo and errorCode are propagated
# appropriately on error.

test error-1.1 {typemethod errors propagate properly} -body {
    type dog {
        typemethod generr {} {
            error bogusError bogusInfo bogusCode
        }
    }

    catch {dog generr} result

    global errorInfo errorCode

    list $result [string match "*bogusInfo*" $errorInfo] $errorCode
} -cleanup {
    dog destroy
} -result {bogusError 1 bogusCode}

test error-1.2 {snit::type constructor errors propagate properly} -body {
    type dog {
        constructor {} {
            error bogusError bogusInfo bogusCode
        }
    }

    catch {dog fido} result

    global errorInfo errorCode

    list $result [string match "*bogusInfo*" $errorInfo] $errorCode
} -cleanup {
    dog destroy
} -result {{Error in constructor: bogusError} 1 bogusCode}

test error-1.3 {snit::widget constructor errors propagate properly} -constraints {
    tk
} -body {
    widget dog {
        constructor {args} {
            error bogusError bogusInfo bogusCode
        }
    }

    catch {dog .fido} result

    global errorInfo errorCode

    list $result [string match "*bogusInfo*" $errorInfo] $errorCode
} -cleanup {
    dog destroy
} -result {{Error in constructor: bogusError} 1 bogusCode}

test error-1.4 {method errors propagate properly} -body {
    type dog {
        method generr {} {
            error bogusError bogusInfo bogusCode
        }
    }

    dog fido
    catch {fido generr} result

    global errorInfo errorCode

    list $result [string match "*bogusInfo*" $errorInfo] $errorCode
} -cleanup {
    dog destroy
} -result {bogusError 1 bogusCode}

test error-1.5 {onconfigure errors propagate properly} -body {
    type dog {
        option -generr

        onconfigure -generr {value} {
            error bogusError bogusInfo bogusCode
        }
    }

    dog fido
    catch {fido configure -generr 0} result

    global errorInfo errorCode

    list $result [string match "*bogusInfo*" $errorInfo] $errorCode
} -cleanup {
    dog destroy
} -result {bogusError 1 bogusCode}

test error-1.6 {oncget errors propagate properly} -body {
    type dog {
        option -generr

        oncget -generr {
            error bogusError bogusInfo bogusCode
        }
    }

    dog fido
    catch {fido cget -generr} result

    global errorInfo errorCode

    list $result [string match "*bogusInfo*" $errorInfo] $errorCode
} -cleanup {
    dog destroy
} -result {bogusError 1 bogusCode}

#-----------------------------------------------------------------------
# Externally defined typemethods

test etypemethod-1.1 {external typemethods can be called as expected} -body {
    type dog { }
    typemethod dog foo {a} {return "+$a+"}

    dog foo bar
} -cleanup {
    dog destroy
} -result {+bar+}

test etypemethod-1.2 {external typemethods can use typevariables} -body {
    type dog {
        typevariable somevar "Howdy"
    }
    typemethod dog getvar {} {return $somevar}

    dog getvar
} -cleanup {
    dog destroy
} -result {Howdy}

test etypemethod-1.3 {typemethods can be redefined dynamically} -body {
    type dog {
        typemethod foo {} { return "foo" }
    }
    set a [dog foo]

    typemethod dog foo {} { return "bar"}

    set b [dog foo]

    list $a $b
} -cleanup {
    dog destroy
} -result {foo bar}

test etypemethod-1.4 {can't define external typemethod if no type} -body {
    typemethod extremelyraredog foo {} { return "bar"}
} -returnCodes {
    error
} -result {no such type: "extremelyraredog"}

test etypemethod-2.1 {external hierarchical method, two tokens} -body {
    type dog { }
    typemethod dog {wag tail} {} {
        return "wags tail"
    }

    dog wag tail
} -cleanup {
    dog destroy
} -result {wags tail}

test etypemethod-2.2 {external hierarchical method, three tokens} -body {
    type dog { }
    typemethod dog {wag tail proudly} {} {
        return "wags tail proudly"
    }

    dog wag tail proudly
} -cleanup {
    dog destroy
} -result {wags tail proudly}

test etypemethod-2.3 {external hierarchical method, three tokens} -body {
    type dog { }
    typemethod dog {wag tail really high} {} {
        return "wags tail really high"
    }

    dog wag tail really high
} -cleanup {
    dog destroy
} -result {wags tail really high}

test etypemethod-2.4 {redefinition is OK} -body {
    type dog { }
    typemethod dog {wag tail} {} {
        return "wags tail"
    }
    typemethod dog {wag tail} {} {
        return "wags tail briskly"
    }

    dog wag tail
} -cleanup {
    dog destroy
} -result {wags tail briskly}

test etypemethod-3.1 {prefix/method collision} -body {
    type dog {
        typemethod wag {} {}
    }

    typemethod dog {wag tail} {} {}
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result {Cannot define "wag tail", "wag" has no submethods.}

test etypemethod-3.2 {prefix/method collision} -body {
    type dog {
        typemethod {wag tail} {} {}
    }

    typemethod dog wag {} {}
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result {Cannot define "wag", "wag" has submethods.}

test etypemethod-3.3 {prefix/method collision} -body {
    type dog {
        typemethod {wag tail} {} {}
    }

    typemethod dog {wag tail proudly} {} {}
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result {Cannot define "wag tail proudly", "wag tail" has no submethods.}

test etypemethod-3.4 {prefix/method collision} -body {
    type dog {
        typemethod {wag tail proudly} {} {}
    }

    typemethod dog {wag tail} {} {}
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result {Cannot define "wag tail", "wag tail" has submethods.}

#-----------------------------------------------------------------------
# Externally defined methods

test emethod-1.1 {external methods can be called as expected} -body {
    type dog { }
    method dog bark {a} {return "+$a+"}

    dog spot
    spot bark woof
} -cleanup {
    dog destroy
} -result {+woof+}

test emethod-1.2 {external methods can use typevariables} -body {
    type dog {
        typevariable somevar "Hello"
    }
    method dog getvar {} {return $somevar}

    dog spot
    spot getvar
} -cleanup {
    dog destroy
} -result {Hello}

test emethod-1.3 {external methods can use variables} -body {
    type dog {
        variable somevar "Greetings"
    }
    method dog getvar {} {return $somevar}

    dog spot
    spot getvar
} -cleanup {
    dog destroy
} -result {Greetings}

test emethod-1.4 {methods can be redefined dynamically} -body {
    type dog {
        method bark {} { return "woof" }
    }

    dog spot

    set a [spot bark]

    method dog bark {} { return "arf"}

    set b [spot bark]

    list $a $b
} -cleanup {
    dog destroy
} -result {woof arf}

test emethod-1.5 {delegated methods can't be redefined} -body {
    type dog {
        delegate method bark to someotherdog
    }

    method dog bark {} { return "arf"}
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result {Cannot define "bark", "bark" has been delegated}

test emethod-1.6 {can't define external method if no type} -body {
    method extremelyraredog foo {} { return "bar"}
} -returnCodes {
    error
} -result {no such type: "extremelyraredog"}

test emethod-2.1 {external hierarchical method, two tokens} -body {
    type dog { }
    method dog {wag tail} {} {
        return "$self wags tail."
    }

    dog spot
    spot wag tail
} -cleanup {
    dog destroy
} -result {::spot wags tail.}

test emethod-2.2 {external hierarchical method, three tokens} -body {
    type dog { }
    method dog {wag tail proudly} {} {
        return "$self wags tail proudly."
    }

    dog spot
    spot wag tail proudly
} -cleanup {
    dog destroy
} -result {::spot wags tail proudly.}

test emethod-2.3 {external hierarchical method, three tokens} -body {
    type dog { }
    method dog {wag tail really high} {} {
        return "$self wags tail really high."
    }

    dog spot
    spot wag tail really high
} -cleanup {
    dog destroy
} -result {::spot wags tail really high.}

test emethod-2.4 {redefinition is OK} -body {
    type dog { }
    method dog {wag tail} {} {
        return "$self wags tail."
    }
    method dog {wag tail} {} {
        return "$self wags tail briskly."
    }

    dog spot
    spot wag tail
} -cleanup {
    dog destroy
} -result {::spot wags tail briskly.}

test emethod-3.1 {prefix/method collision} -body {
    type dog {
        method wag {} {}
    }

    method dog {wag tail} {} {
        return "$self wags tail."
    }
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result {Cannot define "wag tail", "wag" has no submethods.}

test emethod-3.2 {prefix/method collision} -body {
    type dog {
        method {wag tail} {} {
            return "$self wags tail."
        }
    }

    method dog wag {} {}
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result {Cannot define "wag", "wag" has submethods.}

test emethod-3.3 {prefix/method collision} -body {
    type dog {
        method {wag tail} {} {}
    }

    method dog {wag tail proudly} {} {
        return "$self wags tail."
    }
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result {Cannot define "wag tail proudly", "wag tail" has no submethods.}

test emethod-3.4 {prefix/method collision} -body {
    type dog {
        method {wag tail proudly} {} {
            return "$self wags tail."
        }
    }

    method dog {wag tail} {} {}
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result {Cannot define "wag tail", "wag tail" has submethods.}


#-----------------------------------------------------------------------
# Macros

test macro-1.1 {can't redefine non-macros} -body {
    snit::macro method {} {}
} -returnCodes {
    error
} -result {invalid macro name "method"}

test macro-1.2 {can define and use a macro} -body {
    snit::macro hello {name} {
        method hello {} "return {Hello, $name!}"
    }

    type dog {
        hello World
    }

    dog spot

    spot hello

} -cleanup {
    dog destroy
} -result {Hello, World!}

test macro-1.3 {can redefine macro} -body {
    snit::macro dup {} {}
    snit::macro dup {} {}

    set dummy "No error"
} -result {No error}

test macro-1.4 {can define macro in namespace} -body {
    snit::macro ::test::goodbye {name} {
        method goodbye {} "return {Goodbye, $name!}"
    }

    type dog {
        ::test::goodbye World
    }

    dog spot

    spot goodbye
} -cleanup {
    dog destroy
} -result {Goodbye, World!}

test macro-1.5 {_proc and _variable are defined} -body {
    snit::macro testit {} {
        set a [info commands _variable]
        set b [info commands _proc]
        method testit {} "list $a $b"
    }

    type dog {
        testit
    }

    dog spot

    spot testit
} -cleanup {
    dog destroy
} -result {_variable _proc}

test macro-1.6 {_variable works} -body {
    snit::macro test1 {} {
        _variable myvar "_variable works"
    }

    snit::macro test2 {} {
        _variable myvar

        method testit {} "return {$myvar}"
    }

    type dog {
        test1
        test2
    }

    dog spot

    spot testit
} -cleanup {
    dog destroy
} -result {_variable works}

#-----------------------------------------------------------------------
# Component Statement

test component-1.1 {component defines an instance variable} -body {
    type dog {
        component tail
    }

    dog spot

    namespace tail [spot info vars tail]
} -cleanup {
    dog destroy
} -result {tail}

test component-1.2 {-public exposes the component} -body {
    type tail {
        method wag {} {
            return "Wag, wag"
        }
    }

    type dog {
        component tail -public mytail

        constructor {} {
            set tail [tail %AUTO%]
        }
    }

    dog spot

    spot mytail wag
} -cleanup {
    dog destroy
    tail destroy
} -result {Wag, wag}

test component-1.3 {-inherit requires a boolean value} -body {
    type dog {
        component animal -inherit foo
    }
} -returnCodes {
    error
} -result {component animal -inherit: expected boolean value, got "foo"}

test component-1.4 {-inherit delegates unknown methods to the component} -body {
    type animal {
        method eat {} {
            return "Eat, eat."
        }
    }

    type dog {
        component animal -inherit yes

        constructor {} {
            set animal [animal %AUTO%]
        }
    }

    dog spot

    spot eat
} -cleanup {
    dog destroy
    animal destroy
} -result {Eat, eat.}

test component-1.5 {-inherit delegates unknown options to the component} -body {
    type animal {
        option -size medium
    }

    type dog {
        component animal -inherit yes

        constructor {} {
            set animal [animal %AUTO%]
        }
    }

    dog spot

    spot cget -size
} -cleanup {
    dog destroy
    animal destroy
} -result {medium}

#-----------------------------------------------------------------------
# Typevariables, Variables, Typecomponents, Components

test typevar_var-1.1 {variable/typevariable collisions not allowed: order 1} -body {
    type dog {
        typevariable var
        variable var
    }
} -returnCodes {
    error
} -result {Error in "variable var...", "var" is already a typevariable}

test typevar_var-1.2 {variable/typevariable collisions not allowed: order 2} -body {
    type dog {
        variable var
        typevariable var
    }
} -returnCodes {
    error
} -result {Error in "typevariable var...", "var" is already an instance variable}

test typevar_var-1.3 {component/typecomponent collisions not allowed: order 1} -body {
    type dog {
        typecomponent comp
        component comp
    }
} -returnCodes {
    error
} -result {Error in "component comp...", "comp" is already a typevariable}

test typevar_var-1.4 {component/typecomponent collisions not allowed: order 2} -body {
    type dog {
        component comp
        typecomponent comp
    }
} -returnCodes {
    error
} -result {Error in "typecomponent comp...", "comp" is already an instance variable}

test typevar_var-1.5 {can't delegate options to typecomponents} -body {
    type dog {
        typecomponent comp

        delegate option -opt to comp
    }
} -returnCodes {
    error
} -result {Error in "delegate option -opt...", "comp" is already a typevariable}

test typevar_var-1.6 {can't delegate typemethods to instance components} -body {
    type dog {
        component comp

        delegate typemethod foo to comp
    }
} -returnCodes {
    error
} -result {Error in "delegate typemethod foo...", "comp" is already an instance variable}

test typevar_var-1.7 {can delegate methods to typecomponents} -body {
    proc echo {args} {return [join $args "|"]}

    type dog {
        typecomponent tail

        typeconstructor {
            set tail echo
        }

        delegate method wag to tail
    }

    dog spot
    spot wag briskly
} -cleanup {
    dog destroy
    rename echo ""
} -result {wag|briskly}

#-----------------------------------------------------------------------
# Option syntax tests.
#
# This set of tests verifies that the option statement is interpreted
# properly, that errors are caught, and that the type's optionInfo
# array is initialized properly.
#
# TBD: At some point, this needs to be folded into the regular
# option tests.

test optionsyntax-1.1 {local option names are saved} -body {
    type dog {
        option -foo
        option -bar
    }

    set ::dog::Snit_optionInfo(local)
} -cleanup {
    dog destroy
} -result {-foo -bar}

test optionsyntax-1.2 {islocal flag is set} -body {
    type dog {
        option -foo
    }

    set ::dog::Snit_optionInfo(islocal--foo)
} -cleanup {
    dog destroy
} -result {1}

test optionsyntax-2.1 {implicit resource and class} -body {
    type dog {
        option -foo
    }

    list \
        $::dog::Snit_optionInfo(resource--foo) \
        $::dog::Snit_optionInfo(class--foo)
} -cleanup {
    dog destroy
} -result {foo Foo}

test optionsyntax-2.2 {explicit resource, default class} -body {
    type dog {
        option {-foo ffoo}
    }

    list \
        $::dog::Snit_optionInfo(resource--foo) \
        $::dog::Snit_optionInfo(class--foo)
} -cleanup {
    dog destroy
} -result {ffoo Ffoo}

test optionsyntax-2.3 {explicit resource and class} -body {
    type dog {
        option {-foo ffoo FFoo}
    }

    list \
        $::dog::Snit_optionInfo(resource--foo) \
        $::dog::Snit_optionInfo(class--foo)
} -cleanup {
    dog destroy
} -result {ffoo FFoo}

test optionsyntax-2.4 {can't redefine explicit resource} -body {
    type dog {
        option {-foo ffoo}
        option {-foo foo}
    }
} -returnCodes {
    error
} -result {Error in "option {-foo foo}...", resource name redefined from "ffoo" to "foo"}

test optionsyntax-2.5 {can't redefine explicit class} -body {
    type dog {
        option {-foo ffoo Ffoo}
        option {-foo ffoo FFoo}
    }
} -returnCodes {
    error
} -result {Error in "option {-foo ffoo FFoo}...", class name redefined from "Ffoo" to "FFoo"}

test optionsyntax-2.6 {can redefine implicit resource and class} -body {
    type dog {
        option -foo
        option {-foo ffoo}
        option {-foo ffoo FFoo}
        option -foo
    }
} -cleanup {
    dog destroy
} -result {::dog}

test optionsyntax-3.1 {no default value} -body {
    type dog {
        option -foo
    }

    set ::dog::Snit_optionInfo(default--foo)
} -cleanup {
    dog destroy
} -result {}

test optionsyntax-3.2 {default value, old syntax} -body {
    type dog {
        option -foo bar
    }

    set ::dog::Snit_optionInfo(default--foo)
} -cleanup {
    dog destroy
} -result {bar}

test optionsyntax-3.3 {option definition options can be set} -body {
    type dog {
        option -foo \
            -default Bar \
            -validatemethod Validate \
            -configuremethod Configure \
            -cgetmethod Cget \
            -readonly 1
    }

    list \
        $::dog::Snit_optionInfo(default--foo) \
        $::dog::Snit_optionInfo(validate--foo) \
        $::dog::Snit_optionInfo(configure--foo) \
        $::dog::Snit_optionInfo(cget--foo) \
        $::dog::Snit_optionInfo(readonly--foo)
} -cleanup {
    dog destroy
} -result {Bar Validate Configure Cget 1}

test optionsyntax-3.4 {option definition option values accumulate} -body {
    type dog {
        option -foo -default Bar
        option -foo -validatemethod Validate
        option -foo -configuremethod Configure
        option -foo -cgetmethod Cget
        option -foo -readonly 1
    }

    list \
        $::dog::Snit_optionInfo(default--foo) \
        $::dog::Snit_optionInfo(validate--foo) \
        $::dog::Snit_optionInfo(configure--foo) \
        $::dog::Snit_optionInfo(cget--foo) \
        $::dog::Snit_optionInfo(readonly--foo)
} -cleanup {
    dog destroy
} -result {Bar Validate Configure Cget 1}

test optionsyntax-3.5 {option definition option values can be redefined} -body {
    type dog {
        option -foo -default Bar
        option -foo -validatemethod Validate
        option -foo -configuremethod Configure
        option -foo -cgetmethod Cget
        option -foo -readonly 1
        option -foo -default Bar2
        option -foo -validatemethod Validate2
        option -foo -configuremethod Configure2
        option -foo -cgetmethod Cget2
        option -foo -readonly 0
    }

    list \
        $::dog::Snit_optionInfo(default--foo) \
        $::dog::Snit_optionInfo(validate--foo) \
        $::dog::Snit_optionInfo(configure--foo) \
        $::dog::Snit_optionInfo(cget--foo) \
        $::dog::Snit_optionInfo(readonly--foo)
} -cleanup {
    dog destroy
} -result {Bar2 Validate2 Configure2 Cget2 0}

test optionsyntax-3.6 {option -readonly defaults to 0} -body {
    type dog {
        option -foo
    }

    set ::dog::Snit_optionInfo(readonly--foo)
} -cleanup {
    dog destroy
} -result {0}

test optionsyntax-3.7 {option -readonly can be any boolean} -body {
    type dog {
        option -foo -readonly 0
        option -foo -readonly 1
        option -foo -readonly y
        option -foo -readonly n
    }
} -cleanup {
    dog destroy
} -result {::dog}

test optionsyntax-3.8 {option -readonly must be a boolean} -body {
    type dog {
        option -foo -readonly foo
    }
} -returnCodes {
    error
} -result {Error in "option -foo...", -readonly requires a boolean, got "foo"}

test optionsyntax-3.9 {option -readonly can't be empty} -body {
    type dog {
        option -foo -readonly {}
    }
} -returnCodes {
    error
} -result {Error in "option -foo...", -readonly requires a boolean, got ""}

#-----------------------------------------------------------------------
# 'delegate option' Syntax tests.
#
# This set of tests verifies that the 'delegation option' statement is
# interpreted properly, and that the type's optionInfo
# array is initialized properly.
#
# TBD: At some point, this needs to be folded into the regular
# option tests.

test delegateoptionsyntax-1.1 {'delegated' lists delegated option names} -body {
    type dog {
        delegate option -foo to comp
        delegate option -bar to comp
    }

    set ::dog::Snit_optionInfo(delegated)
} -cleanup {
    dog destroy
} -result {-foo -bar}

test delegateoptionsyntax-1.2 {'delegated' does not include '*'} -body {
    type dog {
        delegate option * to comp
    }

    set ::dog::Snit_optionInfo(delegated)
} -cleanup {
    dog destroy
} -result {}

test delegateoptionsyntax-1.3 {'islocal' is set to 0} -body {
    type dog {
        delegate option -foo to comp
    }

    set ::dog::Snit_optionInfo(islocal--foo)
} -cleanup {
    dog destroy
} -result {0}

test delegateoptionsyntax-1.4 {'islocal' is not set for '*'} -body {
    type dog {
        delegate option * to comp
    }

    info exists ::dog::Snit_optionInfo(islocal-*)
} -cleanup {
    dog destroy
} -result {0}

test delegateoptionsyntax-1.5 {'delegated-$comp' lists options for the component} -body {
    type dog {
        delegate option -foo to comp1
        delegate option -bar to comp1
        delegate option -baz to comp2

        # The * won't show up.
        delegate option * to comp2
    }

    list \
        $::dog::Snit_optionInfo(delegated-comp1) \
        $::dog::Snit_optionInfo(delegated-comp2)
} -cleanup {
    dog destroy
} -result {{-foo -bar} -baz}

test delegateoptionsyntax-1.6 {'except' is empty by default} -body {
    type dog {
        delegate option -foo to comp
    }

    set ::dog::Snit_optionInfo(except)
} -cleanup {
    dog destroy
} -result {}

test delegateoptionsyntax-1.7 {'except' lists exceptions} -body {
    type dog {
        delegate option * to comp except {-foo -bar -baz}
    }

    set ::dog::Snit_optionInfo(except)
} -cleanup {
    dog destroy
} -result {-foo -bar -baz}

test delegateoptionsyntax-1.8 {'target-$opt' set with default} -body {
    type dog {
        delegate option -foo to comp
    }

    set ::dog::Snit_optionInfo(target--foo)
} -cleanup {
    dog destroy
} -result {comp -foo}

test delegateoptionsyntax-1.9 {'target-$opt' set explicitly} -body {
    type dog {
        delegate option -foo to comp as -bar
    }

    set ::dog::Snit_optionInfo(target--foo)
} -cleanup {
    dog destroy
} -result {comp -bar}

test delegateoptionsyntax-1.10 {'starcomp' is {} by default} -body {
    type dog {
        delegate option -foo to comp
    }

    set ::dog::Snit_optionInfo(starcomp)
} -cleanup {
    dog destroy
} -result {}

test delegateoptionsyntax-1.11 {'starcomp' set for *} -body {
    type dog {
        delegate option * to comp
    }

    set ::dog::Snit_optionInfo(starcomp)
} -cleanup {
    dog destroy
} -result {comp}

test delegatedoptionsyntax-2.1 {implicit resource and class} -body {
    type dog {
        delegate option -foo to comp
    }

    list \
        $::dog::Snit_optionInfo(resource--foo) \
        $::dog::Snit_optionInfo(class--foo)
} -cleanup {
    dog destroy
} -result {foo Foo}

test delegatedoptionsyntax-2.2 {explicit resource, default class} -body {
    type dog {
        delegate option {-foo ffoo} to comp
    }

    list \
        $::dog::Snit_optionInfo(resource--foo) \
        $::dog::Snit_optionInfo(class--foo)
} -cleanup {
    dog destroy
} -result {ffoo Ffoo}

test delegatedoptionsyntax-2.3 {explicit resource and class} -body {
    type dog {
        delegate option {-foo ffoo FFoo} to comp
    }

    list \
        $::dog::Snit_optionInfo(resource--foo) \
        $::dog::Snit_optionInfo(class--foo)
} -cleanup {
    dog destroy
} -result {ffoo FFoo}

test delegatedoptionsyntax-2.4 {* doesn't get resource and class} -body {
    type dog {
        delegate option * to comp
    }

    list \
        [info exist ::dog::Snit_optionInfo(resource-*)] \
        [info exist ::dog::Snit_optionInfo(class-*)]
} -cleanup {
    dog destroy
} -result {0 0}

#-----------------------------------------------------------------------
# Cget cache

test cgetcache-1.1 {Instance rename invalidates cache} -body {
    type dog {
        option -foo -default bar -cgetmethod getfoo

        method getfoo {option} {
            return $options($option)
        }
    }

    dog fido -foo quux

    # Cache the cget command.
    fido cget -foo

    rename fido spot

    spot cget -foo
} -cleanup {
    dog destroy
} -result {quux}

test cgetcache-1.2 {Component rename invalidates cache} -body {
    type tail {
        option -foo bar
    }

    type dog {
        delegate option -foo to tail

        constructor {args} {
            set tail [tail %AUTO%]
            $tail configure -foo quux
        }

        method retail {} {
            set tail [tail %AUTO%]
        }
    }

    dog fido

    # Cache the cget command.
    fido cget -foo

    # Invalidate the cache
    fido retail

    fido cget -foo
} -cleanup {
    dog destroy
    tail destroy
} -result {bar}

# case 1
test cgetcache-1.3 {Invalid -cgetmethod causes error} -constraints {
    snit1
} -body {
    type dog {
        option -foo -default bar -cgetmethod bogus
    }

    dog fido -foo quux

    fido cget -foo
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result {can't cget -foo, "::fido bogus" is not defined}

# case 2
test cgetcache-1.4 {Invalid -cgetmethod causes error} -constraints {
    snit2
} -body {
    type dog {
        option -foo -default bar -cgetmethod bogus
    }

    dog fido -foo quux

    fido cget -foo
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result {unknown subcommand "bogus": must be cget, or configurelist}

test cgetcache-1.5 {hierarchical -cgetmethod} -body {
    type dog {
        option -foo -default bar -cgetmethod {Get Opt}

        method {Get Opt} {option} {
            return Dummy
        }
    }

    dog fido

    fido cget -foo
} -cleanup {
    dog destroy
} -result {Dummy}

#-----------------------------------------------------------------------
# Configure cache

test configurecache-1.1 {Instance rename invalidates cache} -body {
    type dog {
        option -foo -default bar -configuremethod setfoo

        method setfoo {option value} {
            $self setoption $option $value
        }

        method setoption {option value} {
            set options($option) $value
        }
    }

    # Set the option on creation; this will cache the
    # configure command.
    dog fido -foo quux

    rename fido spot

    spot configure -foo baz
    spot cget -foo
} -cleanup {
    dog destroy
} -result {baz}

test configurecache-1.2 {Component rename invalidates cache} -body {
    type tail {
        option -foo bar
    }

    type dog {
        delegate option -foo to tail

        constructor {args} {
            set tail [tail thistail]
            $self configurelist $args
        }

        method retail {} {
            # Give it a new component
            set tail [tail thattail]
        }
    }

    # Set the tail's -foo, and cache the command.
    dog fido -foo quux

    # Invalidate the cache
    fido retail

    # Should recache, and set the new tail's option.
    fido configure -foo baz

    fido cget -foo
} -cleanup {
    dog destroy
    tail destroy
} -result {baz}

# Case 1
test configurecache-1.3 {Invalid -configuremethod causes error} -constraints {
    snit1
} -body {
    type dog {
        option -foo -default bar -configuremethod bogus
    }

    dog fido
    fido configure -foo quux
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result {can't configure -foo, "::fido bogus" is not defined}

# Case 2
test configurecache-1.4 {Invalid -configuremethod causes error} -constraints {
    snit2
} -body {
    type dog {
        option -foo -default bar -configuremethod bogus
    }

    dog fido
    fido configure -foo quux
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result {unknown subcommand "bogus": must be configure, or configurelist}

test configurecache-1.5 {hierarchical -configuremethod} -body {
    type dog {
        option -foo -default bar -configuremethod {Set Opt}

        method {Set Opt} {option value} {
            set options($option) Dummy
        }
    }

    dog fido -foo NotDummy
    fido cget -foo
} -cleanup {
    dog destroy
} -result {Dummy}



#-----------------------------------------------------------------------
# option -validatemethod

test validatemethod-1.1 {Validate method is called} -body {
    type dog {
        variable flag 0

        option -color \
            -default black \
            -validatemethod ValidateColor

        method ValidateColor {option value} {
            set flag 1
        }

        method getflag {} {
            return $flag
        }
    }

    dog fido -color brown
    fido getflag
} -cleanup {
    dog destroy
} -result {1}

test validatemethod-1.2 {Validate method gets correct arguments} -body {
    type dog {
        option -color \
            -default black \
            -validatemethod ValidateColor

        method ValidateColor {option value} {
            if {![string equal $option "-color"] ||
                ![string equal $value "brown"]} {
                error "Expected '-color brown'"
            }
        }
    }

    dog fido -color brown
} -cleanup {
    dog destroy
} -result {::fido}

# Case 1
test validatemethod-1.3 {Invalid -validatemethod causes error} -constraints {
    snit1
} -body {
    type dog {
        option -foo -default bar -validatemethod bogus
    }

    dog fido
    fido configure -foo quux
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result {can't validate -foo, "::fido bogus" is not defined}

# Case 2
test validatemethod-1.4 {Invalid -validatemethod causes error} -constraints {
    snit2
} -body {
    type dog {
        option -foo -default bar -validatemethod bogus
    }

    dog fido
    fido configure -foo quux
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result {unknown subcommand "bogus": must be configure, or configurelist}

test validatemethod-1.5 {hierarchical -validatemethod} -body {
    type dog {
        option -foo -default bar -validatemethod {Val Opt}

        method {Val Opt} {option value} {
            error "Dummy"
        }
    }

    dog fido -foo value
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result {Error in constructor: Dummy}



#-----------------------------------------------------------------------
# option -readonly semantics

test optionreadonly-1.1 {Readonly options can be set at creation time} -body {
    type dog {
        option -color \
            -default black \
            -readonly true
    }

    dog fido -color brown

    fido cget -color
} -cleanup {
    dog destroy
} -result {brown}

test optionreadonly-1.2 {Readonly options can't be set after creation} -body {
    type dog {
        option -color \
            -default black \
            -readonly true
    }

    dog fido

    fido configure -color brown
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result {option -color can only be set at instance creation}

test optionreadonly-1.3 {Readonly options can't be set after creation} -body {
    type dog {
        option -color \
            -default black \
            -readonly true
    }

    dog fido -color yellow

    fido configure -color brown
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result {option -color can only be set at instance creation}

#-----------------------------------------------------------------------
# Pragma -hastypeinfo

test hastypeinfo-1.1 {$type info is defined by default} -body {
    type dog {
        typevariable foo
    }

    dog info typevars
} -cleanup {
    dog destroy
} -result {::dog::foo}

# Case 1
test hastypeinfo-1.2 {$type info can be disabled} -constraints {
    snit1
} -body {
    type dog {
        pragma -hastypeinfo no
        typevariable foo
    }

    dog info typevars
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result {"::dog info" is not defined}

# Case 2
test hastypeinfo-1.3 {$type info can be disabled} -constraints {
    snit2
} -body {
    type dog {
        pragma -hastypeinfo no
        typevariable foo
    }

    dog info typevars
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result {unknown subcommand "info": namespace ::dog does not export any commands}


#-----------------------------------------------------------------------
# Pragma -hastypedestroy

test hastypedestroy-1.1 {$type destroy is defined by default} -body {
    type dog {
        typevariable foo
    }

    dog destroy

    ::dog info typevars
} -returnCodes {
    error
} -result {invalid command name "::dog"}

# Case 1
test hastypedestroy-1.2 {$type destroy can be disabled} -constraints {
    snit1
} -body {
    type dog {
        pragma -hastypedestroy no
        typevariable foo
    }

    dog destroy
} -returnCodes {
    error
} -cleanup {
    rename ::dog ""
    namespace delete ::dog
} -result {"::dog destroy" is not defined}

# Case 2
test hastypedestroy-1.3 {$type destroy can be disabled} -constraints {
    snit2
} -body {
    type dog {
        pragma -hastypedestroy no
        typevariable foo
    }

    dog destroy
} -returnCodes {
    error
} -cleanup {
    rename ::dog ""
    namespace delete ::dog
} -result {unknown subcommand "destroy": namespace ::dog does not export any commands}

#-----------------------------------------------------------------------
# Pragma -hasinstances

test hasinstances-1.1 {-hasinstances is true by default} -body {
    type dog {
        method bark {} {
            return "Woof"
        }
    }

    dog fido
    fido bark
} -cleanup {
    dog destroy
} -result {Woof}

# Case 1
test hasinstances-1.2 {'-hasinstances no' disables explicit object creation} -constraints {
    snit1
} -body {
    type dog {
        pragma -hasinstances no
    }

    dog create fido
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result {"::dog create" is not defined}

# Case 2
test hasinstances-1.3 {'-hasinstances no' disables explicit object creation} -constraints {
    snit2
} -body {
    type dog {
        pragma -hasinstances no
    }

    dog create fido
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result {unknown subcommand "create": namespace ::dog does not export any commands}

# Case 1
test hasinstances-1.4 {'-hasinstances no' disables implicit object creation} -constraints {
    snit1
} -body {
    type dog {
        pragma -hasinstances no
    }

    dog fido
} -returnCodes {
    error
} -result {"::dog fido" is not defined}

# Case 2
test hasinstances-1.5 {'-hasinstances no' disables implicit object creation} -constraints {
    snit2
} -body {
    type dog {
        pragma -hasinstances no
    }

    dog fido
} -returnCodes {
    error
} -result {unknown subcommand "fido": namespace ::dog does not export any commands}

#-----------------------------------------------------------------------
# pragma -canreplace

test canreplace-1.1 {By default, "-canreplace no"} -body {
    type dog {
        # ...
    }

    dog fido
    dog fido
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result {command "::fido" already exists}

test canreplace-1.2 {Can replace commands when "-canreplace yes"} -constraints {
    bug8.5a3
} -body {
    type dog {
        pragma -canreplace yes
    }

    dog fido
    dog fido
} -cleanup {
    dog destroy
} -result {::fido}

#-----------------------------------------------------------------------
# pragma -hasinfo

test hasinfo-1.1 {$obj info is defined by default} -body {
    type dog {
        variable foo ""
    }

    dog spot
    spot info vars
} -cleanup {
    dog destroy
} -result {::dog::Snit_inst1::foo}

# Case 1
test hasinfo-1.2 {$obj info can be disabled} -constraints {
    snit1
} -body {
    type dog {
        pragma -hasinfo no
        variable foo
    }

    dog spot
    spot info vars
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result {"::spot info" is not defined}

# Case 2
test hasinfo-1.3 {$obj info can be disabled} -constraints {
    snit2
} -body {
    type dog {
        pragma -hasinfo no
        variable foo
    }

    dog spot
    spot info vars
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result {unknown subcommand "info": namespace ::dog::Snit_inst1 does not export any commands}

#-----------------------------------------------------------------------
# pragma -hastypemethods
#
# The "-hastypemethods yes" case is tested by the bulk of this file.
# We'll test the "-hastypemethods no" case here.

test hastypemethods-1.1 {-hastypemethods no, $type foo creates instance.} -body {
    type dog {
        pragma -hastypemethods no
        variable foo
    }

    dog spot
} -cleanup {
    spot destroy
    rename ::dog ""
    namespace delete ::dog
} -result {::spot}

test hastypemethods-1.2 {-hastypemethods no, $type create foo fails.} -body {
    type dog {
	pragma -hastypemethods no
	variable foo
    }

    dog create spot
} -returnCodes {
    error
} -cleanup {
    rename ::dog ""
    namespace delete ::dog
} -result "Error in constructor: [tcltest::tooManyArgs ::dog::Snit_constructor {type selfns win self}]"

test hastypemethods-1.3 {-hastypemethods no, $type info fails.} -body {
    type dog {
        pragma -hastypemethods no
        variable foo
    }

    dog info
} -returnCodes {
    error
} -cleanup {
    rename ::dog ""
    namespace delete ::dog
} -result {command "::info" already exists}

test hastypemethods-1.4 {-hastypemethods no, [$widget] fails.} -constraints {
    tk
} -body {
    widget dog {
        pragma -hastypemethods no
        variable foo
    }

    dog
} -returnCodes {
    error
} -cleanup {
    rename ::dog ""
    namespace delete ::dog
} -result {wrong # args: should be "::dog name args"}

test hastypemethods-1.5 {-hastypemethods no, -hasinstances no fails.} -body {
    type dog {
        pragma -hastypemethods no
        pragma -hasinstances no
        variable foo
    }
} -returnCodes {
    error
} -result {type ::dog has neither typemethods nor instances}

#-----------------------------------------------------------------------
# -simpledispatch yes

test simpledispatch-1.1 {not allowed with method delegation.} -constraints {
    snit1
} -body {
    type dog {
        pragma -simpledispatch yes

        delegate method foo to bar
    }
} -returnCodes {
    error
} -result {type ::dog requests -simpledispatch but delegates methods.}

test simpledispatch-1.2 {normal methods work with simpledispatch.} -constraints {
    snit1
} -body {
    type dog {
        pragma -simpledispatch yes

        method barks {how} {
            return "$self barks $how."
        }
    }

    dog spot
    spot barks loudly
} -cleanup {
    dog destroy
} -result {::spot barks loudly.}

test simpledispatch-1.3 {option methods work with simpledispatch.} -constraints {
    snit1
} -body {
    type dog {
        pragma -simpledispatch yes

        option -breed mutt
    }

    dog spot
    set a [spot cget -breed]
    spot configure -breed collie
    set b [spot cget -breed]
    spot configurelist [list -breed sheltie]
    set c [spot cget -breed]

    list $a $b $c
} -cleanup {
    dog destroy
} -result {mutt collie sheltie}

test simpledispatch-1.4 {info method works with simpledispatch.} -constraints {
    snit1
} -body {
    type dog {
        pragma -simpledispatch yes

        option -breed mutt
    }

    dog spot

    spot info options
} -cleanup {
    dog destroy
} -result {-breed}

test simpledispatch-1.5 {destroy method works with simpledispatch.} -constraints {
    snit1
} -body {
    type dog {
        pragma -simpledispatch yes

        option -breed mutt
    }

    dog spot
    set a [info commands ::spot]
    spot destroy
    set b [info commands ::spot]
    list $a $b
} -cleanup {
    dog destroy
} -result {::spot {}}

test simpledispatch-1.6 {no hierarchical methods with simpledispatch.} -constraints {
    snit1
} -body {
    type dog {
        pragma -simpledispatch yes

        method {wag tail} {} {}
    }
} -returnCodes {
    error
} -result {type ::dog requests -simpledispatch but defines hierarchical methods.}

#-----------------------------------------------------------------------
# Exotic return codes

test break-1.1 {Methods can "return -code break"} -body {
    snit::type dog {
        method bark {} {return -code break "Breaking"}
    }

    dog spot

    catch {spot bark} result
} -cleanup {
    dog destroy
} -result {3}

test break-1.2 {Typemethods can "return -code break"} -body {
    snit::type dog {
        typemethod bark {} {return -code break "Breaking"}
    }

    catch {dog bark} result
} -cleanup {
    dog destroy
} -result {3}

test break-1.3 {Methods called via mymethod "return -code break"} -body {
    snit::type dog {
        method bark {} {return -code break "Breaking"}

        method getbark {} {
            return [mymethod bark]
        }
    }

    dog spot

    catch {uplevel \#0 [spot getbark]} result
} -cleanup {
    dog destroy
} -result {3}

#-----------------------------------------------------------------------
# Namespace path

test nspath-1.1 {Typemethods call commands from parent namespace} -constraints {
    snit2
} -body {
    namespace eval ::snit_test:: {
        proc bark {} {return "[namespace current]: Woof"}
    }

    snit::type ::snit_test::dog {
        typemethod bark {} {
            bark
        }
    }

    ::snit_test::dog bark
} -cleanup {
    ::snit_test::dog destroy
    namespace forget ::snit_test
} -result {::snit_test: Woof}

test nspath-1.2 {Methods can call commands from parent namespace} -constraints {
    snit2
} -body {
    namespace eval ::snit_test:: {
        proc bark {} {return "[namespace current]: Woof"}
    }

    snit::type ::snit_test::dog {
        method bark {} {
            bark
        }
    }

    ::snit_test::dog spot
    spot bark
} -cleanup {
    ::snit_test::dog destroy
    namespace forget ::snit_test
} -result {::snit_test: Woof}

#-----------------------------------------------------------------------
# snit::boolean

test boolean-1.1 {boolean: valid} -body {
    snit::boolean validate 1
    snit::boolean validate 0
    snit::boolean validate true
    snit::boolean validate false
    snit::boolean validate yes
    snit::boolean validate no
    snit::boolean validate on
    snit::boolean validate off
} -result {off}

test boolean-1.2 {boolean: invalid} -body {
    codecatch {snit::boolean validate quux}
} -result {INVALID invalid boolean "quux", should be one of: 1, 0, true, false, yes, no, on, off}

test boolean-2.1 {boolean subtype: valid} -body {
    snit::boolean subtype
    subtype validate 1
    subtype validate 0
    subtype validate true
    subtype validate false
    subtype validate yes
    subtype validate no
    subtype validate on
    subtype validate off
} -cleanup {
    subtype destroy
} -result {off}

test boolean-2.2 {boolean subtype: invalid} -body {
    snit::boolean subtype
    codecatch {subtype validate quux}
} -cleanup {
    subtype destroy
} -result {INVALID invalid boolean "quux", should be one of: 1, 0, true, false, yes, no, on, off}

#-----------------------------------------------------------------------
# snit::double

test double-1.1 {double: invalid -min} -body {
    snit::double obj -min abc
} -returnCodes {
    error
} -result {Error in constructor: invalid -min: "abc"}

test double-1.2 {double: invalid -max} -body {
    snit::double obj -max abc
} -returnCodes {
    error
} -result {Error in constructor: invalid -max: "abc"}

test double-1.3 {double: invalid, max < min} -body {
    snit::double obj -min 5 -max 0
} -returnCodes {
    error
} -result {Error in constructor: -max < -min}

test double-2.1 {double type: valid} -body {
    snit::double validate 1.5
} -result {1.5}

test double-2.2 {double type: invalid} -body {
    codecatch {snit::double validate abc}
} -result {INVALID invalid value "abc", expected double}

test double-3.1 {double subtype: valid, no range} -body {
    snit::double subtype
    subtype validate 1.5
} -cleanup {
    subtype destroy
} -result {1.5}

test double-3.2 {double subtype: valid, min but no max} -body {
    snit::double subtype -min 0.5
    subtype validate 1
} -cleanup {
    subtype destroy
} -result {1}

test double-3.3 {double subtype: valid, min and max} -body {
    snit::double subtype -min 0.5 -max 10.5
    subtype validate 1.5
} -cleanup {
    subtype destroy
} -result {1.5}

test double-4.1 {double subtype: not a number} -body {
    snit::double subtype
    codecatch {subtype validate quux}
} -cleanup {
    subtype destroy
} -result {INVALID invalid value "quux", expected double}

test double-4.2 {double subtype: less than min, no max} -body {
    snit::double subtype -min 0.5
    codecatch {subtype validate -1}
} -cleanup {
    subtype destroy
} -result {INVALID invalid value "-1", expected double no less than 0.5}

test double-4.3 {double subtype: less than min, with max} -body {
    snit::double subtype -min 0.5 -max 5.5
    codecatch {subtype validate -1}
} -cleanup {
    subtype destroy
} -result {INVALID invalid value "-1", expected double in range 0.5, 5.5}

#-----------------------------------------------------------------------
# snit::enum

test enum-1.1 {enum: valid} -body {
    snit::enum validate foo
} -result {foo}

test enum-2.1 {enum subtype: missing -values} -body {
    snit::enum subtype
} -returnCodes {
    error
} -result {Error in constructor: invalid -values: ""}

test enum-3.1 {enum subtype: valid} -body {
    snit::enum subtype -values {foo bar baz}
    subtype validate foo
    subtype validate bar
    subtype validate baz
} -cleanup {
    subtype destroy
} -result {baz}

test enum-3.2 {enum subtype: invalid} -body {
    snit::enum subtype -values {foo bar baz}
    codecatch {subtype validate quux}
} -cleanup {
    subtype destroy
} -result {INVALID invalid value "quux", should be one of: foo, bar, baz}


#-----------------------------------------------------------------------
# snit::fpixels

test fpixels-1.1 {no suffix} -constraints tk -body {
    snit::fpixels validate 5
} -result {5}

test fpixels-1.2 {suffix} -constraints tk -body {
    snit::fpixels validate 5i
} -result {5i}

test fpixels-1.3 {decimal} -constraints tk -body {
    snit::fpixels validate 5.5
} -result {5.5}

test fpixels-1.4 {invalid} -constraints tk -body {
    codecatch {snit::fpixels validate 5.5abc}
} -result {INVALID invalid value "5.5abc", expected fpixels}

test fpixels-2.1 {bad -min} -constraints tk -body {
    snit::fpixels subtype -min abc
} -returnCodes {
    error
} -result {Error in constructor: invalid -min: "abc"}

test fpixels-2.2 {bad -max} -constraints tk -body {
    snit::fpixels subtype -max abc
} -returnCodes {
    error
} -result {Error in constructor: invalid -max: "abc"}

test fpixels-2.3 {-min > -max} -constraints tk -body {
    snit::fpixels subtype -min 10 -max 5
} -returnCodes {
    error
} -result {Error in constructor: -max < -min}

test fpixels-3.1 {subtype, no suffix} -constraints tk -body {
    snit::fpixels subtype
    subtype validate 5
} -cleanup {
    subtype destroy
} -result {5}

test fpixels-3.2 {suffix} -constraints tk -body {
    snit::fpixels subtype
    subtype validate 5i
} -cleanup {
    subtype destroy
} -result {5i}

test fpixels-3.3 {decimal} -constraints tk -body {
    snit::fpixels subtype
    subtype validate 5.5
} -cleanup {
    subtype destroy
} -result {5.5}

test fpixels-3.4 {invalid} -constraints tk -body {
    snit::fpixels subtype
    codecatch {subtype validate 5.5abc}
} -cleanup {
    subtype destroy
} -result {INVALID invalid value "5.5abc", expected fpixels}


test fpixels-3.5 {subtype -min} -constraints tk -body {
    snit::fpixels subtype -min 5
    subtype validate 10
} -cleanup {
    subtype destroy
} -result {10}

test fpixels-3.6 {min of min, max} -constraints tk -body {
    snit::fpixels subtype -min 5 -max 20
    subtype validate 5
} -cleanup {
    subtype destroy
} -result {5}

test fpixels-3.7 {max of min, max} -constraints tk -body {
    snit::fpixels subtype -min 5 -max 20
    subtype validate 20
} -cleanup {
    subtype destroy
} -result {20}

test fpixels-3.8 {middle of min, max} -constraints tk -body {
    snit::fpixels subtype -min 5 -max 20
    subtype validate 15
} -cleanup {
    subtype destroy
} -result {15}

test fpixels-3.9 {invalid, < min} -constraints tk -body {
    snit::fpixels subtype -min 5
    codecatch {subtype validate 4}
} -cleanup {
    subtype destroy
} -result {INVALID invalid value "4", expected fpixels no less than 5}

test fpixels-3.10 {invalid, > max} -constraints tk -body {
    snit::fpixels subtype -min 5 -max 20
    codecatch {subtype validate 21}
} -cleanup {
    subtype destroy
} -result {INVALID invalid value "21", expected fpixels in range 5, 20}

test fpixels-3.11 {invalid, > max, range with suffix} -constraints tk -body {
    snit::fpixels subtype -min 5i -max 10i
    codecatch {subtype validate 11i}
} -cleanup {
    subtype destroy
} -result {INVALID invalid value "11i", expected fpixels in range 5i, 10i}

#-----------------------------------------------------------------------
# snit::integer

test integer-1.1 {integer: invalid -min} -body {
    snit::integer obj -min abc
} -returnCodes {
    error
} -result {Error in constructor: invalid -min: "abc"}

test integer-1.2 {integer: invalid -max} -body {
    snit::integer obj -max abc
} -returnCodes {
    error
} -result {Error in constructor: invalid -max: "abc"}

test integer-1.3 {integer: invalid, max < min} -body {
    snit::integer obj -min 5 -max 0
} -returnCodes {
    error
} -result {Error in constructor: -max < -min}

test integer-2.1 {integer type: valid} -body {
    snit::integer validate 1
} -result {1}

test integer-2.2 {integer type: invalid} -body {
    codecatch {snit::integer validate abc}
} -result {INVALID invalid value "abc", expected integer}

test integer-3.1 {integer subtype: valid, no range} -body {
    snit::integer subtype
    subtype validate 1
} -cleanup {
    subtype destroy
} -result {1}

test integer-3.2 {integer subtype: valid, min but no max} -body {
    snit::integer subtype -min 0
    subtype validate 1
} -cleanup {
    subtype destroy
} -result {1}

test integer-3.3 {integer subtype: valid, min and max} -body {
    snit::integer subtype -min 0 -max 10
    subtype validate 1
} -cleanup {
    subtype destroy
} -result {1}

test integer-4.1 {integer subtype: not a number} -body {
    snit::integer subtype
    codecatch {subtype validate quux}
} -cleanup {
    subtype destroy
} -result {INVALID invalid value "quux", expected integer}

test integer-4.2 {integer subtype: less than min, no max} -body {
    snit::integer subtype -min 0
    codecatch {subtype validate -1}
} -cleanup {
    subtype destroy
} -result {INVALID invalid value "-1", expected integer no less than 0}

test integer-4.3 {integer subtype: less than min, with max} -body {
    snit::integer subtype -min 0 -max 5
    codecatch {subtype validate -1}
} -cleanup {
    subtype destroy
} -result {INVALID invalid value "-1", expected integer in range 0, 5}

#-----------------------------------------------------------------------
# snit::listtype

test listtype-1.1 {listtype, length 0; valid} -body {
    snit::listtype validate ""
} -result {}

test listtype-1.2 {listtype, length 1; valid} -body {
    snit::listtype validate a
} -result {a}

test listtype-1.3 {listtype, length 2; valid} -body {
    snit::listtype validate {a b}
} -result {a b}

test listtype-2.1 {listtype subtype, length 0; valid} -body {
    snit::listtype subtype
    subtype validate ""
} -cleanup {
    subtype destroy
} -result {}

test listtype-2.2 {listtype, length 1; valid} -body {
    snit::listtype subtype
    subtype validate a
} -cleanup {
    subtype destroy
} -result {a}

test listtype-2.3 {listtype, length 2; valid} -body {
    snit::listtype subtype
    subtype validate {a b}
} -cleanup {
    subtype destroy
} -result {a b}

test listtype-2.4 {listtype, invalid -minlen} -body {
    snit::listtype subtype -minlen abc
} -returnCodes {
    error
} -result {Error in constructor: invalid -minlen: "abc"}

test listtype-2.5 {listtype, negative -minlen} -body {
    snit::listtype subtype -minlen -1
} -returnCodes {
    error
} -result {Error in constructor: invalid -minlen: "-1"}

test listtype-2.6 {listtype, invalid -maxlen} -body {
    snit::listtype subtype -maxlen abc
} -returnCodes {
    error
} -result {Error in constructor: invalid -maxlen: "abc"}

test listtype-2.7 {listtype, -maxlen < -minlen} -body {
    snit::listtype subtype -minlen 10 -maxlen 9
} -returnCodes {
    error
} -result {Error in constructor: -maxlen < -minlen}

test listtype-3.1 {-minlen 2, length 2; valid} -body {
    snit::listtype subtype -minlen 2 
    subtype validate {a b}
} -cleanup {
    subtype destroy
} -result {a b}

test listtype-3.2 {-minlen 2, length 3; valid} -body {
    snit::listtype subtype -minlen 2 
    subtype validate {a b c}
} -cleanup {
    subtype destroy
} -result {a b c}

test listtype-3.3 {-minlen 2, length 1; invalid} -body {
    snit::listtype subtype -minlen 2 
    codecatch {subtype validate a}
} -cleanup {
    subtype destroy
} -result {INVALID value has too few elements; at least 2 expected}

test listtype-3.4 {range 1 to 3, length 1; valid} -body {
    snit::listtype subtype -minlen 1 -maxlen 3
    subtype validate a
} -cleanup {
    subtype destroy
} -result {a}

test listtype-3.5 {range 1 to 3, length 3; valid} -body {
    snit::listtype subtype -minlen 1 -maxlen 3
    subtype validate {a b c}
} -cleanup {
    subtype destroy
} -result {a b c}

test listtype-3.6 {range 1 to 3, length 0; invalid} -body {
    snit::listtype subtype -minlen 1 -maxlen 3
    codecatch {subtype validate {}}
} -cleanup {
    subtype destroy
} -result {INVALID value has too few elements; at least 1 expected}

test listtype-3.7 {range 1 to 3, length 4; invalid} -body {
    snit::listtype subtype -minlen 1 -maxlen 3
    codecatch {subtype validate {a b c d}}
} -cleanup {
    subtype destroy
} -result {INVALID value has too many elements; no more than 3 expected}

test listtype-4.1 {boolean list, valid} -body {
    snit::listtype subtype -type snit::boolean
    subtype validate {yes 1 true}
} -cleanup {
    subtype destroy
} -result {yes 1 true}

test listtype-4.2 {boolean list, invalid} -body {
    snit::listtype subtype -type snit::boolean
    codecatch {subtype validate {yes 1 abc no}}
} -cleanup {
    subtype destroy
} -result {INVALID invalid boolean "abc", should be one of: 1, 0, true, false, yes, no, on, off}

#-----------------------------------------------------------------------
# snit::pixels

test pixels-1.1 {no suffix} -constraints tk -body {
    snit::pixels validate 5
} -result {5}

test pixels-1.2 {suffix} -constraints tk -body {
    snit::pixels validate 5i
} -result {5i}

test pixels-1.3 {decimal} -constraints tk -body {
    snit::pixels validate 5.5
} -result {5.5}

test pixels-1.4 {invalid} -constraints tk -body {
    codecatch {snit::pixels validate 5.5abc}
} -result {INVALID invalid value "5.5abc", expected pixels}

test pixels-2.1 {bad -min} -constraints tk -body {
    snit::pixels subtype -min abc
} -returnCodes {
    error
} -result {Error in constructor: invalid -min: "abc"}

test pixels-2.2 {bad -max} -constraints tk -body {
    snit::pixels subtype -max abc
} -returnCodes {
    error
} -result {Error in constructor: invalid -max: "abc"}

test pixels-2.3 {-min > -max} -constraints tk -body {
    snit::pixels subtype -min 10 -max 5
} -returnCodes {
    error
} -result {Error in constructor: -max < -min}

test pixels-3.1 {subtype, no suffix} -constraints tk -body {
    snit::pixels subtype
    subtype validate 5
} -cleanup {
    subtype destroy
} -result {5}

test pixels-3.2 {suffix} -constraints tk -body {
    snit::pixels subtype
    subtype validate 5i
} -cleanup {
    subtype destroy
} -result {5i}

test pixels-3.3 {decimal} -constraints tk -body {
    snit::pixels subtype
    subtype validate 5.5
} -cleanup {
    subtype destroy
} -result {5.5}

test pixels-3.4 {invalid} -constraints tk -body {
    snit::pixels subtype
    codecatch {subtype validate 5.5abc}
} -cleanup {
    subtype destroy
} -result {INVALID invalid value "5.5abc", expected pixels}


test pixels-3.5 {subtype -min} -constraints tk -body {
    snit::pixels subtype -min 5
    subtype validate 10
} -cleanup {
    subtype destroy
} -result {10}

test pixels-3.6 {min of min, max} -constraints tk -body {
    snit::pixels subtype -min 5 -max 20
    subtype validate 5
} -cleanup {
    subtype destroy
} -result {5}

test pixels-3.7 {max of min, max} -constraints tk -body {
    snit::pixels subtype -min 5 -max 20
    subtype validate 20
} -cleanup {
    subtype destroy
} -result {20}

test pixels-3.8 {middle of min, max} -constraints tk -body {
    snit::pixels subtype -min 5 -max 20
    subtype validate 15
} -cleanup {
    subtype destroy
} -result {15}

test pixels-3.9 {invalid, < min} -constraints tk -body {
    snit::pixels subtype -min 5
    codecatch {subtype validate 4}
} -cleanup {
    subtype destroy
} -result {INVALID invalid value "4", expected pixels no less than 5}

test pixels-3.10 {invalid, > max} -constraints tk -body {
    snit::pixels subtype -min 5 -max 20
    codecatch {subtype validate 21}
} -cleanup {
    subtype destroy
} -result {INVALID invalid value "21", expected pixels in range 5, 20}

test pixels-3.11 {invalid, > max, range with suffix} -constraints tk -body {
    snit::pixels subtype -min 5i -max 10i
    codecatch {subtype validate 11i}
} -cleanup {
    subtype destroy
} -result {INVALID invalid value "11i", expected pixels in range 5i, 10i}

#-----------------------------------------------------------------------
# snit::stringtype

test stringtype-1.1 {stringtype, valid string} -body {
    snit::stringtype validate ""
} -result {}

test stringtype-2.1 {stringtype subtype: invalid -regexp} -body {
    snit::stringtype subtype -regexp "\[A-Z"
} -returnCodes {
    error
} -result {Error in constructor: invalid -regexp: "[A-Z"}

test stringtype-2.2 {stringtype subtype: invalid -minlen} -body {
    snit::stringtype subtype -minlen foo
} -returnCodes {
    error
} -result {Error in constructor: invalid -minlen: "foo"}

test stringtype-2.3 {stringtype subtype: invalid -maxlen} -body {
    snit::stringtype subtype -maxlen foo
} -returnCodes {
    error
} -result {Error in constructor: invalid -maxlen: "foo"}

test stringtype-2.4 {stringtype subtype: -maxlen < -minlen} -body {
    snit::stringtype subtype -maxlen 1 -minlen 5
} -returnCodes {
    error
} -result {Error in constructor: -maxlen < -minlen}

test stringtype-2.5 {stringtype subtype: -minlen < 0} -body {
    snit::stringtype subtype -minlen -1
} -returnCodes {
    error
} -result {Error in constructor: invalid -minlen: "-1"}

test stringtype-2.6 {stringtype subtype: -maxlen < 0} -body {
    snit::stringtype subtype -maxlen -1
} -returnCodes {
    error
} -result {Error in constructor: -maxlen < -minlen}

test stringtype-3.1 {stringtype subtype: -glob, valid} -body {
    snit::stringtype subtype -glob "*FOO*"
    subtype validate 1FOO2
} -cleanup {
    subtype destroy
} -result {1FOO2}

test stringtype-3.2 {stringtype subtype: -glob, case-insensitive} -body {
    snit::stringtype subtype -nocase yes -glob "*FOO*"
    subtype validate 1foo2
} -cleanup {
    subtype destroy
} -result {1foo2}

test stringtype-3.3 {stringtype subtype: -glob invalid, case-sensitive} -body {
    snit::stringtype subtype -glob "*FOO*"
    codecatch {subtype validate 1foo2}
} -cleanup {
    subtype destroy
} -result {INVALID invalid value "1foo2"}

test stringtype-5.4 {stringtype subtype: -glob invalid, case-insensitive} -body {
    snit::stringtype subtype -nocase yes -glob "*FOO*"
    codecatch {subtype validate bar}
} -cleanup {
    subtype destroy
} -result {INVALID invalid value "bar"}

test stringtype-5.5 {stringtype subtype: -regexp valid, case-sensitive} -body {
    snit::stringtype subtype -regexp {^[A-Z]+$}
    subtype validate FOO
} -cleanup {
    subtype destroy
} -result {FOO}

test stringtype-5.6 {stringtype subtype: -regexp valid, case-insensitive} -body {
    snit::stringtype subtype -nocase yes -regexp {^[A-Z]+$}
    subtype validate foo
} -cleanup {
    subtype destroy
} -result {foo}

test stringtype-5.7 {stringtype subtype: -regexp invalid, case-sensitive} -body {
    snit::stringtype subtype -regexp {^[A-Z]+$}
    codecatch {subtype validate foo}
} -cleanup {
    subtype destroy
} -result {INVALID invalid value "foo"}

test stringtype-5.8 {stringtype subtype: -regexp invalid, case-insensitive} -body {
    snit::stringtype subtype -nocase yes -regexp {^[A-Z]+$}
    codecatch {subtype validate foo1}
} -cleanup {
    subtype destroy
} -result {INVALID invalid value "foo1"}

#-----------------------------------------------------------------------
# snit::window

test window-1.1 {window: valid} -constraints tk -body {
    snit::window validate .
} -result {.}

test window-1.2 {window: invalid} -constraints tk -body {
    codecatch {snit::window validate .nonesuch}
} -result {INVALID invalid value ".nonesuch", value is not a window}

test window-2.1 {window subtype: valid} -constraints tk -body {
    snit::window subtype
    subtype validate .
} -cleanup {
    subtype destroy
} -result {.}

test window-2.2 {window subtype: invalid} -constraints tk -body {
    snit::window subtype
    codecatch {subtype validate .nonesuch}
} -cleanup {
    subtype destroy
} -result {INVALID invalid value ".nonesuch", value is not a window}

#-----------------------------------------------------------------------
# option -type specifications

test optiontype-1.1 {-type is type object name} -body {
    type dog {
        option -akcflag -default no -type snit::boolean
    }

    dog create spot

    # Set -akcflag to a boolean value
    spot configure -akcflag yes
    spot configure -akcflag 1
    spot configure -akcflag on
    spot configure -akcflag off
    
    # Set -akcflag to an invalid value
    spot configure -akcflag offf
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result {invalid -akcflag value: invalid boolean "offf", should be one of: 1, 0, true, false, yes, no, on, off}

test optiontype-1.2 {-type is type specification} -body {
    type dog {
        option -color -default brown \
            -type {snit::enum -values {brown black white golden}}
    }

    dog create spot

    # Set -color to a valid value
    spot configure -color brown
    spot configure -color black
    spot configure -color white
    spot configure -color golden
    
    # Set -color to an invalid value
    spot configure -color green
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result {invalid -color value: invalid value "green", should be one of: brown, black, white, golden}

test optiontype-1.3 {-type catches invalid defaults} -body {
    type dog {
        option -color -default green \
            -type {snit::enum -values {brown black white golden}}
    }
    
    dog spot
} -returnCodes {
    error
} -cleanup {
    dog destroy
} -result {Error in constructor: invalid -color default: invalid value "green", should be one of: brown, black, white, golden}


#-----------------------------------------------------------------------
# Bug Fixes

test bug-1.1 {Bug 1161779: destructor can't precede constructor} -body {
    type dummy {
        destructor {
            # No content
        }

        constructor {args} {
            $self configurelist $args
        }

    }
} -cleanup {
    rename ::dummy ""
} -result ::dummy

test bug-2.1 {Bug 1106375: Widget Error on failed object's construction} -constraints {
    tk
} -body {
    ::snit::widgetadaptor mylabel {
        delegate method * to hull
        delegate option * to hull

        constructor {args} {
            installhull using label
            error "simulated error"
        }
    }

    catch {mylabel .lab} result
    list [info commands .lab] $result

} -cleanup {
    ::mylabel destroy
} -result {{} {Error in constructor: simulated error}}

test bug-2.2 {Bug 1106375: Widget Error on failed object's construction} -constraints {
    tk
} -body {
    ::snit::widget myframe {
        delegate method * to hull
        delegate option * to hull

        constructor {args} {
            error "simulated error"
        }
    }

    catch {myframe .frm} result
    list [info commands .frm] $result
 } -cleanup {
    ::myframe destroy
} -result {{} {Error in constructor: simulated error}}

test bug-3.1 {Bug 1532791: snit2, snit::widget problem} -constraints {
    tk
} -body {
    snit::widget mywidget {
        delegate method * to mylabel
        delegate option * to mylabel

        variable mylabel {}
    }

    mywidget .mylabel
} -cleanup {
    destroy .mylabel
} -result {.mylabel}


#---------------------------------------------------------------------
# Clean up

rename expect {}
testsuiteCleanup