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

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

#---------------------------------------------------------------------
# Load the snit package.
source snit.tcl
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
}


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


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


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


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

#-----------------------------------------------------------------------
# selfname and renaming

test rename-1.1 {selfname returns name of instance name variable} {} {
    cleanup

    type dog { 
        method selfname {} {
            return [selfname]
        }
    }

    dog fido
    fido selfname
} {::dog::Snit_inst1::Snit_instance}

test rename-1.2 {instances can be renamed.} {} {
    cleanup

    type dog { 
        method names {} {
            list [selfname] $selfns $win $self
        }
    }

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

    concat $a $b
} {::dog::Snit_inst1::Snit_instance ::dog::Snit_inst1 ::fido ::fido ::dog::Snit_inst1::Snit_instance ::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 {}}

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

#-----------------------------------------------------------------------
# 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 {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 {} {} 1 0} {-color {} {} black red}}

test option-1.11 {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 {} {} black red}

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

    type papers {
        option -akcflag 1
    }

    type dog {
        option -color black
        delegate option -akc to papers as -akcflag
        constructor {args} {
            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} {} {
    cleanup

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

    widgetadaptor 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
    tkbide
    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 {
    cleanup

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

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

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

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

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

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



#-----------------------------------------------------------------------
# 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]
} {{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 "string 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}}

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


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

    widgetadaptor 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
    tkbide
    list $a $b
} {{My Label} {My Label}}

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

    widgetadaptor mylabel {
        constructor {} {
            component hull is [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 {} {
            component hull is [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 {} {
            component hull is [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 {} {
            component hull is [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 {} {
            component hull is [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 {} {
            component hull is [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} {
            component hull is [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} {
            component hull is [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} {
            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
    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} {
            component hull is [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} {
            component hull is [label $self]
        }

        method basemethod {} { return "basemethod" }
    }

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

    widgetadaptor w2 { 
        constructor {args} {
            component hull is [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} {
            component hull is [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} {
            component hull is [label $self]
            $self configurelist $args
        }
        method method1 {} {
            return "method1"
        }
        delegate option * to hull
    }

    widgetadaptor mylabel2 {
        constructor {args} {
            component hull is [mylabel $self]
            $self configurelist $args
        }
        method method2 {} {
            return "method2: [[component 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} {
            component hull is [label $self]
            $self configurelist $args
        }
        method method1 {} {
            return "method1"
        }
        delegate option * to hull
    }

    widgetadaptor mylabel2 {
        constructor {args} {
            component hull is [mylabel $self]
            $self configurelist $args
        }
        method method2 {} {
            return "method2: [[component 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} {
            component hull is [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 {}}

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

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

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

    widgetadaptor myframe { 
        option -foo a
        delegate option * to hull
        constructor {args} {
            component hull is [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}

#-----------------------------------------------------------------------
# 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} result
    set result
} {wrong # args: should be "::snit::TypeInfo_instances type"}

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




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

::tcltest::cleanupTests
exit



