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


#---------------------------------------------------------------------
# Load the tcltest package

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

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

#---------------------------------------------------------------------
# Load the snit package.
source snit.tcl
namespace import ::snit::*

# cleanup before each test
proc cleanup {} {
    catch {::dog destroy}
    catch {::cat destroy}
}

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


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

test type-1.1 {type names get qualified} {} {
    type dog {}
} {::dog}

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

    dog foo 1 2
} {1 2}

test type-1.3 {upvar works in typemethods} {} {
    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} {} {
    catch {
        type dog { 
            typemethod foo {a type b} { }
        }
    } result
    set result
} {typemethod 'foo's arglist may not contain 'self' or 'type'.}

test type-1.5 {typemethod args can't include self} {} {
    catch {
        type dog { 
            typemethod foo {a self b} { }
        }
    } result
    set result
} {typemethod 'foo's arglist may not contain 'self' or 'type'.}


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

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

    dog create spot
} {::spot}

test creation-1.2 {type instance names can be generated} {} {
    # 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} {} {
    type dog { }
    
    dog fido
} {::fido}


test creation-1.4 {constructor arg can't be type} {} {
    catch {
        type dog { 
            constructor {type} { }
        }
    } result
    set result
} {constructor's argument may not be 'type'}

test creation-1.5 {constructor arg can't be self} {} {
    catch {
        type dog { 
            constructor {self} { }
        }
    } result
    set result
} {constructor's argument may not be 'self'}


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

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

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

test method-1.2 {methods can call other methods} {} {
    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} {} {
    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} {} {
    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} {} {
    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} {} {
    type dog { }

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

test method-1.7 {instance method can call type method} {} {
    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} {} {
    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} {} {
    type dog { 
        method bark {volume} { }
    }

    dog create spot
    set result ""
    catch {spot bark} result
    set result
} {wrong # args: should be "::spot bark volume"}

test method-1.10 {too many arguments} {} {
    type dog { 
        method bark {volume} { }
    }

    dog create spot
    set result ""
    catch {spot bark really loud} result
    set result
} {wrong # args: should be "::spot bark volume"}

test type-1.11 {method args can't include type} {} {
    catch {
        type dog { 
            method foo {a type b} { }
        }
    } result
    set result
} {method 'foo's arglist may not contain 'self' or 'type'.}

test type-1.12 {ethod args can't include self} {} {
    catch {
        type dog { 
            method foo {a self b} { }
        }
    } result
    set result
} {method 'foo's arglist may not contain 'self' or 'type'.}


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

test typevariable-1.1 {typevarname qualifies typevariables} {} {
    namespace delete ::dog::

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

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

test typevariable-1.2 {undefined typevariables are OK} {} {
    namespace delete ::dog::

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

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

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

    type dog { 
        typevariable greetings Howdy

        typemethod greet {} {
            return $greetings
        }
    }

    dog greet
} {Howdy}

test typevariable-1.6 {typevariables can used in procs} {} {
    namespace delete ::dog::

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

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

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

test ivariable-1.2 {undefined instance variables are OK} {} {
    namespace delete ::dog::

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

test ivariable-1.3 {instance variables are destroyed automatically} {} {
    namespace delete ::dog::

    type dog { 
        constructor {args} {
            variable greeting

            set greeting Hi
        }
    }

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

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

test ivariable-1.4 {defined instance variables need not be declared} {} {
    namespace delete ::dog::

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

    type dog { 
        variable greetings

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

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

test ivariable-1.6 {instance variables can be initialized in the definition} {} {
    namespace delete ::dog::

    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 self 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 "self": no such variable}

test ivariable-1.8 {varname is illegal when self 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 "self": no such variable}

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

    type dog { 
        variable greeting Howdy

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

        proc callee {self} {
            return $greeting
        }
    }

    dog create spot

    spot caller
} {Howdy}

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

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

test codename-1.2 {procs with self work} {} {
    cleanup
    type dog {
        variable datum foo

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

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

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

    dog create spot
    spot cget -color
} {golden}

test option-1.2 {options can be set} {} {
    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} {} {
    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} {} {
    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} {} {
    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} {} {
    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} {} {
    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} {} {
    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 ""} {} {
    type dog {
        option -color
    }

    dog create spot
    spot cget -color
} {}

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

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

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

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

test option-1.12 {configure -opt returns info, explicit options} {} {
    type papers {
        option -akcflag 1
    }
    type dog {
        option -color black
        delegate option -akc to papers as -akcflag
        constructor {args} {
            component papers is [papers create $self.papers]
        }
    }

    dog create spot
    spot configure -akc 0
    spot configure -akc
} {-akc {} {} 1 0}

test option-1.13 {configure -unknownopt} {} {
    type papers {
        option -akcflag 1
    }
    type dog {
        option -color black
        delegate option -akc to papers as -akcflag
        constructor {args} {
            component papers is [papers create $self.papers]
        }
    }

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

test option-1.14 {configure returns info, unknown options} tk {
    widget myframe { 
        option -foo a
        delegate option -width to hull
        delegate option * to hull
        constructor {args} {
            component hull is [frame $self]
        }
    }
    myframe .frm
    set a [.frm configure -foo]
    set b [.frm configure -width]
    set c [.frm configure -height]
    destroy .frm
    list $a $b $c
} {{-foo {} {} a a} {-width width Width 0 0} {-height height Height 0 0}}

test option-1.15 {configure -opt unknown to implicit component} tk {
    widget myframe { 
        delegate option * to hull
        constructor {args} {
            component hull is [frame $self]
        }
    }
    myframe .frm
    catch {.frm configure -quux} result
    destroy .frm
    set result
} {unknown option "-quux"}

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


test onconfigure-1.1 {invalid onconfigure methods are caught.} {} {
    catch {
        type dog { 
            onconfigure -color {value} { }
        }
    } result
    set result
} {onconfigure -color: option '-color' unknown.}

test onconfigure-1.2 {onconfigure methods take one argument.} {} {
    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.} {} {
    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 or self.} {} {
    catch {
        type dog { 
            option -color
            onconfigure -color {type} { }
        }
    } result
    set result
} {onconfigure's argument may not be 'type'}

test onconfigure-1.5 {onconfigure arg can't be type or self.} {} {
    catch {
        type dog { 
            option -color
            onconfigure -color {self} { }
        }
    } result
    set result
} {onconfigure's argument may not be 'self'}

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

test oncget-1.1 {invalid oncget methods are caught.} {} {
    catch {
        type dog {
            oncget -color { }
        }
    } result
    set result
} {oncget -color: option '-color' unknown.}

test oncget-1.2 {oncget methods work.} {} {
    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} {} {
    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} {} {
    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} {} {
    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} {} {
    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} {} {
    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} {} {
    namespace delete dog

    type dog { 
        option -color golden
    }
    
    set a [info exists ::dog::::spot::options]
    dog create spot
    set b [info exists ::dog::::spot::options]
    spot destroy
    set c [info exists ::dog::::spot::options]
    list $a $b $c [info commands ::dog::spot]
} {0 1 0 {}}

test destroy-1.2 {incomplete objects are destroyed} {} {
    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]
} {{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 {syntax error: delegate foo} {} {
    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 {syntax error: delegate method foo as} {} {
    cleanup

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

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

test delegate-1.3 {syntax error: delegate method foo to bar as} {} {
    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 {syntax error: delegate method foo to bar foo} {} {
    cleanup

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

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

#-----------------------------------------------------------------------
# component

test component-1.1 {retrieving undefined component.} {
    cleanup

    set result ""

    type dog {
        method foo {} {
            component foo
        }
    }

    dog create spot
    catch {spot foo} result
    set result
} {component 'foo' is undefined in ::dog ::spot.}

test component-1.2 {defining and retrieving component.} {
    cleanup

    type dog {
        constructor {args} {
            component foo is bar
        }
        method foo {} {
            component foo
        }
    }

    dog create spot
    spot foo
} {bar}


#-----------------------------------------------------------------------
# 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} {
            component string is 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} {
            component string is string
        }

        delegate method length to string
    }

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

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

    type dog {
        constructor {args} {
            component string is 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} {
            component stringhandler is string
        }

        delegate method * to stringhandler
    }

    dog create spot
    set result ""
    catch {spot foo bar} result
    set result
} {'::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.}

#-----------------------------------------------------------------------
# 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} {
            component catthing is ::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} {
            component catthing is ::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} {
            component catthing is ::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} {
            component catthing is ::hershey
            $self configurelist $args
        }

        delegate option * to catthing
    }
    
    set result {}
    catch {dog create spot -colour blue} result
    set result
} {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.}

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




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

test widget-1.1 {creating a widget} tk {
    cleanup

    widget mylabel {
        constructor {args} {
            component hull is [label $self]
            $self configurelist $args
        }

        method hull {} { return [component 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

    list $a $b
} {{My Label} {My Label}}

test widget-1.2 {"create" is optional} tk {
    cleanup

    widget mylabel {
        constructor {args} {
            component hull is [label $self]
        }
        method howdy {} {return "Howdy!"}
    }
    
    mylabel .label
    set a [.label howdy]

    destroy .label
    set a
} {Howdy!}

test widget-1.3 {"create" is optional, but must be a valid name.} tk {
    cleanup

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

test widget-1.4 {user-defined destructors are called} tk {
    cleanup

    widget mylabel { 
        typevariable flag ""
        
        constructor {args} {
            component hull is [label $self]
            set flag "created $self"
        }

        destructor {
            set flag "destroyed $self"
        }

        typemethod getflag {} {
            return $flag
        }
    }
    
    mylabel .label
    set a [mylabel getflag]
    destroy .label
    list $a [mylabel getflag]
} {{created .label} {destroyed .label}}

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

    widget mylabel { 
        constructor {args} {
            component hull is [label $self]
        }
    }
    
    mylabel .label
    catch {.label destroy} result
    destroy .label
    set result
} {'.label destroy' is not defined.}

test widget-1.6 {hull can be repeatedly renamed.} tk {
    cleanup

    widget basetype { 
        constructor {args} {
            component hull is [label $self]
        }

        method basemethod {} { return "basemethod" }
    }

    widget w1 {
        constructor {args} {
            component hull is [basetype create $self]
        }
    }

    widget w2 { 
        constructor {args} {
            component hull is [w1 $self]
        }
    }
    
    w2 .foo
} {.foo}

test widget-1.7 {widget names can be generated.} tk {
    cleanup

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

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

test widget-1.8 {instance command can be called without hull.} tk {
    cleanup

    widget mywidget {
        option -datum ""
        constructor {args} {
            $self configure -datum "No Hull Yet"
            component hull is [label $self]
        }
        delegate option * to hull
    }
    
    mywidget .mywidget
    set result [.mywidget cget -datum]
    destroy .mywidget
    set result
} {No Hull Yet}



#-----------------------------------------------------------------------
# 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 "::spot info 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 "::spot info type"}

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::spot::hervar ::dog::spot::hisvar}

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

    type dog { }

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

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

    widget myframe { 
        option -foo a
        delegate option * to hull
        constructor {args} {
            component hull is [frame $self]
        }
    }
    myframe .frm

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

#-----------------------------------------------------------------------
# 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 info command args"}

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

    type dog { }

    catch {dog info instances foo} result
    set result
} {wrong # args: should be "::dog info instances"}

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

    widget mylabel { 
        constructor {args} {
            component hull is [label $self]
        }
    }

    mylabel .lab1
    mylabel .lab2

    set result [mylabel info instances]
    destroy .lab1
    destroy .lab2
    lsort $result
} {.lab1 .lab2}




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

::tcltest::cleanupTests
exit



