# -*-Tcl-*-
#---------------------------------------------------------------------
# TITLE:
#	snit.test
#
# AUTHOR:
#	Will Duquette
#
# DESCRIPTION:
#	Test cases for snit.tcl.  Uses the ::tcltest:: harness.

# Note:
#    Snit assumes Tcl 8.4
#    The tests assume tcltest 2.1

#---------------------------------------------------------------------
# Load the tcltest package, initialize some constraints.

if {![package vsatisfies [package provide Tcl] 8.4]} {
    puts "Aborting tests for snit."
    puts "Requiring Tcl 8.4, have [package present Tcl]"
    return
}

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2.1
    namespace import ::tcltest::*
} else {
    # Ensure that 2.1 or higher present.

    if {![package vsatisfies [package present tcltest] 2.1]} {
	puts "Aborting tests for snit."
	puts "Requiring tcltest 2.1, have [package present tcltest]"
	return
    }
}

if { [lsearch $auto_path [file dirname [info script]]] == -1 } {
    set auto_path [linsert $auto_path 0 [file dirname [info script]]]
}

set ::tcltest::testConstraints(tk) [info exists tk_version]

if {$::tcltest::testConstraints(tk) && 
    ![catch {package require BWidget} result]} {
    set ::tcltest::testConstraints(bwidget) 1
} else {
    set ::tcltest::testConstraints(bwidget) 0
}

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

package forget snit
catch {namespace delete snit}
if {[catch {source [file join [file dirname [info script]] snit.tcl]} msg]} {
    puts "skipped [file tail [info script]]: $msg"
    return
}

puts "- Tcl  [package present Tcl]"
puts "- snit [package present 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 {[info commands "spot"] ne ""} {
        puts "spot not erased!"
        error "spot not erased!"
    }

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


#-----------------------------------------------------------------------
# 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%"
} -result {Prefix: My %TEMPLATE%} -cleanup {
    unset text
}

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

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

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

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%
} -result {::mytype3} -cleanup {
    unset counter
    rename ::mytype1 ""
    rename ::mytype2 ""
}

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

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

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

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
} -result {::mytype::Snit_inst3} -cleanup {
    unset counter
    namespace delete ::mytype::
}

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

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

#-----------------------------------------------------------------------
# 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} {} {
    set compResult [compile type dog { }]

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

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

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

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

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

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

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

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

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

test type-1.1 {type names get qualified} {} {
    cleanup

    type dog {}
} {::dog}

test type-1.2 {typemethods can be defined} {} {
    cleanup

    type dog {
        typemethod foo {a b} {
            return [list $a $b]
        }
    }

    dog foo 1 2
} {1 2}

test type-1.3 {upvar works in typemethods} {} {
    cleanup

    type dog { 
        typemethod goodname {varname} {
            upvar $varname myvar
            set myvar spot
        }
    }
    
    set thename fido
    dog goodname thename
    set thename
} {spot}

test type-1.4 {typemethod args can't include type} {} {
    cleanup

    catch {
        type dog { 
            typemethod foo {a type b} { }
        }
    } result
    set result
} {typemethod foo's arglist may not contain "type" explicitly}

test type-1.5 {typemethod args can't include self} {} {
    cleanup

    catch {
        type dog { 
            typemethod foo {a self b} { }
        }
    } result
    set result
} {typemethod foo's arglist may not contain "self" explicitly}

test type-1.6 {typemethod args can span multiple lines} {} {
    cleanup

    # 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
        } { }
    }
} {::dog}


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

test typeconstructor-1.1 {a typeconstructor can be defined} {} {
    cleanup

    type dog {
        typevariable a

        typeconstructor {
            set a 1
        }

        typemethod aget {} {
            return $a
        }
    }

    dog aget
} {1}

test typeconstructor-1.2 {only one typeconstructor can be defined} {} {
    cleanup

    catch {
        type dog {
            typevariable a

            typeconstructor {
                set a 1
            }

            typeconstructor {
                set a 2
            }
        }
    } result

    set result
} {too many typeconstructors}

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

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

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

test typecomponent-1.1 {typecomponent defines typevariable} {} {
    cleanup

    catch {
    type dog {
        typecomponent mycomp
            
        typemethod test {} {
            return $mycomp
        }
    }

    dog test
    } result
    set result
} {}

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

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

    dog test
} {foo}

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

        typeconstructor {
            set mycomp string
        }
    }

    dog string length foo
} {3}

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

        typeconstructor {
            set mycomp string
        }
    }

    dog length foo
} {3}


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

test htypemethod1.1 {hierarchical method, two tokens} {} {
    cleanup

    type dog {
        typemethod {wag tail} {} {
            return "wags tail"
        }
    }

    dog wag tail
} {wags tail}

test htypemethod1.2 {hierarchical method, three tokens} {} {
    cleanup

    type dog {
        typemethod {wag tail proudly} {} {
            return "wags tail proudly"
        }
    }

    dog wag tail proudly
} {wags tail proudly}

test htypemethod1.3 {hierarchical method, three tokens} {} {
    cleanup

    type dog {
        typemethod {wag tail really high} {} {
            return "wags tail really high"
        }
    }

    dog wag tail really high
} {wags tail really high}

test htypemethod1.4 {redefinition is OK} {} {
    cleanup

    type dog {
        typemethod {wag tail} {} {
            return "wags tail"
        }
        typemethod {wag tail} {} {
            return "wags tail briskly"
        }
    }

    dog wag tail
} {wags tail briskly}

test htypemethod1.5 {proper error on missing submethod} {} {
    cleanup

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

    catch {dog wag} result
    set result
} {wrong number args: should be "::dog wag method args"}


test htypemethod2.1 {prefix/method collision} {} {
    cleanup

    catch {
        type dog {
            typemethod wag {} {}
            typemethod {wag tail} {} {}
        }
    } result

    set result
} {Error in "typemethod {wag tail}...", "wag" has no submethods.}

test htypemethod2.2 {prefix/method collision} {} {
    cleanup

    catch {
        type dog {
            typemethod {wag tail} {} {}
            typemethod wag {} {}
        }
    } result

    set result
} {Error in "typemethod wag...", "wag" has submethods.}

test htypemethod2.3 {prefix/method collision} {} {
    cleanup

    catch {
        type dog {
            typemethod {wag tail} {} {}
            typemethod {wag tail proudly} {} {}
        }
    } result

    set result
} {Error in "typemethod {wag tail proudly}...", "wag tail" has no submethods.}

test htypemethod2.4 {prefix/method collision} {} {
    cleanup

    catch {
        type dog {
            typemethod {wag tail proudly} {} {}
            typemethod {wag tail} {} {}
        }
    } result

    set result
} {Error in "typemethod {wag tail}...", "wag tail" has submethods.}

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

test dtypemethod-1.1 {delegate typemethod to non-existent component} {} {
    cleanup

    set result ""

    type dog {
        delegate typemethod foo to bar
    }

    catch {dog foo} result
    set result
} {::dog delegates typemethod "foo" to undefined typecomponent "bar"}

test dtypemethod-1.2 {delegating to existing typecomponent} {
    cleanup

    type dog {
        delegate typemethod length to string

        typeconstructor {
            set string string
        }
    }

    dog length foo
} {3}

test dtypemethod-1.3 {delegating to existing typecomponent with error} {
    cleanup

    type dog {
        delegate typemethod length to string

        typeconstructor {
            set string string
        }
    }

    set result ""
    catch {dog length foo bar} result
    set result
} {wrong # args: should be "string length string"}

test dtypemethod-1.4 {delegating unknown typemethods to existing typecomponent} {
    cleanup

    type dog {
        delegate typemethod * to string

        typeconstructor {
            set string string
        }
    }

    dog length foo
} {3}

test dtypemethod-1.5 {delegating unknown typemethod to existing typecomponent with error} {
    cleanup

    type dog {
        delegate typemethod * to stringhandler

        typeconstructor {
            set stringhandler string
        }
    }

    set result ""
    catch {dog foo bar} result
    set 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.6 {can't delegate local typemethod: order 1} {
    cleanup

    catch {
        type dog {
            typemethod foo {} {}
            delegate typemethod foo to bar
        }
    } result

    set result
} {Error in "delegate typemethod foo...", "foo" has been defined locally.}

test dtypemethod-1.7 {can't delegate local typemethod: order 2} {
    cleanup

    catch {
        type dog {
            delegate typemethod foo to bar
            typemethod foo {} {}
        }
    } result

    set result
} {Error in "typemethod foo...", "foo" has been delegated}

test dtypemethod-1.8 {excepted methods are caught properly} {
    cleanup

    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
} {3 {"::dog match" is not defined} {"::dog index" is not defined}}

test dtypemethod-1.9 {as clause can include arguments} {
    cleanup

    proc tail {a b} {
        return "<$a $b>"
    }

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

        typeconstructor {
            set tail tail
        }
    }

    dog wag
} {<wag briskly>}

test dtypemethod-2.1 {'using "%c %m"' gets normal behavior} {
    cleanup

    type dog {
        delegate typemethod length to string using {%c %m}

        typeconstructor {
            set string string
        }
    }

    dog length foo
} {3}

test dtypemethod-2.2 {All relevant 'using' conversions are converted} {
    cleanup

    proc echo {args} { 
        return $args 
    }

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

    dog tail wag
} {% ::dog {tail wag} wag tail_wag %n %w %s %c}

test dtypemethod-2.3 {"%%" is handled properly} {
    cleanup

    proc echo {args} { join $args "|" }

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

    dog wag
} {%m|%wag}

test dtypemethod-2.4 {Method "*" and "using"} {
    cleanup

    proc echo {args} { join $args "|" }

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

    list [dog wag] [dog bark loudly]
} {wag bark|loudly}


test dtypemethod-3.1 {typecomponent names can be changed dynamically} {
    cleanup

    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
} {3 length|foo}

test dtypemethod-4.1 {hierarchical typemethod, two tokens} {} {
    cleanup

    type tail {
        method wag {} {return "wags tail"}
    }

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

    dog wag tail
} {wags tail}

test dtypemethod-4.2 {hierarchical typemethod, three tokens} {} {
    cleanup 

    type tail {
        method wag {} {return "wags tail"}
    }

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

    dog wag tail proudly
} {wags tail}

test dtypemethod-4.3 {hierarchical typemethod, three tokens} {} {
    cleanup

    type tail {
        method wag {} {return "wags tail"}
    }

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

    dog wag tail really high
} {wags tail}

test dtypemethod-4.4 {redefinition is OK} {} {
    cleanup

    type tail {
        method {wag tail}    {} {return "wags tail"}
        method {wag briskly} {} {return "wags tail briskly"}
    }

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

    dog wag tail
} {wags tail briskly}

test dtypemethod-4.5 {last token is used by default} {} {
    cleanup

    type tail {
        method wag {} {return "wags tail"}
    }

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

    dog tail wag
} {wags tail}

test dtypemethod-4.6 {last token can be *} {} {
    cleanup

    type tail {
        method wag {} {return "wags"}
        method droop {} {return "droops"}
    }

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

    list [dog tail wag] [dog tail droop]
} {wags droops}

test dtypemethod-4.7 {except with multiple tokens} {} {
    cleanup

    type tail {
        method wag {} {return "wags"}
        method droop {} {return "droops"}
    }

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

    catch {dog tail droop} result

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

test dtypemethod-4.8 {"*" in the wrong spot} {} {
    cleanup

    catch {
        type dog {
            delegate typemethod {tail * wag} to tail
        }
    } result

    set result
} {Error in "delegate typemethod {tail * wag}...", "*" must be the last token.}

test dtypemethod-5.1 {prefix/typemethod collision} {} {
    cleanup

    catch {
        type dog {
            delegate typemethod wag to tail
            delegate typemethod {wag tail} to tail as wag
        }
    } result

    set result
} {Error in "delegate typemethod {wag tail}...", "wag" has no submethods.}

test dtypemethod-5.2 {prefix/typemethod collision} {} {
    cleanup

    catch {
        type dog {
            delegate typemethod {wag tail} to tail as wag
            delegate typemethod wag to tail
        }
    } result

    set result
} {Error in "delegate typemethod wag...", "wag" has submethods.}

test dtypemethod-5.3 {prefix/typemethod collision} {} {
    cleanup

    catch {
        type dog {
            delegate typemethod {wag tail} to tail
            delegate typemethod {wag tail proudly} to tail as wag
        }
    } result

    set result
} {Error in "delegate typemethod {wag tail proudly}...", "wag tail" has no submethods.}

test dtypemethod-5.4 {prefix/typemethod collision} {} {
    cleanup

    catch {
        type dog {
            delegate typemethod {wag tail proudly} to tail as wag
            delegate typemethod {wag tail} to tail
        }
    } result

    set result
} {Error in "delegate typemethod {wag tail}...", "wag tail" has submethods.}



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

test creation-1.1 {type instance names get qualified} {} {
    cleanup 

    type dog { }

    dog create spot
} {::spot}

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

    # Note: do not use type "abc" in any other test.
    type abc { }
    
    abc create my%AUTO%
} {::myabc1}

test creation-1.3 {"create" method is optional} {} {
    cleanup

    type dog { }

    dog fido
} {::fido}


test creation-1.4 {constructor arg can't be type} {} {
    cleanup

    catch {
        type dog { 
            constructor {type} { }
        }
    } result
    set result
} {constructor's arglist may not contain "type" explicitly}

test creation-1.5 {constructor arg can't be self} {} {
    cleanup

    catch {
        type dog { 
            constructor {self} { }
        }
    } result
    set result
} {constructor's arglist may not contain "self" explicitly}

test creation-1.6 {weird names are OK} {} {
    cleanup

    type confused-dog { 
        method meow {} {
            return "$self meows."
        }
    }

    confused-dog spot
    spot meow
} {::spot meows.}

test creation-1.7 {If -hasinstances yes, [$type] == [$type create %AUTO%]} {
    cleanup

    type dog {
        variable dummy
    }

    set mydog [dog]
} {::dog1}

test creation-1.8 {If -hasinstances no, [$type] != [$type create %AUTO%]} {
    cleanup

    type dog {
        pragma -hasinstances no
    }

    catch {set mydog [dog]} result
    set result
} {wrong # args: should be "::dog method args"}

test creation-1.9 {If widget, [$type] != [$type create %AUTO%]} tk {
    cleanup

    widget dog {
        variable dummy
    }

    catch {set mydog [dog]} result
    set result
} {wrong # args: should be "::dog method args"}


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

test proc-1.1 {proc args can span multiple lines} {} {
    cleanup

    # 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
        } { }
    }
} {::dog}


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

test method-1.1 {methods get called} {} {
    cleanup

    type dog {
        method bark {} {
            return "$self barks"
        }
    }

    dog create spot
    spot bark
} {::spot barks}

test method-1.2 {methods can call other methods} {} {
    cleanup

    type dog {
        method bark {} {
            return "$self barks."
        }

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

    dog create spot
    spot chase cat
} {::spot chases cat; ::spot barks.}

test method-1.3 {instances can call one another} {} {
    cleanup

    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
} {::spot chases ::fido; ::fido barks. ::spot barks.}

test method-1.4 {upvar works in methods} {} {
    cleanup

    type dog { 
        method goodname {varname} {
            upvar $varname myvar
            set myvar spot
        }
    }
    
    dog create fido
    set thename fido
    fido goodname thename
    set thename
} {spot}

test method-1.5 {unknown methods get an error} {} {
    cleanup

    type dog { }

    dog create spot
    set result ""
    catch {spot chase} result
    set result
} {"::spot chase" is not defined}

test method-1.6 {info type method returns the object's type} {} {
    cleanup

    type dog { }

    dog create spot
    spot info type
} {::dog}

test method-1.7 {instance method can call type method} {} {
    cleanup

    type dog { 
        typemethod hello {} {
            return "Hello"
        }
        method helloworld {} {
            return "[$type hello], World!"
        }
    }
    
    dog create spot
    spot helloworld
} {Hello, World!}

test method-1.8 {type methods must be qualified} {} {
    cleanup

    type dog { 
        typemethod hello {} {
            return "Hello"
        }
        method helloworld {} {
            return "[hello], World!"
        }
    }
    
    dog create spot
    catch {spot helloworld} result
    set result
} {invalid command name "hello"}

test method-1.9 {too few arguments} {} {
    cleanup

    type dog { 
        method bark {volume} { }
    }

    dog create spot
    set result ""
    catch {spot bark} result
    set result
} {wrong # args: should be "::dog::Snit_methodbark type selfns win self volume"}

test method-1.10 {too many arguments} {} {
    cleanup

    type dog { 
        method bark {volume} { }
    }

    dog create spot
    set result ""
    catch {spot bark really loud} result
    set result
} {wrong # args: should be "::dog::Snit_methodbark type selfns win self volume"}

test method-1.11 {method args can't include type} {} {
    cleanup

    catch {
        type dog { 
            method foo {a type b} { }
        }
    } result
    set result
} {method foo's arglist may not contain "type" explicitly}

test method-1.12 {method args can't include self} {} {
    cleanup

    catch {
        type dog { 
            method foo {a self b} { }
        }
    } result
    set result
} {method foo's arglist may not contain "self" explicitly}

test method-1.13 {method args can span multiple lines} {} {
    cleanup

    # 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
                } { }
    }
} {::dog}

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

test hmethod-1.1 {hierarchical method, two tokens} {} {
    cleanup

    type dog {
        method {wag tail} {} {
            return "$self wags tail."
        }
    }

    dog spot
    spot wag tail
} {::spot wags tail.}

test hmethod-1.2 {hierarchical method, three tokens} {} {
    cleanup

    type dog {
        method {wag tail proudly} {} {
            return "$self wags tail proudly."
        }
    }

    dog spot
    spot wag tail proudly
} {::spot wags tail proudly.}

test hmethod-1.3 {hierarchical method, three tokens} {} {
    cleanup

    type dog {
        method {wag tail really high} {} {
            return "$self wags tail really high."
        }
    }

    dog spot
    spot wag tail really high
} {::spot wags tail really high.}

test hmethod-1.4 {redefinition is OK} {} {
    cleanup

    type dog {
        method {wag tail} {} {
            return "$self wags tail."
        }
        method {wag tail} {} {
            return "$self wags tail briskly."
        }
    }

    dog spot
    spot wag tail
} {::spot wags tail briskly.}

test hmethod-1.5 {proper error on missing submethod} {} {
    cleanup

    type dog {
        method {wag tail} {} { }
    }

    dog spot
    catch {spot wag} result
    set result
} {wrong number args: should be "::spot wag method args"}


test hmethod-2.1 {prefix/method collision} {} {
    cleanup

    catch {
        type dog {
            method wag {} {}
            method {wag tail} {} {
                return "$self wags tail."
            }
        }
    } result

    set result
} {Error in "method {wag tail}...", "wag" has no submethods.}

test hmethod-2.2 {prefix/method collision} {} {
    cleanup

    catch {
        type dog {
            method {wag tail} {} {
                return "$self wags tail."
            }
            method wag {} {}
        }
    } result

    set result
} {Error in "method wag...", "wag" has submethods.}

test hmethod-2.3 {prefix/method collision} {} {
    cleanup

    catch {
        type dog {
            method {wag tail} {} {}
            method {wag tail proudly} {} {
                return "$self wags tail."
            }
        }
    } result

    set result
} {Error in "method {wag tail proudly}...", "wag tail" has no submethods.}

test hmethod-2.4 {prefix/method collision} {} {
    cleanup

    catch {
        type dog {
            method {wag tail proudly} {} {
                return "$self wags tail."
            }
            method {wag tail} {} {}
        }
    } result

    set result
} {Error in "method {wag tail}...", "wag tail" has submethods.}

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

test rename-1.1 {mymethod uses name of instance name variable} {} {
    cleanup

    type dog { 
        method mymethod {} {
            list [mymethod] [mymethod "A B"] [mymethod A B]
        }
    }

    dog fido
    fido mymethod
} {{::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} {} {
    cleanup

    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
} {{::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} {} {
    cleanup

    type dog { }

    dog fido
    rename fido ""
    namespace children ::dog
} {}

test rename-1.4 {rename to "" deletes an instance even after a rename} {} {
    cleanup

    type dog { }

    dog fido
    rename fido spot
    rename spot ""
    namespace children ::dog
} {}

test rename-1.5 {creating an object twice destroys the first instance} {} {
    cleanup

    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
} {::dog::Snit_inst1 ::dog::Snit_inst2 {}}

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

test mymethod-1.1 {run mymethod handler} {
    cleanup

    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
} {::bar::fubar snarf}

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

test myproc-1.1 {myproc qualifies proc names} {} {
    cleanup

    type dog {
        proc foo {} {}

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

    dog getit
} {::dog::foo}

test myproc-1.2 {myproc adds arguments} {} {
    cleanup

    type dog {
        proc foo {} {}

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

    dog getit
} {::dog::foo {a b}}

test myproc-1.3 {myproc adds arguments} {} {
    cleanup

    type dog {
        proc foo {} {}

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

    dog getit
} {::dog::foo {a b} c d}

test myproc-1.4 {procs with selfns work} {} {
    cleanup

    type dog {
        variable datum foo

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


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

test mytypemethod-1.1 {mytypemethod qualifies typemethods} {} {
    cleanup

    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]
} {{::dog this} {::dog this x} {::dog this {x y}} {::dog this x y}}

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

test typevariable-1.1 {typevarname qualifies typevariables} {} {
    # Note: typevarname is DEPRECATED.  Use mytypevar instead.
    cleanup

    type dog { 
        method tvname {name} {
            typevarname $name
        }
    }

    dog create spot
    spot tvname myvar
} {::dog::myvar}

test typevariable-1.2 {undefined typevariables are OK} {} {
    cleanup

    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]
} {Howdy Howdy Howdy}

test typevariable-1.3 {predefined typevariables are OK} {} {
    cleanup

    type dog { 
        typevariable greeting Hello

        method tget {} {
            return $greeting
        }
    }

    dog create spot
    dog create fido

    list [spot tget] [fido tget] [set ::dog::greeting]
} {Hello Hello Hello}

test typevariable-1.4 {typevariables can be arrays} {} {
    cleanup

    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)
} {Hi Howdy}

test typevariable-1.5 {typevariables can used in typemethods} {} {
    cleanup

    type dog { 
        typevariable greetings Howdy

        typemethod greet {} {
            return $greetings
        }
    }

    dog greet
} {Howdy}

test typevariable-1.6 {typevariables can used in procs} {} {
    cleanup

    type dog { 
        typevariable greetings Howdy

        method greet {} {
            return [realGreet]
        }

        proc realGreet {} {
            return $greetings
        }
    }

    dog create spot
    spot greet
} {Howdy}

test typevariable-1.7 {mytypevar qualifies typevariables} {} {
    cleanup

    type dog { 
        method tvname {name} {
            mytypevar $name
        }
    }

    dog create spot
    spot tvname myvar
} {::dog::myvar}

test typevariable-1.8 {typevariable with too many initializers throws an error} {} {
    cleanup

    catch {
        type dog { 
            typevariable color dark brown
        }
    } result

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

test typevariable-1.9 {typevariable with too many initializers throws an error} {} {
    cleanup

    catch {
        type dog { 
            typevariable color -array dark brown
        }
    } result

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

test typevariable-1.10 {typevariable can initialize array variables} {} {
    cleanup

    type dog { 
        typevariable data -array {
            family jones
            color brown
        }

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

    list [dog getdata family] [dog getdata color]
} {jones brown}

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

test ivariable-1.1 {myvar qualifies instance variables} {} {
    cleanup

    type dog { 
        method vname {name} {
            myvar $name
        }
    }

    dog create spot
    spot vname somevar
} {::dog::Snit_inst1::somevar}

test ivariable-1.2 {undefined instance variables are OK} {} {
    cleanup

    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]
} {Hey Howdy Hey}

test ivariable-1.3 {instance variables are destroyed automatically} {} {
    cleanup

    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]
} {Hi 0}

test ivariable-1.4 {defined instance variables need not be declared} {} {
    cleanup

    type dog { 
        variable greetings

        method put {} {
            set greetings Howdy
        }

        method get {} {
            return $greetings
        }
    }

    dog create spot
    spot put
    spot get
} {Howdy}

test ivariable-1.5 {instance variables can be arrays} {} {
    cleanup

    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)]
} {Hi Howdy}

test ivariable-1.6 {instance variables can be initialized in the definition} {} {
    cleanup

    type dog { 
        variable greetings {Hi Howdy}
        variable empty {}

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

    dog create spot
    spot list
} {{Hi Howdy} {}}

test ivariable-1.7 {variable is illegal when selfns is undefined} {} {
    cleanup

    type dog { 
        method caller {} {
            callee
        }
        proc callee {} {
            variable foo
        }
    }

    dog create spot

    set result ""
    catch {spot caller} result
    set result
} {can't read "selfns": no such variable}

test ivariable-1.8 {myvar is illegal when selfns is undefined} {} {
    cleanup

    type dog { 
        method caller {} {
            callee
        }
        proc callee {} {
            myvar foo
        }
    }

    dog create spot

    set result ""
    catch {spot caller} result
    set result
} {can't read "selfns": no such variable}

test ivariable-1.9 {procs which define selfns see instance variables} {} {
    cleanup

    type dog { 
        variable greeting Howdy

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

        proc callee {selfns} {
            return $greeting
        }
    }

    dog create spot

    spot caller
} {Howdy}

test ivariable-1.10 {in methods, variable works with fully qualified names} {} {
    cleanup

    namespace eval ::somenamespace:: {
        set somevar somevalue
    }

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

    dog create spot

    spot get
} {somevalue}

test ivariable-1.11 {variable with too many initializers throws an error} {} {
    cleanup

    catch {
        type dog { 
            variable color dark brown
        }
    } result

    set result
} {Error in "variable color...", too many initializers}

test ivariable-1.12 {variable with too many initializers throws an error} {} {
    cleanup

    catch {
        type dog { 
            variable color -array dark brown
        }
    } result

    set result
} {Error in "variable color...", too many initializers}

test ivariable-1.13 {variable can initialize array variables} {} {
    cleanup

    type dog { 
        variable data -array {
            family jones
            color brown
        }

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

    dog spot
    list [spot getdata family] [spot getdata color]
} {jones brown}

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

test codename-1.1 {codename qualifies procs} {} {
    cleanup

    type dog {
        method qualify {} {
            return [codename myproc]
        }
        proc myproc {} { }
    }
    dog create spot
    spot qualify
} {::dog::myproc}

test codename-1.2 {procs with selfns work} {} {
    cleanup

    type dog {
        variable datum foo

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

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

test option-1.1 {options get default values} {} {
    cleanup

    type dog {
        option -color golden
    }

    dog create spot
    spot cget -color
} {golden}

test option-1.2 {options can be set} {} {
    cleanup

    type dog {
        option -color golden
    }

    dog create spot
    spot configure -color black
    spot cget -color
} {black}

test option-1.3 {multiple options can be set} {} {
    cleanup

    type dog {
        option -color golden
        option -akc 0
    }

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

test option-1.4 {options can be retrieved as instance variable} {} {
    cleanup

    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
} {black 1}

test option-1.5 {options can be set as an instance variable} {} {
    cleanup

    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]
} {black 1}

test option-1.6 {options can be set at creation time} {} {
    cleanup

    type dog {
        option -color golden
        option -akc 0
    }

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

test option-1.7 {undefined option: cget} {} {
    cleanup

    type dog {
        option -color golden
        option -akc 0
    }

    dog create spot
    set result {}
    catch {spot cget -colour} result
    set result
} {unknown option "-colour"}

test option-1.8 {undefined option: configure} {} {
    cleanup

    type dog {
        option -color golden
        option -akc 0
    }

    dog create spot
    set result {}
    catch {spot configure -colour blue} result
    set result
} {unknown option "-colour"}

test option-1.9 {options default to ""} {} {
    cleanup

    type dog {
        option -color
    }

    dog create spot
    spot cget -color
} {}

test option-1.10 {spaces allowed in option defaults} {} {
    cleanup

    type dog {
        option -breed "golden retriever"
    }
    dog fido
    fido cget -breed
} {golden retriever}

test option-1.11 {brackets allowed in option defaults} {} {
    cleanup

    type dog {
        option -regexp {[a-z]+}
    }

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

test option-2.1 {configure returns info, local options only} {} {
    cleanup

    type dog {
        option -color black
        option -akc 1
    }

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

test option-2.2 {configure -opt returns info, local options only} {} {
    cleanup

    type dog {
        option -color black
        option -akc 1
    }

    dog create spot
    spot configure -color red
    spot configure -color
} {-color color Color black red}

test option-2.3 {configure -opt returns info, explicit options} {} {
    cleanup

    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
} {-akc akc Akc 1 0}

test option-2.4 {configure -unknownopt} {} {
    cleanup

    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
    catch {spot configure -foo} result
    set result
} {unknown option "-foo"}

test option-2.5 {configure returns info, unknown options} tk {
    cleanup

    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

} {{-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} tk {
    cleanup

    widgetadaptor myframe { 
        delegate option * to hull
        constructor {args} {
            installhull [frame $self]
        }
    }
    myframe .frm
    catch {.frm configure -quux} result
    destroy .frm
    tkbide
    set result
} {unknown option "-quux"}

test option-3.1 {set option resource name explicitly} {
    cleanup

    type dog {
        option {-tailcolor tailColor} black
    }

    dog fido

    fido configure -tailcolor
} {-tailcolor tailColor TailColor black black}

test option-3.2 {set option class name explicitly} {
    cleanup

    type dog {
        option {-tailcolor tailcolor TailColor} black
    }

    dog fido

    fido configure -tailcolor
} {-tailcolor tailcolor TailColor black black}

test option-3.3 {delegated option's names come from owner} {
    cleanup
    
    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
} {-tailcolor tailcolor Tailcolor black black}

test option-3.4 {delegated option's resource name set explicitly} {
    cleanup
    
    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
} {-tailcolor tailColor TailColor black black}

test option-3.5 {delegated option's class name set explicitly} {
    cleanup
    
    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
} {-tailcolor tailcolor TailColor black black}

test option-3.6 {delegated option's default comes from component} {
    cleanup
    
    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
} {-tailcolor tailcolor Tailcolor black red}

test option-4.1 {local option name must begin with hyphen} {
    cleanup

    catch {
        type dog {
            option nohyphen
        }
    } result

    set result
} {Error in "option nohyphen...", badly named option "nohyphen"}

test option-4.2 {local option name must be lower case} {
    cleanup

    catch {
        type dog {
            option -Upper
        }
    } result

    set result
} {Error in "option -Upper...", badly named option "-Upper"}

test option-4.3 {local option name may not contain spaces} {
    cleanup

    catch {
        type dog {
            option {"-with space"}
        }
    } result

    set result
} {Error in "option {"-with space"}...", badly named option "-with space"}

test option-4.4 {delegated option name must begin with hyphen} {
    cleanup

    catch {
        type dog {
            delegate option nohyphen to tail
        }
    } result

    set result
} {Error in "delegate option nohyphen...", badly named option "nohyphen"}

test option-4.5 {delegated option name must be lower case} {
    cleanup

    catch {
        type dog {
            delegate option -Upper to tail
        }
    } result

    set result
} {Error in "delegate option -Upper...", badly named option "-Upper"}

test option-4.6 {delegated option name may not contain spaces} {
    cleanup

    catch {
        type dog {
            delegate option {"-with space"} to tail
        }
    } result

    set result
} {Error in "delegate option {"-with space"}...", badly named option "-with space"}

test option-5.1 {local widget options read from option database} tk {
    cleanup

    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

} {a bb}

test option-5.2 {local option database values available in constructor} tk {
    cleanup

    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
} {bb}

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

    dog spot
    spot info vars options
} {}

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

    dog spot
    spot info methods c*
} {}

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

test onconfigure-1.1 {invalid onconfigure methods are caught} {} {
    cleanup

    catch {
        type dog { 
            onconfigure -color {value} { }
        }
    } result
    set result
} {onconfigure -color: option "-color" unknown}

test onconfigure-1.2 {onconfigure methods take one argument} {} {
    cleanup

    catch {
        type dog { 
            option -color golden

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

test onconfigure-1.3 {onconfigure methods work} {} {
    cleanup

    type dog { 
        option -color golden
        
        onconfigure -color {value} { 
            set options(-color) "*$value*"
        }
    }

    dog create spot
    spot configure -color brown
    spot cget -color
} {*brown*}

test onconfigure-1.4 {onconfigure arg can't be type} {} {
    cleanup

    catch {
        type dog { 
            option -color
            onconfigure -color {type} { }
        }
    } result
    set result
} {onconfigure -color's arglist may not contain "type" explicitly}

test onconfigure-1.5 {onconfigure arg can't be self} {} {
    cleanup

    catch {
        type dog { 
            option -color
            onconfigure -color {self} { }
        }
    } result
    set result
} {onconfigure -color's arglist may not contain "self" explicitly}

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

test oncget-1.1 {invalid oncget methods are caught} {} {
    cleanup

    catch {
        type dog {
            oncget -color { }
        }
    } result
    set result
} {Error in "oncget -color...", option "-color" unknown}

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

    type dog { 
        option -color golden
        
        oncget -color { 
            return "*$options(-color)*"
        }
    }

    dog create spot
    spot configure -color brown
    spot cget -color
} {*brown*}

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


test constructor-1.1 {constructor can do things} {} {
    cleanup

    type dog {
        variable a
        variable b
        constructor {args} {
            set a 1
            set b 2
        }
        method foo {} {
            list $a $b
        }
    }

    dog create spot
    spot foo
} {1 2}

test constructor-1.2 {constructor with no configurelist ignores args} {} {
    cleanup

    type dog {
        constructor {args} { }
        option -color golden
        option -akc 0
    }

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

test constructor-1.3 {constructor with configurelist gets args} {} {
    cleanup

    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]
} {white 1}

test constructor-1.4 {constructor with specific args} {} {
    cleanup

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

    dog spot retriever golden -akc 1
    spot cget -value
} {retriever golden {-akc 1}}

test constructor-1.5 {constructor with list as one list arg} {} {
    cleanup

    type dog {
        option -value ""
        constructor {args} {
            set options(-value) $args
        }
    }

    dog spot {retriever golden}
    spot cget -value
} {{retriever golden}}

test constructor-1.6 {default constructor configures options} {} {
    cleanup

    type dog {
        option -color brown
        option -breed mutt
    }

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

test constructor-1.7 {default constructor takes no args if no options} {} {
    cleanup

    type dog {
        variable color
    }

    catch {dog spot -color golden} result
    set result
} {Error in constructor: wrong # args: should be "::dog::Snit_constructor type selfns win self"}


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

test destroy-1.1 {destroy cleans up the instance} {} {
    cleanup

    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]
} {{} ::dog::Snit_inst1 {} {}}

test destroy-1.2 {incomplete objects are destroyed} {} {
    cleanup

    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]
} {{Error in constructor: No Red Dogs!} {} {}}

test destroy-1.3 {user-defined destructors are called} {} {
    cleanup

    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]
} {{created ::spot} {destroyed ::spot}}


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

test delegate-1.1 {can only delegate methods or options} {} {
    cleanup

    set result ""
    catch {
        type dog {
            delegate foo bar to baz
        }
    } result

    set result
} {Error in "delegate foo bar...", "foo"?}

test delegate-1.2 {"to" must appear in the right place} {} {
    cleanup

    set result ""
    catch {
        type dog {
            delegate method foo from bar
        }
    } result

    set result
} {Error in "delegate method foo...", unknown delegation option "from"}

test delegate-1.3 {"as" must have a target} {} {
    cleanup

    set result ""
    catch {
        type dog {
            delegate method foo to bar as
        }
    } result

    set result
} {Error in "delegate method foo...", invalid syntax}

test delegate-1.4 {"as" must have a single target} {} {
    cleanup

    set result ""
    catch {
        type dog {
            delegate method foo to bar as baz quux
        }
    } result

    set result
} {Error in "delegate method foo...", unknown delegation option "quux"}

test delegate-1.5 {"as" doesn't work with "*"} {} {
    cleanup

    set result ""
    catch {
        type dog {
            delegate method * to hull as foo
        }
    } result

    set result
} {Error in "delegate method *...", cannot specify "as" with "*"}

test delegate-1.6 {"except" must have a target} {} {
    cleanup

    set result ""
    catch {
        type dog {
            delegate method * to bar except
        }
    } result

    set result
} {Error in "delegate method *...", invalid syntax}

test delegate-1.7 {"except" must have a single target} {} {
    cleanup

    set result ""
    catch {
        type dog {
            delegate method * to bar except baz quux
        }
    } result

    set result
} {Error in "delegate method *...", unknown delegation option "quux"}

test delegate-1.8 {"except" works only with "*"} {} {
    cleanup

    set result ""
    catch {
        type dog {
            delegate method foo to hull except bar
        }
    } result

    set result
} {Error in "delegate method foo...", can only specify "except" with "*"}

test delegate-1.9 {only "as" or "except"} {} {
    cleanup

    set result ""
    catch {
        type dog {
            delegate method foo to bar with quux
        }
    } result

    set result
} {Error in "delegate method foo...", unknown delegation option "with"}


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

test dmethod-1.1 {delegate method to non-existent component} {} {
    cleanup

    set result ""

    type dog {
        delegate method foo to bar
    }

    dog create spot
    catch {spot foo} result
    set result
} {::dog ::spot delegates method "foo" to undefined component "bar"}

test dmethod-1.2 {delegating to existing component} {
    cleanup

    type dog {
        constructor {args} {
            set string string
        }

        delegate method length to string
    }

    dog create spot
    spot length foo
} {3}

test dmethod-1.3 {delegating to existing component with error} {
    cleanup

    type dog {
        constructor {args} {
            set string string
        }

        delegate method length to string
    }

    dog create spot
    set result ""
    catch {spot length foo bar} result
    set result
} {wrong # args: should be "string length string"}

test dmethod-1.4 {delegating unknown methods to existing component} {
    cleanup

    type dog {
        constructor {args} {
            set string string
        }

        delegate method * to string
    }

    dog create spot
    spot length foo
} {3}

test dmethod-1.5 {delegating unknown method to existing component with error} {
    cleanup

    type dog {
        constructor {args} {
            set stringhandler string
        }

        delegate method * to stringhandler
    }

    dog create spot
    set result ""
    catch {spot foo bar} result
    set 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.6 {can't delegate local method: order 1} {
    cleanup

    catch {
        type cat {
            method foo {} {}
            delegate method foo to hull
        }
    } result

    set result
} {Error in "delegate method foo...", "foo" has been defined locally.}

test dmethod-1.7 {can't delegate local method: order 2} {
    cleanup

    catch {
        type cat {
            delegate method foo to hull
            method foo {} {}
        }
    } result

    set result
} {Error in "method foo...", "foo" has been delegated}

test dmethod-1.8 {excepted methods are caught properly} {
    cleanup

    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
} {flaunted {"::fifi wag" is not defined} {"::fifi tuck" is not defined}}

test dmethod-1.9 {as clause can include arguments} {
    cleanup

    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
} {wagged briskly}

test dmethod-2.1 {'using "%c %m"' gets normal behavior} {
    cleanup

    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
} {wagged briskly}

test dmethod-2.2 {All 'using' conversions are converted} {
    cleanup

    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
} {% ::dog {tail wag} wag tail_wag ::dog::Snit_inst1 ::spot ::spot %c}

test dmethod-2.3 {"%%" is handled properly} {
    cleanup

    proc echo {args} { join $args "|" }

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

    dog spot

    spot wag
} {%m|%wag}

test dmethod-2.4 {Method "*" and "using"} {
    cleanup

    proc echo {args} { join $args "|" }

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

    dog spot

    list [spot wag] [spot bark loudly]
} {wag bark|loudly}


test dmethod-3.1 {component names can be changed dynamically} {
    cleanup

    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
} {wagged drooped}

test dmethod-4.1 {hierarchical method, two tokens} {} {
    cleanup

    type tail {
        method wag {} {return "wags tail"}
    }

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

    dog spot
    spot wag tail
} {wags tail}

test dmethod-4.2 {hierarchical method, three tokens} {} {
    cleanup 

    type tail {
        method wag {} {return "wags tail"}
    }

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

    dog spot
    spot wag tail proudly
} {wags tail}

test dmethod-4.3 {hierarchical method, three tokens} {} {
    cleanup

    type tail {
        method wag {} {return "wags tail"}
    }

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

    dog spot
    spot wag tail really high
} {wags tail}

test dmethod-4.4 {redefinition is OK} {} {
    cleanup

    type tail {
        method {wag tail}    {} {return "wags tail"}
        method {wag briskly} {} {return "wags tail briskly"}
    }

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

    dog spot
    spot wag tail
} {wags tail briskly}

test dmethod-4.5 {all tokens are used by default} {} {
    cleanup

    type tail {
        method wag {} {return "wags tail"}
    }

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

    dog spot
    spot tail wag
} {wags tail}

test dmethod-4.6 {last token can be *} {} {
    cleanup

    type tail {
        method wag {} {return "wags"}
        method droop {} {return "droops"}
    }

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

    dog spot

    list [spot tail wag] [spot tail droop]
} {wags droops}

test dmethod-4.7 {except with multiple tokens} {} {
    cleanup

    type tail {
        method wag {} {return "wags"}
        method droop {} {return "droops"}
    }

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

    dog spot

    catch {spot tail droop} result

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

test dmethod-4.8 {"*" in the wrong spot} {} {
    cleanup

    catch {
        type dog {
            delegate method {tail * wag} to tail
        }
    } result

    set result
} {Error in "delegate method {tail * wag}...", "*" must be the last token.}

test dmethod-5.1 {prefix/method collision} {} {
    cleanup

    catch {
        type dog {
            delegate method wag to tail
            delegate method {wag tail} to tail as wag
        }
    } result

    set result
} {Error in "delegate method {wag tail}...", "wag" has no submethods.}

test dmethod-5.2 {prefix/method collision} {} {
    cleanup

    catch {
        type dog {
            delegate method {wag tail} to tail as wag
            delegate method wag to tail
        }
    } result

    set result
} {Error in "delegate method wag...", "wag" has submethods.}

test dmethod-5.3 {prefix/method collision} {} {
    cleanup

    catch {
        type dog {
            delegate method {wag tail} to tail
            delegate method {wag tail proudly} to tail as wag
        }
    } result

    set result
} {Error in "delegate method {wag tail proudly}...", "wag tail" has no submethods.}

test dmethod-5.4 {prefix/method collision} {} {
    cleanup

    catch {
        type dog {
            delegate method {wag tail proudly} to tail as wag
            delegate method {wag tail} to tail
        }
    } result

    set result
} {Error in "delegate method {wag tail}...", "wag tail" has submethods.}

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

test doption-1.1 {delegate option to non-existent component} {} {
    cleanup

    set result ""

    type dog {
        delegate option -foo to bar
    }

    dog create spot
    catch {spot cget -foo} result
    set result
} {component "bar" is undefined in ::dog ::spot}

test doption-1.2 {delegating option to existing component: cget} {
    cleanup

    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
} {black}

test doption-1.3 {delegating option to existing component: configure} {
    cleanup

    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]
} {blue blue}

test doption-1.4 {delegating unknown options to existing component} {
    cleanup

    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]
} {blue blue}

test doption-1.5 {can't oncget for delegated option} {
    cleanup

    set result ""
    catch {
        type dog {
            delegate option -color to catthing

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

test doption-1.6 {can't onconfigure for delegated option} {
    cleanup

    set result ""
    catch {
        type dog {
            delegate option -color to catthing

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

test doption-1.7 {delegating unknown options to existing component: error} {
    cleanup

    type cat {
        option -color "black"
    }

    cat create hershey

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

        delegate option * to catthing
    }
    
    set result {}
    catch {dog create spot -colour blue} result
    set result
} {Error in constructor: unknown option "-colour"}

test doption-1.8 {can't delegate local option: order 1} {
    cleanup

    catch {
        type cat {
            option -color "black"
            delegate option -color to hull
        }
    } result

    set result
} {Error in "delegate option -color...", "-color" has been defined locally}

test doption-1.9 {can't delegate local option: order 2} {
    cleanup

    catch {
        type cat {
            delegate option -color to hull
            option -color "black"
        }
    } result

    set result
} {Error in "option -color...", cannot define "-color" locally, it has been delegated}

test doption-1.10 {excepted options are caught properly on cget} {
    cleanup

    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
} {a {unknown option "-b"} {unknown option "-c"}}

test doption-1.11 {excepted options are caught properly on configurelist} {
    cleanup

    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
} {{} {unknown option "-b"} {unknown option "-c"}}

test doption-1.12 {excepted options are caught properly on configure, 1} {
    cleanup

    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
} {{} {unknown option "-b"} {unknown option "-c"}}

test doption-1.13 {excepted options are caught properly on configure, 2} {
    cleanup

    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
} {{-a a A a a} {unknown option "-b"} {unknown option "-c"}}

test doption-1.14 {configure query skips excepted options} {
    cleanup

    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
} {{-d d D d d} {-a a A a a}}


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

test from-1.1 {getting default values} {
    cleanup

    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]
} {AAA BAR}

test from-1.2 {getting non-default values} {
    cleanup

    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] 
} {quux frobozz {-baz frobnitz}}

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


test widgetadaptor-1.1 {creating a widget: hull hijacking} tk {
    cleanup

    widgetadaptor mylabel {
        constructor {args} {
            installhull [label $self]
            $self configurelist $args
        }

        method hull {} { return $hull] }

        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
} {{My Label} {My Label}}

test widgetadaptor-1.2 {destroying a widget with destroy} tk {
    cleanup

    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
} {::mylabel::Snit_inst1 {}}

test widgetadaptor-1.3 {destroying two widgets of the same type with destroy} tk {
    cleanup

    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
} {{::mylabel::Snit_inst1 ::mylabel::Snit_inst2} {}}

test widgetadaptor-1.4 {destroying a widget with rename, then destroy type} tk {
    cleanup

    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
} {::mylabel::Snit_inst1 {}}

test widgetadaptor-1.5 {destroying two widgets of the same type with rename} tk {
    cleanup

    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
} {{::mylabel::Snit_inst1 ::mylabel::Snit_inst2} {}}

test widgetadaptor-1.6 {create/destroy twice, with destroy} tk {
    cleanup

    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
} {::mylabel::Snit_inst1 ::mylabel::Snit_inst2 {}}

test widgetadaptor-1.7 {create/destroy twice, with rename} tk {
    cleanup

    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
} {::mylabel::Snit_inst1 ::mylabel::Snit_inst2 {}}

test widgetadaptor-1.8 {"create" is optional} tk {
    cleanup

    widgetadaptor mylabel {
        constructor {args} {
            installhull [label $self]
        }
        method howdy {} {return "Howdy!"}
    }
    
    mylabel .label
    set a [.label howdy]

    destroy .label
    tkbide
    set a
} {Howdy!}

test widgetadaptor-1.9 {"create" is optional, but must be a valid name} tk {
    cleanup

    widgetadaptor mylabel {
        constructor {args} {
            installhull [label $self]
        }
        method howdy {} {return "Howdy!"}
    }
    
    catch {mylabel foo} result
    tkbide
    set result
} {"::mylabel foo" is not defined}

test widgetadaptor-1.10 {user-defined destructors are called} tk {
    cleanup

    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]
} {{created .label} {destroyed .label}}

test widgetadaptor-1.11 {destroy method not defined for widget types} tk {
    cleanup

    widgetadaptor mylabel { 
        constructor {args} {
            installhull [label $self]
        }
    }
    
    mylabel .label
    catch {.label destroy} result
    destroy .label
    tkbide
    set result
} {".label destroy" is not defined}

test widgetadaptor-1.12 {hull can be repeatedly renamed} tk {
    cleanup

    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]
    tkbide
    set a
} {.foo}

test widgetadaptor-1.13 {widget names can be generated} tk {
    cleanup

    # Don't use this widget type name in any other test.
    widgetadaptor unique {
        constructor {args} {
            installhull [label $self]
        }
    }

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

test widgetadaptor-1.14 {snit::widgetadaptor as hull} tk {
    cleanup

    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
} {{method2: method1} {Some Text} {More Text} ::mylabel2::Snit_inst1 ::mylabel::Snit_inst1 {} {}}

test widgetadaptor-1.15 {snit::widgetadaptor as hull; use rename} tk {
    cleanup

    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
} {{method2: method1} {Some Text} {More Text} ::mylabel2::Snit_inst1 ::mylabel::Snit_inst1 {} {}}

test widgetadaptor-1.16 {BWidget Label as hull} bwidget {
    cleanup

    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
} {{Some Text} {More Text} ::mylabel::Snit_inst1 {}}

test widgetadaptor-1.17 {error in widgetadaptor constructor} tk {
    cleanup

    widgetadaptor mylabel {
        constructor {args} {
            error "Simulated Error"
        }
    }
    
    catch {mylabel .lab} result

    set 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} tk {
    cleanup

    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
} {green ::hull1.frm}

test widget-2.1 {can't redefine hull} tk {
    cleanup

    widget myframe {
        method resethull {} { set hull "" }
    }
    
    myframe .frm

    catch {.frm resethull} result
    set 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} tk {
    cleanup

    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
} {green}

test install-1.2 {installed components are saved properly} tk {
    cleanup

    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
} {green}

test install-1.3 {can't install until hull exists} tk {
    cleanup

    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
        }
    }

    catch {
        myframe .frm
    } result

    set result
} {Error in constructor: tried to install "text" before the hull exists}

test install-1.4 {install queries option database} tk {
    cleanup

    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
} {Courier}

test install-1.5 {explicit options override option database} tk {
    cleanup

    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
} {Times}

test install-1.6 {option db works with targetted options} tk {
    cleanup

    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
} {Courier}

test install-1.7 {install works for snit::types} {
    cleanup

    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
} {black}

test install-1.8 {install can install non-widget components} tk {
    cleanup

    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

} {green}

test install-1.9 {ok if no options are delegated to component} tk {
    cleanup

    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
} {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.
} tk {
    cleanup

    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
} {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.
} tk {
    cleanup

    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 {$a ne $b}
} {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.
} tk {
    cleanup

    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
} {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.
} tk {
    cleanup

    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
} {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.
} tk {
    cleanup

    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
} {red 123}

test installhull-1.2 {
    Options delegated to a widget's hull frame with a different name are 
    initialized from the option database.
} tk {
    cleanup

    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
} {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.
} tk {
    cleanup

    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
} {red 123}

test installhull-1.4 {
    Options delegated to a widget's hull frame with a different name are 
    initialized from the option database.
} tk {
    cleanup

    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
} {red}

test installhull-1.4 {
    Option values read from the option database are overridden by options
    explicitly passed, even if delegated under a different name.
} tk {
    cleanup

    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
} {green 321}


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

test iinfo-1.1 {object info too few args} {
    cleanup

    type dog { }

    dog create spot

    catch {spot info} result
    set result
} {wrong # args: should be "::snit::RT.method.info type selfns win self command args"}

test iinfo-1.2 {object info too many args} {
    cleanup

    type dog { }

    dog create spot

    catch {spot info type foo} result
    set result
} {wrong # args: should be "::snit::RT.method.info.type type selfns win self"}

test iinfo-2.1 {object info type} {
    cleanup

    type dog { }

    dog create spot
    spot info type
} {::dog}

test iinfo-3.1 {object info typevars} {
    cleanup

    type dog { 
        typevariable thisvar 1

        constructor {args} {
            typevariable thatvar 2
        }
    }

    dog create spot
    lsort [spot info typevars]
} {::dog::thatvar ::dog::thisvar}

test iinfo-3.2 {object info typevars with pattern} {
    cleanup

    type dog { 
        typevariable thisvar 1

        constructor {args} {
            typevariable thatvar 2
        }
    }

    dog create spot
    spot info typevars *this*
} {::dog::thisvar}

test iinfo-4.1 {object info vars} {
    cleanup

    type dog { 
        variable hisvar 1

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

    dog create spot
    lsort [spot info vars]
} {::dog::Snit_inst1::hervar ::dog::Snit_inst1::hisvar}

test iinfo-4.2 {object info vars with pattern} {
    cleanup

    type dog { 
        variable hisvar 1

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

    dog create spot
    spot info vars "*his*"
} {::dog::Snit_inst1::hisvar}

test iinfo-5.1 {object info no vars defined} {
    cleanup

    type dog { }

    dog create spot
    list [spot info vars] [spot info typevars]
} {{} {}}

test iinfo-6.1 {info options with no options} {
    cleanup

    type dog { }
    dog create spot

    llength [spot info options]
} {0}

test iinfo-6.2 {info options with only local options} {
    cleanup

    type dog { 
        option -foo a
        option -bar b
    }
    dog create spot

    lsort [spot info options]
} {-bar -foo}

test iinfo-6.3 {info options with local and delegated options} {
    cleanup

    type dog { 
        option -foo a
        option -bar b
        delegate option -quux to sibling
    }
    dog create spot

    lsort [spot info options]
} {-bar -foo -quux}

test iinfo-6.4 {info options with unknown delegated options} tk {
    cleanup

    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
} {-background -bd -bg -borderwidth -class -colormap -container -cursor -foo -height -highlightbackground -highlightcolor -highlightthickness -padx -pady -relief -takefocus -visual -width}

test iinfo-6.5 {info options with exceptions} tk {
    cleanup

    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
} {-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 pattern} tk {
    cleanup

    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
} {-class -colormap -container -cursor}

test iinfo-7.1 {info typemethods, simple case} {
    cleanup

    type dog { }

    dog spot

    lsort [spot info typemethods]
} {create destroy info}

test iinfo-7.2 {info typemethods, with pattern} {
    cleanup

    type dog { }

    dog spot

    spot info typemethods i*
} {info}

test iinfo-7.3 {info typemethods, with explicit typemethods} {
    cleanup

    type dog { 
        typemethod foo {} {}
        delegate typemethod bar to comp
    }

    dog spot

    lsort [spot info typemethods]
} {bar create destroy foo info}

test iinfo-7.4 {info typemethods, with implicit typemethods} {
    cleanup

    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
} {{create destroy info} {create destroy info is length} length}

test iinfo-7.5 {info typemethods, with hierarchical typemethods} {
    cleanup

    type dog { 
        delegate typemethod {comp foo} to comp
        
        typemethod {comp bar} {} {}
    }

    dog create spot

    lsort [spot info typemethods]
} {{comp bar} {comp foo} create destroy info}


test iinfo-8.1 {info methods, simple case} {
    cleanup

    type dog { }

    dog spot

    lsort [spot info methods]
} {destroy info}

test iinfo-8.2 {info methods, with pattern} {
    cleanup

    type dog { }

    dog spot

    spot info methods i*
} {info}

test iinfo-8.3 {info methods, with explicit methods} {
    cleanup

    type dog { 
        method foo {} {}
        delegate method bar to comp
    }

    dog spot

    lsort [spot info methods]
} {bar destroy foo info}

test iinfo-8.4 {info methods, with implicit methods} {
    cleanup

    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
} {{destroy info} {destroy info is length} length}

test iinfo-8.5 {info methods, with hierarchical methods} {
    cleanup

    type dog { 
        delegate method {comp foo} to comp
        
        method {comp bar} {} {}
    }

    dog create spot

    lsort [spot info methods]
} {{comp bar} {comp foo} destroy info}


#-----------------------------------------------------------------------
# Type Introspection

test tinfo-1.1 {type info too few args} {
    cleanup

    type dog { }

    catch {dog info} result
    set result
} {wrong # args: should be "::snit::RT.typemethod.info type command args"}

test tinfo-1.2 {type info too many args} {
    cleanup

    type dog { }

    catch {dog info instances foo bar} result
    set result
} {wrong # args: should be "::snit::RT.typemethod.info.instances type ?pattern?"}

test tinfo-2.1 {type info typevars} {
    cleanup

    type dog { 
        typevariable thisvar 1

        constructor {args} {
            typevariable thatvar 2
        }
    }

    dog create spot
    lsort [dog info typevars]
} {::dog::thatvar ::dog::thisvar}

test tinfo-3.1 {type info instances} {
    cleanup

    type dog { }

    dog create spot
    dog create fido

    lsort [dog info instances]
} {::fido ::spot}

test tinfo-3.2 {widget info instances} tk {
    cleanup

    widgetadaptor mylabel { 
        constructor {args} {
            installhull [label $self]
        }
    }

    mylabel .lab1
    mylabel .lab2

    set result [mylabel info instances]

    destroy .lab1
    destroy .lab2
    tkbide

    lsort $result
} {.lab1 .lab2}

test tinfo-3.3 {type info instances with non-global namespaces} {
    cleanup

    type dog { }

    dog create ::spot

    namespace eval ::dogs:: {
        set ::qname [dog create fido]
    }

    list $qname [lsort [dog info instances]]
} {::dogs::fido {::dogs::fido ::spot}}

test tinfo-3.4 {type info instances with pattern} {
    cleanup

    type dog { }

    dog create spot
    dog create fido

    dog info instances "*f*"
} {::fido}

test tinfo-4.1 {type info typevars with pattern} {
    cleanup

    type dog { 
        typevariable thisvar 1

        constructor {args} {
            typevariable thatvar 2
        }
    }

    dog create spot
    dog info typevars *this*
} {::dog::thisvar}

test tinfo-5.1 {type info typemethods, simple case} {
    cleanup

    type dog { }

    lsort [dog info typemethods]
} {create destroy info}

test tinfo-5.2 {type info typemethods, with pattern} {
    cleanup

    type dog { }

    dog info typemethods i*
} {info}

test tinfo-5.3 {type info typemethods, with explicit typemethods} {
    cleanup

    type dog { 
        typemethod foo {} {}
        delegate typemethod bar to comp
    }

    lsort [dog info typemethods]
} {bar create destroy foo info}

test tinfo-5.4 {type info typemethods, with implicit typemethods} {
    cleanup

    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
} {{create destroy info} {create destroy info is length} length}

test tinfo-5.5 {info typemethods, with hierarchical typemethods} {
    cleanup

    type dog { 
        delegate typemethod {comp foo} to comp
        
        typemethod {comp bar} {} {}
    }

    lsort [dog info typemethods]
} {{comp bar} {comp foo} create destroy info}


#-----------------------------------------------------------------------
# Setting the widget class explicitly

test widgetclass-1.1 {can't set widgetclass for snit::types} {
    cleanup

    catch {
        type dog { 
            widgetclass Dog
        }
    } result
    
    set result
} {widgetclass cannot be set for snit::types}

test widgetclass-1.2 {can't set widgetclass for snit::widgetadaptors} tk {
    cleanup

    catch {
        widgetadaptor dog { 
            widgetclass Dog
        }
    } result
    
    set result
} {widgetclass cannot be set for snit::widgetadaptors}

test widgetclass-1.3 {widgetclass must begin with uppercase letter} tk {
    cleanup

    catch {
        widget dog { 
            widgetclass dog
        }
    } result
    
    set result
} {widgetclass "dog" does not begin with an uppercase letter}

test widgetclass-1.4 {widgetclass can only be defined once} tk {
    cleanup

    catch {
        widget dog { 
            widgetclass Dog
            widgetclass Dog
        }
    } result
    
    set result
} {too many widgetclass statements}

test widgetclass-1.5 {widgetclass set successfully} tk {
    cleanup

    widget dog { 
        widgetclass DogWidget
    }
    
    # The test passes if no error is thrown.
    list ok
} {ok}

test widgetclass-1.6 {implicit widgetclass applied to hull} tk {
    cleanup

    widget dog { 
        typeconstructor {
            option add *Dog.background green 
        }

        method background {} {
            $hull cget -background
        }
    }

    dog .dog
    
    set bg [.dog background]

    destroy .dog
    
    set bg
} {green}

test widgetclass-1.7 {explicit widgetclass applied to hull} tk {
    cleanup

    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
} {green}

#-----------------------------------------------------------------------
# hulltype statement

test hulltype-1.1 {can't set hulltype for snit::types} {
    cleanup

    catch {
        type dog { 
            hulltype Dog
        }
    } result
    
    set result
} {hulltype cannot be set for snit::types}

test hulltype-1.2 {can't set hulltype for snit::widgetadaptors} tk {
    cleanup

    catch {
        widgetadaptor dog { 
            hulltype Dog
        }
    } result
    
    set result
} {hulltype cannot be set for snit::widgetadaptors}

test hulltype-1.3 {hulltype can be frame} tk {
    cleanup

    widget dog { 
        delegate option * to hull
        hulltype frame
    }

    dog .fido
    catch {.fido configure -use} result
    destroy .fido
    tkbide

    set result
} {unknown option "-use"}

test hulltype-1.4 {hulltype can be toplevel} tk {
    cleanup

    widget dog { 
        delegate option * to hull
        hulltype toplevel
    }

    dog .fido
    catch {.fido configure -use} result
    destroy .fido
    tkbide

    set result
} {-use use Use {} {}}

test hulltype-1.5 {hulltype can only be defined once} tk {
    cleanup

    catch {
        widget dog { 
            hulltype frame
            hulltype toplevel
        }
    } result
    
    set result
} {too many hulltype statements}

#-----------------------------------------------------------------------
# expose statement

test expose-1.1 {can't expose nothing} {
    cleanup

    catch {
        type dog { 
            expose
        }
    } result
    
    set result
} {wrong # args: should be "::snit::Comp.statement.expose component ?as? ?methodname?"}


test expose-1.2 {expose a component that's never installed} {
    cleanup

    type dog { 
        expose tail
    }

    dog fido
    
    catch {
        fido tail wag
    } result
    
    set result
} {undefined component "tail"}

test expose-1.3 {exposed method returns component command} {
    cleanup

    type tail {  }

    type dog { 
        expose tail

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

        destructor {
            $tail destroy
        }
    }

    dog fido
    
    fido tail
} {::fido.tail}

test expose-1.4 {exposed method calls component methods} {
    cleanup

    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]
} {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} {
    cleanup

    type dog {
        typemethod generr {} {
            error bogusError bogusInfo bogusCode
        }
    }

    catch {dog generr} result

    global errorInfo errorCode

    list $result [string match "*bogusInfo*" $errorInfo] $errorCode
} {bogusError 1 bogusCode}

test error-1.2 {snit::type constructor errors propagate properly} {
    cleanup

    type dog {
        constructor {} {
            error bogusError bogusInfo bogusCode
        }
    }

    catch {dog fido} result

    global errorInfo errorCode

    list $result [string match "*bogusInfo*" $errorInfo] $errorCode
} {{Error in constructor: bogusError} 1 bogusCode}

test error-1.3 {snit::widget constructor errors propagate properly} tk {
    cleanup

    widget dog {
        constructor {args} {
            error bogusError bogusInfo bogusCode
        }
    }

    catch {dog .fido} result

    global errorInfo errorCode

    list $result [string match "*bogusInfo*" $errorInfo] $errorCode
} {{Error in constructor: bogusError} 1 bogusCode}

test error-1.4 {method errors propagate properly} {
    cleanup

    type dog {
        method generr {} {
            error bogusError bogusInfo bogusCode
        }
    }

    dog fido
    catch {fido generr} result

    global errorInfo errorCode

    list $result [string match "*bogusInfo*" $errorInfo] $errorCode
} {bogusError 1 bogusCode}

test error-1.5 {onconfigure errors propagate properly} {
    cleanup

    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
} {bogusError 1 bogusCode}

test error-1.6 {oncget errors propagate properly} {
    cleanup

    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
} {bogusError 1 bogusCode}

#-----------------------------------------------------------------------
# Externally defined typemethods

test etypemethod-1.1 {external typemethods can be called as expected} {
    cleanup

    type dog { }
    typemethod dog foo {a} {return "+$a+"}
    
    dog foo bar
} {+bar+}

test etypemethod-1.2 {external typemethods can use typevariables} {
    cleanup

    type dog { 
        typevariable somevar "Howdy"
    }
    typemethod dog getvar {} {return $somevar}

    dog getvar
} {Howdy}

test etypemethod-1.3 {typemethods can be redefined dynamically} {
    cleanup

    type dog { 
        typemethod foo {} { return "foo" }
    }
    set a [dog foo]
    
    typemethod dog foo {} { return "bar"}
        
    set b [dog foo]
        
    list $a $b
} {foo bar}

test etypemethod-1.4 {can't define external typemethod if no type} {
    cleanup

    catch {
        typemethod extremelyraredog foo {} { return "bar"}
    } result 

    set result
} {no such type: "extremelyraredog"}

test etypemethod-2.1 {external hierarchical method, two tokens} {} {
    cleanup

    type dog { }
    typemethod dog {wag tail} {} {
        return "wags tail"
    }

    dog wag tail
} {wags tail}

test etypemethod-2.2 {external hierarchical method, three tokens} {} {
    cleanup

    type dog { }
    typemethod dog {wag tail proudly} {} {
        return "wags tail proudly"
    }

    dog wag tail proudly
} {wags tail proudly}

test etypemethod-2.3 {external hierarchical method, three tokens} {} {
    cleanup

    type dog { }
    typemethod dog {wag tail really high} {} {
        return "wags tail really high"
    }

    dog wag tail really high
} {wags tail really high}

test etypemethod-2.4 {redefinition is OK} {} {
    cleanup

    type dog { }
    typemethod dog {wag tail} {} {
        return "wags tail"
    }
    typemethod dog {wag tail} {} {
        return "wags tail briskly"
    }

    dog wag tail
} {wags tail briskly}

test etypemethod-3.1 {prefix/method collision} {} {
    cleanup

    type dog { 
        typemethod wag {} {}
    }

    catch {
        typemethod dog {wag tail} {} {}
    } result

    set result
} {Cannot define "wag tail", "wag" has no submethods.}

test etypemethod-3.2 {prefix/method collision} {} {
    cleanup

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

    catch {
        typemethod dog wag {} {}
    } result

    set result
} {Cannot define "wag", "wag" has submethods.}

test etypemethod-3.3 {prefix/method collision} {} {
    cleanup

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

    catch {
        typemethod dog {wag tail proudly} {} {}
    } result

    set result
} {Cannot define "wag tail proudly", "wag tail" has no submethods.}

test etypemethod-3.4 {prefix/method collision} {} {
    cleanup

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

    catch {
        typemethod dog {wag tail} {} {}
    } result

    set result
} {Cannot define "wag tail", "wag tail" has submethods.}

#-----------------------------------------------------------------------
# Externally defined methods

test emethod-1.1 {external methods can be called as expected} {
    cleanup

    type dog { }
    method dog bark {a} {return "+$a+"}
    
    dog spot
    spot bark woof
} {+woof+}

test emethod-1.2 {external methods can use typevariables} {
    cleanup

    type dog { 
        typevariable somevar "Hello"
    }
    method dog getvar {} {return $somevar}

    dog spot
    spot getvar
} {Hello}

test emethod-1.3 {external methods can use variables} {
    cleanup

    type dog { 
        variable somevar "Greetings"
    }
    method dog getvar {} {return $somevar}

    dog spot
    spot getvar
} {Greetings}

test emethod-1.4 {methods can be redefined dynamically} {
    cleanup

    type dog { 
        method bark {} { return "woof" }
    }

    dog spot

    set a [spot bark]
    
    method dog bark {} { return "arf"}
        
    set b [spot bark]
        
    list $a $b
} {woof arf}

test emethod-1.5 {delegated methods can't be redefined} {
    cleanup

    type dog { 
        delegate method bark to someotherdog
    }

    catch {
        method dog bark {} { return "arf"}
    } result
        
    set result
} {Cannot define "bark", "bark" has been delegated}

test emethod-1.6 {can't define external method if no type} {
    cleanup

    catch {
        method extremelyraredog foo {} { return "bar"}
    } result 

    set result
} {no such type: "extremelyraredog"}

test emethod-2.1 {external hierarchical method, two tokens} {} {
    cleanup

    type dog { }
    method dog {wag tail} {} {
        return "$self wags tail."
    }

    dog spot
    spot wag tail
} {::spot wags tail.}

test emethod-2.2 {external hierarchical method, three tokens} {} {
    cleanup

    type dog { }
    method dog {wag tail proudly} {} {
        return "$self wags tail proudly."
    }

    dog spot
    spot wag tail proudly
} {::spot wags tail proudly.}

test emethod-2.3 {external hierarchical method, three tokens} {} {
    cleanup

    type dog { }
    method dog {wag tail really high} {} {
        return "$self wags tail really high."
    }

    dog spot
    spot wag tail really high
} {::spot wags tail really high.}

test emethod-2.4 {redefinition is OK} {} {
    cleanup

    type dog { }
    method dog {wag tail} {} {
        return "$self wags tail."
    }
    method dog {wag tail} {} {
        return "$self wags tail briskly."
    }

    dog spot
    spot wag tail
} {::spot wags tail briskly.}

test emethod-3.1 {prefix/method collision} {} {
    cleanup

    type dog { 
        method wag {} {}
    }

    catch {
        method dog {wag tail} {} {
            return "$self wags tail."
        }
    } result

    set result
} {Cannot define "wag tail", "wag" has no submethods.}

test emethod-3.2 {prefix/method collision} {} {
    cleanup

    type dog {
        method {wag tail} {} {
            return "$self wags tail."
        }
    }

    catch {
        method dog wag {} {}
    } result

    set result
} {Cannot define "wag", "wag" has submethods.}

test emethod-3.3 {prefix/method collision} {} {
    cleanup

    type dog {
        method {wag tail} {} {}
    }

    catch {
        method dog {wag tail proudly} {} {
            return "$self wags tail."
        }
    } result

    set result
} {Cannot define "wag tail proudly", "wag tail" has no submethods.}

test emethod-3.4 {prefix/method collision} {} {
    cleanup

    type dog {
        method {wag tail proudly} {} {
            return "$self wags tail."
        }
    }

    catch {
        method dog {wag tail} {} {}
    } result

    set result
} {Cannot define "wag tail", "wag tail" has submethods.}


#-----------------------------------------------------------------------
# Macros

test macro-1.1 {can't redefine non-macros} {
    cleanup

    catch {
        snit::macro method {} {}
    } result
    set result
} {invalid macro name "method"}

test macro-1.2 {can define and use a macro} {
    cleanup

    snit::macro hello {name} {
        method hello {} "return {Hello, $name!}"
    }

    type dog {
        hello World
    }

    dog spot

    spot hello

} {Hello, World!}

test macro-1.3 {can redefine macro} {
    cleanup

    snit::macro dup {} {}
    snit::macro dup {} {}

    set dummy "No error"
} {No error}

test macro-1.4 {can define macro in namespace} {
    cleanup

    snit::macro ::test::goodbye {name} {
        method goodbye {} "return {Goodbye, $name!}"
    }

    type dog {
        ::test::goodbye World
    }

    dog spot

    spot goodbye
} {Goodbye, World!}

test macro-1.5 {_proc and _variable are defined} {
    cleanup

    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
} {_variable _proc}

test macro-1.6 {_variable works} {
    cleanup

    snit::macro test1 {} {
        _variable myvar "_variable works"
    }

    snit::macro test2 {} {
        _variable myvar

        method testit {} "return {$myvar}"
    }

    type dog {
        test1
        test2
    }

    dog spot

    spot testit
} {_variable works}

#-----------------------------------------------------------------------
# Component Statement

test component-1.1 {component defines an instance variable} {
    cleanup
    type dog {
        component tail
    }

    dog spot

    namespace tail [spot info vars tail]
} {tail}

test component-1.2 {-public exposes the component} {
    cleanup

    type tail {
        method wag {} {
            return "Wag, wag"
        }
    }

    type dog {
        component tail -public mytail

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

    dog spot

    spot mytail wag
} {Wag, wag}

test component-1.3 {-inherit requires a boolean value} {
    cleanup

    catch {
        type dog {
            component animal -inherit foo
        }
    } result

    set result
} {component animal -inherit: expected boolean value, got "foo"}

test component-1.4 {-inherit delegates unknown methods to the component} {
    cleanup

    type animal {
        method eat {} {
            return "Eat, eat."
        }
    }

    type dog {
        component animal -inherit yes

        constructor {} {
            set animal [animal %AUTO%]
        }
    }

    dog spot

    spot eat
} {Eat, eat.}

test component-1.5 {-inherit delegates unknown options to the component} {
    cleanup
    
    type animal {
        option -size medium
    }

    type dog {
        component animal -inherit yes

        constructor {} {
            set animal [animal %AUTO%]
        }
    }

    dog spot

    spot cget -size
} {medium}

#-----------------------------------------------------------------------
# Typevariables, Variables, Typecomponents, Components

test typevar_var-1.1 {variable/typevariable collisions not allowed: order 1} {
    cleanup

    catch {
        type dog {
            typevariable var
            variable var
        }
    } result

    set result
} {Error in "variable var...", "var" is already a typevariable}

test typevar_var-1.2 {variable/typevariable collisions not allowed: order 2} {
    cleanup

    catch {
        type dog {
            variable var
            typevariable var
        }
    } result

    set result
} {Error in "typevariable var...", "var" is already an instance variable}

test typevar_var-1.3 {component/typecomponent collisions not allowed: order 1} {
    cleanup

    catch {
        type dog {
            typecomponent comp
            component comp
        }
    } result

    set result
} {Error in "component comp...", "comp" is already a typevariable}

test typevar_var-1.4 {component/typecomponent collisions not allowed: order 2} {
    cleanup

    catch {
        type dog {
            component comp
            typecomponent comp
        }
    } result

    set result
} {Error in "typecomponent comp...", "comp" is already an instance variable}

test typevar_var-1.5 {can't delegate options to typecomponents} {
    cleanup

    catch {
        type dog {
            typecomponent comp

            delegate option -opt to comp
        }
    } result

    set result
} {Error in "delegate option -opt...", "comp" is already a typevariable}

test typevar_var-1.5 {can't delegate typemethods to instance components} {
    cleanup

    catch {
        type dog {
            component comp

            delegate typemethod foo to comp
        }
    } result

    set result
} {Error in "delegate typemethod foo...", "comp" is already an instance variable}

test typevar_var-1.6 {can delegate methods to typecomponents} {
    cleanup

    proc echo {args} {return [join $args "|"]}

    type dog {
        typecomponent tail

        typeconstructor {
            set tail echo
        }

        delegate method wag to tail
    }

    dog spot
    spot wag briskly
} {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} {
    cleanup

    type dog {
        option -foo
        option -bar
    }

    set ::dog::Snit_optionInfo(local)
} {-foo -bar}

test optionsyntax-1.2 {islocal flag is set} {
    cleanup

    type dog {
        option -foo
    }

    set ::dog::Snit_optionInfo(islocal--foo)
} {1}

test optionsyntax-2.1 {implicit resource and class} {
    cleanup

    type dog {
        option -foo
    }

    list \
        $::dog::Snit_optionInfo(resource--foo) \
        $::dog::Snit_optionInfo(class--foo)
} {foo Foo}

test optionsyntax-2.2 {explicit resource, default class} {
    cleanup

    type dog {
        option {-foo ffoo}
    }

    list \
        $::dog::Snit_optionInfo(resource--foo) \
        $::dog::Snit_optionInfo(class--foo)
} {ffoo Ffoo}

test optionsyntax-2.3 {explicit resource and class} {
    cleanup

    type dog {
        option {-foo ffoo FFoo}
    }

    list \
        $::dog::Snit_optionInfo(resource--foo) \
        $::dog::Snit_optionInfo(class--foo)
} {ffoo FFoo}

test optionsyntax-2.4 {can't redefine explicit resource} {
    cleanup

    catch {
        type dog {
            option {-foo ffoo}
            option {-foo foo}
        }
    } result

    set result
} {Error in "option {-foo foo}...", resource name redefined from "ffoo" to "foo"}

test optionsyntax-2.5 {can't redefine explicit class} {
    cleanup

    catch {
        type dog {
            option {-foo ffoo Ffoo}
            option {-foo ffoo FFoo}
        }
    } result

    set result
} {Error in "option {-foo ffoo FFoo}...", class name redefined from "Ffoo" to "FFoo"}

test optionsyntax-2.6 {can redefine implicit resource and class} {
    cleanup

    type dog {
        option -foo
        option {-foo ffoo}
        option {-foo ffoo FFoo}
        option -foo
    }
} {::dog}

test optionsyntax-3.1 {no default value} {
    cleanup

    type dog {
        option -foo
    }

    set ::dog::Snit_optionInfo(default--foo)
} {}

test optionsyntax-3.2 {default value, old syntax} {
    cleanup

    type dog {
        option -foo bar
    }

    set ::dog::Snit_optionInfo(default--foo)
} {bar}

test optionsyntax-3.3 {option definition options can be set} {
    cleanup

    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)
} {Bar Validate Configure Cget 1}

test optionsyntax-3.4 {option definition option values accumulate} {
    cleanup

    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)
} {Bar Validate Configure Cget 1}

test optionsyntax-3.5 {option definition option values can be redefined} {
    cleanup

    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)
} {Bar2 Validate2 Configure2 Cget2 0}

test optionsyntax-3.6 {option -readonly defaults to 0} {
    cleanup

    type dog {
        option -foo
    }

    set ::dog::Snit_optio