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

# Note:
#    The tests assume tcltest 2.1


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

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 math::statistics."
	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 "- 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]} {
            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
    catch {option clear}
}


#-----------------------------------------------------------------------
# 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 UniqueName-1.1 {no name collision} -body {
    set counter 0

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

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

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

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

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

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

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

test 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::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 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 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.}

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


#-----------------------------------------------------------------------
# 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::CallInstance ::dog::Snit_inst1} {::snit::CallInstance ::dog::Snit_inst1 {A B}} {::snit::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::CallInstance ::dog::Snit_inst1} ::dog::Snit_inst1 ::fido ::fido {::snit::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 { }

    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}


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

test typevariable-1.1 {typevarname qualifies typevariables} {} {
    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}

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

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

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

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

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 [varname 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 {varname is illegal when selfns is undefined.} {} {
    cleanup

    type dog { 
        method caller {} {
            callee
        }
        proc callee {} {
            varname 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}

#-----------------------------------------------------------------------
# codename

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
} {{-akc akc Akc 1 0} {-color color Color black red}}

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

    dog create spot
    spot configure -akc 0
    spot configure -akc
} result

    set result
} {-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]
        }
    }

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

    global errorInfo
    if {[catch {
        myframe .frm
        set a [.frm configure -foo]
        set b [.frm configure -width]
        set c [.frm configure -height]
        destroy .frm
        tkbide
    } result]} {
        puts "Stack Trace <\n$errorInfo>"
        error $result
    }
    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
} {badly named option 'nohyphen'}

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

    catch {
        type dog {
            option -Upper
        }
    } result

    set result
} {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
} {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
} {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
} {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
} {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}


#-----------------------------------------------------------------------
# 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
} {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} {
            $self configurelist $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}}


#-----------------------------------------------------------------------
# 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
} {syntax error in definition: delegate foo bar...}

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
} {syntax error in definition: delegate method foo...}

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

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

    set result
} {syntax error in definition: delegate method foo...}

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
} {syntax error in definition: delegate method foo...}

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

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

    set result
} {syntax error in definition: delegate method *...}

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

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

    set result
} {syntax error in definition: delegate method *...}

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
} {syntax error in definition: delegate method *...}

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

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

    set result
} {syntax error in definition: delegate method foo...}

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

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

    set result
} {syntax error in definition: delegate method foo...}


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

# {'::spot foo' is not defined.}

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
} {cannot delegate 'foo'; it has been defined locally.}

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

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

    set result
} {cannot delegate 'foo'; it has been defined locally.}

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


#-----------------------------------------------------------------------
# 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
} {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
} {cannot delegate '-color'; it 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
} {cannot delegate '-color'; it has been defined locally.}

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}

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

    list $a $b
} {red Black}

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 "::dog::Snit_methodinfo 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::InstanceInfo_type type selfns win self"}

test iinfo-1.3 {object info type} {
    cleanup

    type dog { }

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

test iinfo-1.4 {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-1.5 {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 ::dog::Snit_inst1::options}

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

    type dog { }

    dog create spot
    list [spot info vars] [spot info typevars]
} {::dog::Snit_inst1::options {}}

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

    type dog { }
    dog create spot

    llength [spot info options]
} {0}

test iinfo-1.8 {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-1.9 {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-1.9 {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-1.10 {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-1.11 {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-1.12 {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-1.13 {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}



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

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

    type dog { }

    catch {dog info} result
    set result
} {wrong # args: should be "::dog::Snit_typemethodinfo 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::TypeInfo_instances type ?pattern?"}

test tinfo-1.3 {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-1.4 {type info instances} {
    cleanup

    type dog { }

    dog create spot
    dog create fido

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

test tinfo-1.5 {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-1.6 {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-1.7 {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-1.8 {type info instances with pattern} {
    cleanup

    type dog { }

    dog create spot
    dog create fido

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

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

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

        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::Type.Expose type 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'}

#-----------------------------------------------------------------------
# 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', it 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'}


#---------------------------------------------------------------------
# Clean up

::tcltest::cleanupTests