File: clay.test

package info (click to toggle)
tcllib 1.21%2Bdfsg-1
links: PTS
area: main
in suites: bookworm
size: 69,456 kB
sloc: tcl: 266,493; ansic: 14,259; sh: 2,936; xml: 1,766; yacc: 1,145; pascal: 881; makefile: 112; perl: 84; f90: 84; python: 33; ruby: 13; php: 11
file content (6273 lines) | stat: -rw-r--r-- 156,658 bytes
## -*- tcl -*-
# -------------------------------------------------------------------------

namespace eval ::oo::dialect {
    variable has ; set has(tip470) 0
}

# clay.test - Copyright (c) 2018 Sean Woods
# -------------------------------------------------------------------------

set MODDIR [file dirname [file dirname [file join [pwd] [info script]]]]
if {[file exists [file join $MODDIR devtools testutilities.tcl]]} {
  # Running inside tcllib
  set TCLLIBMOD $MODDIR
} else {
  set TCLLIBMOD [file join $MODDIR .. .. tcllib modules]
}
source [file join $TCLLIBMOD devtools testutilities.tcl]

testsNeedTcl     8.6
testsNeedTcltest 2
testsNeed        TclOO 1

support {}
testing {
    useLocal clay.tcl clay
}

set ::clay::trace 0

# -------------------------------------------------------------------------
# Handle multiple implementation testing
#

array set preserve [array get ::clay::uuid::accel]

proc implementations {} {
    variable ::clay::uuid::accel
    foreach {a v} [array get accel] {if {$v} {lappend r $a}}
    lappend r tcl; set r
}

proc select_implementation {impl} {
    variable ::clay::uuid::accel
    foreach e [array names accel] { set accel($e) 0 }
    if {[string compare "tcl" $impl] != 0} {
        set accel($impl) 1
    }
}

proc reset_implementation {} {
    variable ::clay::uuid::accel
    array set accel [array get ::preserve]
}

# -------------------------------------------------------------------------
# Setup any constraints
#

# -------------------------------------------------------------------------
# Now the package specific tests....
# -------------------------------------------------------------------------

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

foreach impl [implementations] {
    select_implementation $impl

    test uuid-1.0-$impl "uuid requires args" {
        list [catch {clay::uuid} msg]
    } {1}

    test uuid-1.1-$impl "uuid generate should create a 36 char string uuid" {
        list [catch {string length [clay::uuid generate]} msg] $msg
    } {0 36}

    test uuid-1.2-$impl "uuid comparison of uuid with self should be true" {
        list [catch {
            set a [clay::uuid generate]
            clay::uuid equal $a $a
        } msg] $msg
    } {0 1}

    test uuid-1.3-$impl "uuid comparison of two different uuids should be false" {
        list [catch {
            set a [clay::uuid generate]
            set b [clay::uuid generate]
            clay::uuid equal $a $b
        } msg] $msg
    } {0 0}

    reset_implementation
}


# Modification History:
###
# Modification 2018-10-30
# Fixed an error in our ancestry mapping and developed tests to
# ensure we are actually following in the order TclOO follows methods
###
# Modification 2018-10-21
# The clay metaclass no longer exports the clay method
# to oo::class and oo::object, and clay::ancestors no
# longer returns any class that lacks the clay method
###
# Modification 2018-10-10
# clay::ancestors now rigged to descend into all classes depth-first
# and then place metaclasses at the end of the search
###
# -------------------------------------------------------------------------

# -------------------------------------------------------------------------
# Test Helpers
###
proc dict_compare {a b} {
  set result {}
  set A {}
  dict for {f v} $a {
    set f [string trim $f :/]
    if {$f eq {.}} continue
    dict set A $f $v
  }
  set B {}
  dict for {f v} $b {
    set f [string trim $f :/]
    if {$f eq {.}} continue
    dict set B $f $v
  }
  dict for {f v} $A {
    if {[dict exists $B $f]} {
      if {[dict get $B $f] ne $v} {
        lappend result [list B $f [dict get $B $f] [list != $v]]
      }
    } else {
      lappend result [list B $f $v missing]
    }
  }
  dict for {f v} $B {
    if {![dict exists $A $f]} {
      lappend result [list A $f $v missing]
    }
  }
  return $result
}

test dict-compare-001 {Test our testing method} {
  dict_compare {} {}
} {}

test dict-compare-002 {Test our testing method} {
  dict_compare {a 1} {}
} {{B a 1 missing}}

test dict-compare-003 {Test our testing method} {
  dict_compare {a 1 b 2} {a 1 b 2}
} {}

test dict-compare-003.a {Test our testing method} {
  dict_compare {a 1 b 2} {b 2 a 1 }
} {}

test dict-compare-003.b {Test our testing method} {
  dict_compare {b 2 a 1} {a 1 b 2}
} {}


test dict-compare-004 {Test our testing method} {
  dict_compare {a: 1 b: 2} {a 1 b 2}
} {}

test dict-compare-005 {Test our testing method} {
  dict_compare {a 1 b 3} {a 1 b 2}
} {{B b 2 {!= 3}}}


###
# Test canonical mapping
###


test {test-storage-0001} {Test ::clay::tree::storage with foo bar baz} {
  clay::tree::storage {foo bar baz}
} {foo bar baz}


test {test-storage-0002} {Test ::clay::tree::storage with foo bar baz/} {
  clay::tree::storage {foo bar baz/}
} {foo bar baz}


test {test-storage-0003} {Test ::clay::tree::storage with foo bar .} {
  clay::tree::storage {foo bar .}
} {foo bar .}


test {test-storage-0004} {Test ::clay::tree::storage with foo/ bar/ .} {
  clay::tree::storage {foo/ bar/ .}
} {foo bar .}


test {test-storage-0005} {Test ::clay::tree::storage with foo . bar . baz .} {
  clay::tree::storage {foo . bar . baz .}
} {foo . bar . baz .}


test {test-storage-0006} {Test ::clay::tree::storage with foo bar baz bat:} {
  clay::tree::storage {foo bar baz bat:}
} {foo bar baz bat:}


test {test-storage-0007} {Test ::clay::tree::storage with foo:} {
  clay::tree::storage {foo:}
} {foo:}


test {test-storage-0008} {Test ::clay::tree::storage with foo/bar/baz/bat:} {
  clay::tree::storage {foo/bar/baz/bat:}
} {foo bar baz bat:}


dict set r foo/ bar/ baz 1
dict set s foo/ bar/ baz 0
set t [clay::tree::merge $r $s]

test rmerge-0001 {Test that the root is marked as a branch} {
  dict get $t foo bar baz
} 0

set r [dict create]
clay::tree::dictmerge r {
  foo/ {
    bar/ {
      baz 1
      bing: 2
      bang { bim 3 boom 4 }
      womp: {a 1 b 2}
    }
  }
}

test dictmerge-0001 {Test that the root is marked as a branch} {
  dict exists $r .
} 1
test dictmerge-0002 {Test that branch foo is marked correctly} {
  dict exists $r foo .
} 1
test dictmerge-0003 {Test that branch bar is marked correctly} {
  dict exists $r foo bar .
} 1
test dictmerge-0004 {Test that leaf foo/bar/bang is not marked as branch despite being a dict} {
  dict exists $r foo bar bang .
} 0
test dictmerge-0004 {Test that leaf foo/bar/bang/bim exists} {
  dict exists $r foo bar bang bim
} 1
test dictmerge-0005 {Test that leaf foo/bar/bang/boom exists} {
  dict exists $r foo bar bang boom
} 1

###
# Replace bang with bang/
###
clay::tree::dictmerge r {
  foo/ {
    bar/ {
      bang/ {
        whoop 1
      }
    }
  }
}

test dictmerge-0006 {Test that leaf foo/bar/bang/bim ceases to exist} {
  dict exists $r foo bar bang bim
} 0
test dictmerge-0007 {Test that leaf foo/bar/bang/boom exists} {
  dict exists $r foo bar bang boom
} 0

test dictmerge-0008 {Test that leaf foo/bar/bang is now a branch} {
  dict exists $r foo bar bang .
} 1

test branch-0001 {Test that foo/ is a branch} {
  clay::tree::is_branch $r foo/
} 1
test branch-0002 {Test that foo is a branch} {
  clay::tree::is_branch $r foo
} 1
test branch-0003 {Test that foo/bar/ is a branch} {
  clay::tree::is_branch $r {foo/ bar/}
} 1
test branch-0004 {Test that foo bar is not branch} {
  clay::tree::is_branch $r {foo bar}
} 1
test branch-0004 {Test that foo/ bar is not branch} {
  clay::tree::is_branch $r {foo/ bar}
} 0


test {test-branch-0001} {Test that  foo is_branch = 1} {
  clay::tree::is_branch $r { foo}
} 1


test {test-branch-0002} {Test that  foo: is_branch = 0} {
  clay::tree::is_branch $r { foo:}
} 0


test {test-branch-0003} {Test that  foo/ is_branch = 1} {
  clay::tree::is_branch $r { foo/}
} 1


test {test-branch-0004} {Test that  .foo is_branch = 0} {
  clay::tree::is_branch $r { .foo}
} 0


test {test-branch-0005} {Test that foo bar is_branch = 1} {
  clay::tree::is_branch $r {foo bar}
} 1


test {test-branch-0006} {Test that foo bar: is_branch = 0} {
  clay::tree::is_branch $r {foo bar:}
} 0


test {test-branch-0007} {Test that foo bar/ is_branch = 1} {
  clay::tree::is_branch $r {foo bar/}
} 1


test {test-branch-0008} {Test that foo .bar is_branch = 0} {
  clay::tree::is_branch $r {foo .bar}
} 0


test {test-branch-0009} {Test that foo bar baz is_branch = 0} {
  clay::tree::is_branch $r {foo bar baz}
} 0


test {test-branch-0010} {Test that foo bar baz: is_branch = 0} {
  clay::tree::is_branch $r {foo bar baz:}
} 0


test {test-branch-0011} {Test that foo bar baz/ is_branch = 1} {
  clay::tree::is_branch $r {foo bar baz/}
} 1


test {test-branch-0012} {Test that foo bar .baz is_branch = 0} {
  clay::tree::is_branch $r {foo bar .baz}
} 0


test {test-branch-0013} {Test that foo bar bing is_branch = 0} {
  clay::tree::is_branch $r {foo bar bing}
} 0


test {test-branch-0014} {Test that foo bar bing: is_branch = 0} {
  clay::tree::is_branch $r {foo bar bing:}
} 0


test {test-branch-0015} {Test that foo bar bing/ is_branch = 1} {
  clay::tree::is_branch $r {foo bar bing/}
} 1


test {test-branch-0016} {Test that foo bar .bing is_branch = 0} {
  clay::tree::is_branch $r {foo bar .bing}
} 0


test {test-branch-0017} {Test that foo bar bang is_branch = 1} {
  clay::tree::is_branch $r {foo bar bang}
} 1


test {test-branch-0018} {Test that foo bar bang: is_branch = 0} {
  clay::tree::is_branch $r {foo bar bang:}
} 0


test {test-branch-0019} {Test that foo bar bang/ is_branch = 1} {
  clay::tree::is_branch $r {foo bar bang/}
} 1


test {test-branch-0020} {Test that foo bar .bang is_branch = 0} {
  clay::tree::is_branch $r {foo bar .bang}
} 0


test {test-branch-0021} {Test that foo bar bang whoop is_branch = 0} {
  clay::tree::is_branch $r {foo bar bang whoop}
} 0


test {test-branch-0022} {Test that foo bar bang whoop: is_branch = 0} {
  clay::tree::is_branch $r {foo bar bang whoop:}
} 0


test {test-branch-0023} {Test that foo bar bang whoop/ is_branch = 1} {
  clay::tree::is_branch $r {foo bar bang whoop/}
} 1


test {test-branch-0024} {Test that foo bar bang .whoop is_branch = 0} {
  clay::tree::is_branch $r {foo bar bang .whoop}
} 0


# -------------------------------------------------------------------------
# dictmerge Testing - oometa
unset -nocomplain foo
clay::tree::dictmerge foo {
  option/ {
    color/ {
      label Color
      default green
    }
  }
}
clay::tree::dictmerge foo {
  option/ {
    color/ {
      default purple
    }
  }
}

test oometa-0001 {Invoking dictmerge with empty args on a non existent variable create an empty variable} {
  dict get $foo option color default
} purple
test oometa-0002 {Invoking dictmerge with empty args on a non existent variable create an empty variable} {
  dict get $foo option color label
} Color

unset -nocomplain foo
set foo {. {}}
::clay::tree::dictmerge foo {. {} color {. {} default green label Color}}
::clay::tree::dictmerge foo {. {} color {. {} default purple}}
test oometa-0003 {Recursive merge problem from oometa/clay find} {
  dict get $foo color default
} purple
test oometa-0004 {Recursive merge problem from oometa/clay find} {
  dict get $foo color label
} Color

unset -nocomplain foo
set foo {. {}}
::clay::tree::dictmerge foo {. {} color {. {} default purple}}
::clay::tree::dictmerge foo {. {} color {. {} default green label Color}}
test oometa-0005 {Recursive merge problem from oometa/clay find} {
  dict get $foo color default
} green
test oometa-0006 {Recursive merge problem from oometa/clay find} {
  dict get $foo color label
} Color

test oometa-0008 {Un-Sanitized output} {
  set foo
} {. {} color {. {} default green label Color}}

test oometa-0009 {Sanitize} {
  clay::tree::sanitize $foo
} {color {default green label Color}}


# -------------------------------------------------------------------------
# dictmerge Testing - clay
unset -nocomplain foo
test clay-0001 {Invoking dictmerge with empty args on a non existent variable create an empty variable} {
  ::clay::tree::dictmerge foo
  set foo
} {. {}}

unset -nocomplain foo
::clay::tree::dictset foo bar/ baz/ bell bang

test clay-0002 {For new entries dictmerge is essentially a set} {
  dict get $foo bar baz bell
} {bang}
::clay::tree::dictset foo bar/ baz/ boom/ bang
test clay-0003 {For entries that do exist a zipper merge is performed} {
  dict get $foo bar baz bell
} {bang}
test clay-0004 {For entries that do exist a zipper merge is performed} {
  dict get $foo bar baz boom
} {bang}

::clay::tree::dictset foo bar/ baz/ bop {color green flavor strawberry}

test clay-0005 {Leaves are replaced even if they look like a dict} {
  dict get $foo bar baz bop
} {color green flavor strawberry}

::clay::tree::dictset foo bar/ baz/ bop {color yellow}
test clay-0006 {Leaves are replaced even if they look like a dict} {
  dict get $foo bar baz bop
} {color yellow}

::clay::tree::dictset foo bar/ baz/ bang/ {color green flavor strawberry}
test clay-0007a {Branches are merged} {
  dict get $foo bar baz bang
} {. {} color green flavor strawberry}

::clay::tree::dictset foo bar/ baz/ bang/ color yellow
test clay-0007b {Branches are merged}  {
  dict get $foo bar baz bang
} {. {} color yellow flavor strawberry}

::clay::tree::dictset foo bar/ baz/ bang/ {color blue}
test clay-0007c {Branches are merged}  {
  dict get $foo bar baz bang
} {. {} color blue flavor strawberry}

::clay::tree::dictset foo bar/ baz/ bang/ shape: {Sort of round}
test clay-0007d {Branches are merged} {
  dict get $foo bar baz bang
} {. {} color blue flavor strawberry shape: {Sort of round}}

::clay::tree::dictset foo bar/ baz/ bang/ color yellow
test clay-0007e {Branches are merged}  {
  dict get $foo bar baz bang
} {. {} color yellow flavor strawberry shape: {Sort of round}}

::clay::tree::dictset foo bar/ baz/ bang/ {color blue}
test clay-0007f {Branches are merged}  {
  dict get $foo bar baz bang
} {. {} color blue flavor strawberry shape: {Sort of round}}

::clay::tree::dictset foo dict my_var 10
::clay::tree::dictset foo dict my_other_var 9

test clay-0007g {Branches are merged}  {
  dict get $foo dict
} {. {} my_var 10 my_other_var 9}

::clay::tree::dictset foo dict/ my_other_other_var 8
test clay-0007h {Branches are merged}  {
  dict get $foo dict
} {. {} my_var 10 my_other_var 9 my_other_other_var 8}


::clay::tree::dictmerge foo {option/ {color {type color} flavor {sense taste}}}
::clay::tree::dictmerge foo {option/ {format {default ascii}}}

test clay-0008 {Whole dicts are merged}  {
  dict get $foo option color
} {type color}
test clay-0009 {Whole dicts are merged}  {
  dict get $foo option flavor
} {sense taste}
test clay-0010 {Whole dicts are merged}  {
  dict get $foo option format
} {default ascii}

###
# Tests for the httpd module
###
test clay-0010 {Test that leaves are merged properly}
set bar {}
::clay::tree::dictmerge bar {
   proxy/ {port 10101 host myhost.localhost}
}
::clay::tree::dictmerge bar {
   mimetxt {Host: localhost
Content_Type: text/plain
Content-Length: 15
}
   http {HTTP_HOST {} CONTENT_LENGTH 15 HOST localhost CONTENT_TYPE text/plain UUID 3a7b4cdc-28d7-49b7-b18d-9d7d18382b9e REMOTE_ADDR 127.0.0.1 REMOTE_HOST 127.0.0.1 REQUEST_METHOD POST REQUEST_URI /echo REQUEST_PATH echo REQUEST_VERSION 1.0 DOCUMENT_ROOT {} QUERY_STRING {} REQUEST_RAW {POST /echo HTTP/1.0} SERVER_PORT 10001 SERVER_NAME 127.0.0.1 SERVER_PROTOCOL HTTP/1.1 SERVER_SOFTWARE {TclHttpd 4.2.0} LOCALHOST 0} UUID 3a7b4cdc-28d7-49b7-b18d-9d7d18382b9e uriinfo {fragment {} port {} path echo scheme http host {} query {} pbare 0 pwd {} user {}}
   mixin {reply ::test::content.echo}
   prefix /echo
   proxy_port 10010
   proxy/ {host localhost}
}

test clay-0011 {Whole dicts are merged}  {
  dict get $bar proxy_port
} {10010}

test clay-0012 {Whole dicts are merged}  {
  dict get $bar http CONTENT_LENGTH
} 15
test clay-0013 {Whole dicts are merged}  {
  dict get $bar proxy host
} localhost
test clay-0014 {Whole dicts are merged}  {
  dict get $bar proxy port
} 10101


###
# Dialect Testing
###
::clay::dialect::create ::alpha

proc ::alpha::define::is_alpha {} {
  dict set ::testinfo([current_class]) is_alpha 1
}

::alpha::define ::alpha::object {
  is_alpha
}

::clay::dialect::create ::bravo ::alpha

proc ::bravo::define::is_bravo {} {
  dict set ::testinfo([current_class]) is_bravo 1
}

::bravo::define ::bravo::object {
  is_bravo
}

::clay::dialect::create ::charlie ::bravo

proc ::charlie::define::is_charlie {} {
  dict set ::testinfo([current_class]) is_charlie 1
}

::charlie::define ::charlie::object {
  is_charlie
}

::clay::dialect::create ::delta ::charlie

proc ::delta::define::is_delta {} {
  dict set ::testinfo([current_class]) is_delta 1
}

::delta::define ::delta::object {
  is_delta
}

::delta::class create adam {
  is_alpha
  is_bravo
  is_charlie
  is_delta
}

test oodialect-keyword-001 {Testing keyword application} {
  set ::testinfo(::adam)
} {is_alpha 1 is_bravo 1 is_charlie 1 is_delta 1}

test oodialect-keyword-002 {Testing keyword application} {
  set ::testinfo(::alpha::object)
} {is_alpha 1}

test oodialect-keyword-003 {Testing keyword application} {
  set ::testinfo(::bravo::object)
} {is_bravo 1}

test oodialect-keyword-004 {Testing keyword application} {
  set ::testinfo(::charlie::object)
} {is_charlie 1}

test oodialect-keyword-005 {Testing keyword application} {
  set ::testinfo(::delta::object)
} {is_delta 1}

###
# Declare an object from a namespace
###
namespace eval ::test1 {
  ::alpha::class create a {
    aliases A
    is_alpha
  }
  ::alpha::define b {
    aliases B BEE
    is_alpha
  }
  ::alpha::class create ::c {
    aliases C
    is_alpha
  }
  ::alpha::define ::d {
    aliases D
    is_alpha
  }
}

test oodialect-naming-001 {Testing keyword application} {
  set ::testinfo(::test1::a)
} {is_alpha 1}

test oodialect-naming-002 {Testing keyword application} {
  set ::testinfo(::test1::b)
} {is_alpha 1}

test oodialect-naming-003 {Testing keyword application} {
  set ::testinfo(::c)
} {is_alpha 1}

test oodialect-naming-004 {Testing keyword application} {
  set ::testinfo(::d)
} {is_alpha 1}

test oodialect-aliasing-001 {Testing keyword application} {
namespace eval ::test1 {
    ::alpha::define e {
       superclass A
    }
}
} ::test1::e

test oodialect-aliasing-002 {Testing keyword application} {
namespace eval ::test1 {
    ::bravo::define f {
       superclass A
    }
}
} ::test1::f


test oodialect-aliasing-003 {Testing aliase method on class} {
  ::test1::a aliases
} {::test1::A}

###
# Test modified 2018-10-21
###
test oodialect-ancestry-003 {Testing heritage} {
  ::clay::ancestors ::test1::f
} {}

###
# Test modified 2018-10-21
###
test oodialect-ancestry-004 {Testing heritage} {
  ::clay::ancestors ::alpha::object
} {}

###
# Test modified 2018-10-21
###
test oodialect-ancestry-005 {Testing heritage} {
  ::clay::ancestors ::delta::object
} {}



# -------------------------------------------------------------------------
# clay submodule testing
# -------------------------------------------------------------------------



# Test canonical path building
set path {const/ foo/ bar/ baz/}


test oo-clay-path-0001 "Test path: const foo bar baz" {
  ::clay::path const foo bar baz
} $path


test oo-clay-path-0002 "Test path: const/ foo/ bar/ baz" {
  ::clay::path const/ foo/ bar/ baz
} $path


test oo-clay-path-0003 "Test path: const/foo/bar/baz" {
  ::clay::path const/foo/bar/baz
} $path


test oo-clay-path-0004 "Test path: const/foo bar/baz" {
  ::clay::path const/foo bar/baz
} $path


test oo-clay-path-0005 "Test path: const/foo/bar baz" {
  ::clay::path const/foo/bar baz
} $path


test oo-clay-path-0006 "Test path: const foo/bar/baz" {
  ::clay::path const foo/bar/baz
} $path


test oo-clay-path-0007 "Test path: const foo bar/baz" {
  ::clay::path const foo bar/baz
} $path


test oo-clay-path-0008 "Test path: const/foo bar baz" {
  ::clay::path const/foo bar baz
} $path

set path {const/ foo/ bar/ baz/ bing}

test oo-clay-leaf-0001 "Test leaf: const foo bar baz bing" {
  ::clay::leaf const foo bar baz bing
} $path


test oo-clay-leaf-0002 "Test leaf: const/ foo/ bar/ baz/ bing" {
  ::clay::leaf const/ foo/ bar/ baz/ bing
} $path


test oo-clay-leaf-0003 "Test leaf: const/foo/bar/baz/bing" {
  ::clay::leaf const/foo/bar/baz/bing
} $path


test oo-clay-leaf-0004 "Test leaf: const/foo bar/baz/bing:" {
  ::clay::leaf const/foo bar/baz/bing:
} $path


test oo-clay-leaf-0005 "Test leaf: const/foo/bar baz bing" {
  ::clay::leaf const/foo/bar baz bing
} $path


test oo-clay-leaf-0006 "Test leaf: const/foo/bar baz bing:" {
  ::clay::leaf const/foo/bar baz bing:
} $path


test oo-clay-leaf-0007 "Test leaf: const foo/bar/baz/bing" {
  ::clay::leaf const foo/bar/baz/bing
} $path


test oo-clay-leaf-0008 "Test leaf: const foo bar/baz/bing" {
  ::clay::leaf const foo bar/baz/bing
} $path


test oo-clay-leaf-0009 "Test leaf: const/foo bar baz bing" {
  ::clay::leaf const/foo bar baz bing
} $path

namespace eval ::foo {}

clay::define ::foo::classa {

  clay set const color  blue
  clay set const/flavor strawberry
  clay set {const/ sound} zoink
  clay set info/ {
    animal no
    building no
    subelement {pedantic yes}
  }

  # Provide a method that returns a constant so we can compare clay's inheritance to
  # TclOO
  method color {} {
    return blue
  }
  method flavor {} {
    return strawberry
  }
  method sound {} {
    return zoink
  }

}


test oo-class-clay-method-0001 "Test ::foo::classa const/ color exists" {
  ::foo::classa clay exists const/ color
} 1


test oo-class-clay-method-0001 "Test ::foo::classa const/ color value" {
  ::foo::classa clay get const/ color
} {blue}


test oo-class-clay-method-0003 "Test ::foo::classa const/ flavor exists" {
  ::foo::classa clay exists const/ flavor
} 1


test oo-class-clay-method-0003 "Test ::foo::classa const/ flavor value" {
  ::foo::classa clay get const/ flavor
} {strawberry}


test oo-class-clay-method-0005 "Test ::foo::classa const/ sound exists" {
  ::foo::classa clay exists const/ sound
} 1


test oo-class-clay-method-0005 "Test ::foo::classa const/ sound value" {
  ::foo::classa clay get const/ sound
} {zoink}


test oo-class-clay-method-0007 "Test ::foo::classa info/ animal exists" {
  ::foo::classa clay exists info/ animal
} 1


test oo-class-clay-method-0007 "Test ::foo::classa info/ animal value" {
  ::foo::classa clay get info/ animal
} {no}


test oo-class-clay-method-0009 "Test ::foo::classa info/ building exists" {
  ::foo::classa clay exists info/ building
} 1


test oo-class-clay-method-0009 "Test ::foo::classa info/ building value" {
  ::foo::classa clay get info/ building
} {no}


test oo-class-clay-method-0011 "Test ::foo::classa info/ subelement exists" {
  ::foo::classa clay exists info/ subelement
} 1


test oo-class-clay-method-0011 "Test ::foo::classa info/ subelement value" {
  ::foo::classa clay get info/ subelement
} {pedantic yes}


clay::define ::foo::classb {
  clay set const/ color black
  method color {} {return black}
  clay set const/ flavor vanilla
  method flavor {} {return vanilla}
  clay set const/ feeling dread
  method feeling {} {return dread}
  clay set info/ subelement {spoon yes}
  method subelement {} {return {spoon yes}}

}


test oo-class-clay-method-0013 "Test ::foo::classb const/ color exists" {
  ::foo::classb clay exists const/ color
} 1


test oo-class-clay-method-0013 "Test ::foo::classb const/ color value" {
  ::foo::classb clay get const/ color
} {black}


test oo-class-clay-method-0015 "Test ::foo::classb const/ flavor exists" {
  ::foo::classb clay exists const/ flavor
} 1


test oo-class-clay-method-0015 "Test ::foo::classb const/ flavor value" {
  ::foo::classb clay get const/ flavor
} {vanilla}


test oo-class-clay-method-0017 "Test ::foo::classb const/ feeling exists" {
  ::foo::classb clay exists const/ feeling
} 1


test oo-class-clay-method-0017 "Test ::foo::classb const/ feeling value" {
  ::foo::classb clay get const/ feeling
} {dread}


test oo-class-clay-method-0019 "Test ::foo::classb info/ subelement exists" {
  ::foo::classb clay exists info/ subelement
} 1


test oo-class-clay-method-0019 "Test ::foo::classb info/ subelement value" {
  ::foo::classb clay get info/ subelement
} {spoon yes}


clay::define ::foo::class.ab {
superclass ::foo::classb ::foo::classa
}


clay::define ::foo::class.ba {
superclass ::foo::classa ::foo::classb
}

# -------------------------------------------------------------------------
# Singleton
::clay::define ::test::singletonbehavior {
  method bar {} {
    return CLASS
  }
  method booze {} {
    return CLASS
  }
  Ensemble foo::bang {} {
    return CLASS
  }
  Ensemble foo::both {} {
    return CLASS
  }
  Ensemble foo::mixin {} {
    return CLASS
  }
  Ensemble foo::sloppy {} {
    return CLASS
  }
}
::clay::define ::test::flavor.strawberry {
  clay define property flavor strawbery
  method bar {} {
    return STRAWBERRY
  }
  Ensemble foo::bing {} {
    return STRAWBERRY
  }
  Ensemble foo::both {} {
    return STRAWBERRY
  }
  Ensemble foo::mixin {} {
    return STRAWBERRY
  }
  Ensemble foo::sloppy {} {
    return STRAWBERRY
  }
}
::clay::singleton ::TEST {
  class ::test::singletonbehavior
  clay mixinmap flavor ::test::flavor.strawberry
  clay set property color green
  method bar {} {
    return OBJECT
  }
  method booze {} {
    return OBJECT
  }
  method baz {} {
    return OBJECT
  }
  Ensemble foo::bar {} {
    return OBJECT
  }
  Ensemble foo::both {} {
    return OBJECT
  }
}

test oo-object-singleton-001 {Test singleton superclass keyword} {
  ::TEST clay delegate class
} {::test::singletonbehavior}

test oo-object-singleton-002 {Test singleton ensemble 1} {
  ::TEST foo <list>
} {bang bar bing both mixin sloppy}

test oo-object-singleton-003 {Test singleton ensemble from script} {
  ::TEST foo bar
} {OBJECT}
test oo-object-singleton-004 {Test singleton ensemble from mixin} {
  ::TEST foo bing
} {STRAWBERRY}
test oo-object-singleton-005 {Test singleton ensemble from class} {
  ::TEST foo bang
} {CLASS}
# Test note: the behavior from TclOO is unexpected
# Intuitively, a local method should override a mixin
# but this is not the case
test oo-object-singleton-006 {Test singleton ensemble from conflict, should resolve to object} {
  ::TEST foo both
} {STRAWBERRY}
test oo-object-singleton-007 {Test singleton ensemble from conflict, should resolve to mixin} {
  ::TEST foo sloppy
} {STRAWBERRY}
###
# Test note:
# This should work but does not
###
#test oo-object-singleton-009 {Test property from mixin/class} {
#  ::TEST clay get property flavor
#} {strawberry}
test oo-object-singleton-008 {Test property from script} {
  ::TEST clay get property color
} {green}


# Test note: the behavior from TclOO is unexpected
# Intuitively, a local method should override a mixin
# but this is not the case
test oo-object-singleton-010 {Test method declared in script} {
  ::TEST bar
} {STRAWBERRY}

test oo-object-singleton-011 {Test method declared in script} {
  ::TEST booze
} {OBJECT}
TEST destroy

# OBJECT of ::foo::classa
set OBJECTA [::foo::classa new]

###
# Test object degation
###
proc ::foo::fakeobject {a b} {
  return [expr {$a + $b}]
}

::clay::object create TEST
TEST clay delegate funct ::foo::fakeobject
test oo-object-delegate-001 {Test object delegation} {
  ::TEST clay delegate
} {<class> ::clay::object <funct> ::foo::fakeobject}

test oo-object-delegate-002 {Test object delegation} {
  ::TEST clay delegate funct
} {::foo::fakeobject}

test oo-object-delegate-002a {Test object delegation} {
  ::TEST clay delegate <funct>
} {::foo::fakeobject}

test oo-object-delegate-003 {Test object delegation} {
  ::TEST <funct> 1 1
} {2}
test oo-object-delegate-004 {Test object delegation} {
  ::TEST <funct> 10 -7
} {3}

# Replace the function out from under
proc ::foo::fakeobject {a b} {
  return [expr {$a * $b}]
}
test oo-object-delegate-005 {Test object delegation} {
  ::TEST <funct> 10 -7
} {-70}

# Object with ::foo::classa mixed in
set MIXINA  [::oo::object new]
oo::objdefine $MIXINA mixin ::foo::classa


test oo-object-clay-method-native-0001 {Test native object gets the property const//color} {
  $OBJECTA clay get const/ color
} {blue}
test oo-object-clay-method-mixin-0001 {Test mixin object gets the property const//color} {
  $MIXINA clay get const/ color
} {blue}


test oo-object-clay-method-native-methodcheck-0001 {Test that const//color would mimic method interheritance for a native class} {
  $OBJECTA color
} {blue}
test oo-object-clay-method-mixin-0001 {Test that const//color would mimic method interheritance for a mixed in class} {
  $MIXINA color
} {blue}
    

test oo-object-clay-method-native-0002 {Test native object gets the property const//flavor} {
  $OBJECTA clay get const/ flavor
} {strawberry}
test oo-object-clay-method-mixin-0002 {Test mixin object gets the property const//flavor} {
  $MIXINA clay get const/ flavor
} {strawberry}


test oo-object-clay-method-native-methodcheck-0002 {Test that const//flavor would mimic method interheritance for a native class} {
  $OBJECTA flavor
} {strawberry}
test oo-object-clay-method-mixin-0002 {Test that const//flavor would mimic method interheritance for a mixed in class} {
  $MIXINA flavor
} {strawberry}
    

test oo-object-clay-method-native-0003 {Test native object gets the property const//sound} {
  $OBJECTA clay get const/ sound
} {zoink}
test oo-object-clay-method-mixin-0003 {Test mixin object gets the property const//sound} {
  $MIXINA clay get const/ sound
} {zoink}


test oo-object-clay-method-native-methodcheck-0003 {Test that const//sound would mimic method interheritance for a native class} {
  $OBJECTA sound
} {zoink}
test oo-object-clay-method-mixin-0003 {Test that const//sound would mimic method interheritance for a mixed in class} {
  $MIXINA sound
} {zoink}
    

test oo-object-clay-method-native-0004 {Test native object gets the property info//animal} {
  $OBJECTA clay get info/ animal
} {no}
test oo-object-clay-method-mixin-0004 {Test mixin object gets the property info//animal} {
  $MIXINA clay get info/ animal
} {no}


test oo-object-clay-method-native-0005 {Test native object gets the property info//building} {
  $OBJECTA clay get info/ building
} {no}
test oo-object-clay-method-mixin-0005 {Test mixin object gets the property info//building} {
  $MIXINA clay get info/ building
} {no}


test oo-object-clay-method-native-0006 {Test native object gets the property info//subelement} {
  $OBJECTA clay get info/ subelement
} {pedantic yes}
test oo-object-clay-method-mixin-0006 {Test mixin object gets the property info//subelement} {
  $MIXINA clay get info/ subelement
} {pedantic yes}

# -------------------------------------------------------------------------
# OBJECT of ::foo::classb
set OBJECTB [::foo::classb new]
# Object with ::foo::classb mixed in
set MIXINB  [::oo::object new]
oo::objdefine $MIXINB mixin ::foo::classb


test oo-object-clay-method-native-0007 {Test native object gets the property const//color} {
  $OBJECTB clay get const/ color
} {black}
test oo-object-clay-method-mixin-0007 {Test mixin object gets the property const//color} {
  $MIXINB clay get const/ color
} {black}


test oo-object-clay-method-native-methodcheck-0007 {Test that const//color would mimic method interheritance for a native class} {
  $OBJECTB color
} {black}
test oo-object-clay-method-mixin-0007 {Test that const//color would mimic method interheritance for a mixed in class} {
  $MIXINB color
} {black}
    

test oo-object-clay-method-native-0008 {Test native object gets the property const//flavor} {
  $OBJECTB clay get const/ flavor
} {vanilla}
test oo-object-clay-method-mixin-0008 {Test mixin object gets the property const//flavor} {
  $MIXINB clay get const/ flavor
} {vanilla}


test oo-object-clay-method-native-methodcheck-0008 {Test that const//flavor would mimic method interheritance for a native class} {
  $OBJECTB flavor
} {vanilla}
test oo-object-clay-method-mixin-0008 {Test that const//flavor would mimic method interheritance for a mixed in class} {
  $MIXINB flavor
} {vanilla}
    

test oo-object-clay-method-native-0009 {Test native object gets the property const//feeling} {
  $OBJECTB clay get const/ feeling
} {dread}
test oo-object-clay-method-mixin-0009 {Test mixin object gets the property const//feeling} {
  $MIXINB clay get const/ feeling
} {dread}


test oo-object-clay-method-native-methodcheck-0009 {Test that const//feeling would mimic method interheritance for a native class} {
  $OBJECTB feeling
} {dread}
test oo-object-clay-method-mixin-0009 {Test that const//feeling would mimic method interheritance for a mixed in class} {
  $MIXINB feeling
} {dread}
    

test oo-object-clay-method-native-0010 {Test native object gets the property info//subelement} {
  $OBJECTB clay get info/ subelement
} {spoon yes}
test oo-object-clay-method-mixin-0010 {Test mixin object gets the property info//subelement} {
  $MIXINB clay get info/ subelement
} {spoon yes}

# -------------------------------------------------------------------------
# OBJECT descended from ::foo::classa ::foo::classb
set OBJECTAB [::foo::class.ab new]
# Object where classes were mixed in ::foo::classa ::foo::classb
set MIXINAB  [::oo::object new]
# Test modified 2018-10-30, mixin order was wrong before
oo::objdefine $MIXINAB mixin ::foo::classb ::foo::classa


test oo-object-clay-method-native-0011 {Test native object gets the property const//color} {
  $OBJECTAB clay get const/ color
} {black}
test oo-object-clay-method-mixin-0011 {Test mixin object gets the property const//color} {
  $MIXINAB clay get const/ color
} {black}


test oo-object-clay-method-native-methodcheck-0011 {Test that const//color would mimic method interheritance for a native class} {
  $OBJECTAB color
} {black}
test oo-object-clay-method-mixin-0011 {Test that const//color would mimic method interheritance for a mixed in class} {
  $MIXINAB color
} {black}
    

test oo-object-clay-method-native-0012 {Test native object gets the property const//flavor} {
  $OBJECTAB clay get const/ flavor
} {vanilla}
test oo-object-clay-method-mixin-0012 {Test mixin object gets the property const//flavor} {
  $MIXINAB clay get const/ flavor
} {vanilla}


test oo-object-clay-method-native-methodcheck-0012 {Test that const//flavor would mimic method interheritance for a native class} {
  $OBJECTAB flavor
} {vanilla}
test oo-object-clay-method-mixin-0012 {Test that const//flavor would mimic method interheritance for a mixed in class} {
  $MIXINAB flavor
} {vanilla}
    

test oo-object-clay-method-native-0013 {Test native object gets the property const//feeling} {
  $OBJECTAB clay get const/ feeling
} {dread}
test oo-object-clay-method-mixin-0013 {Test mixin object gets the property const//feeling} {
  $MIXINAB clay get const/ feeling
} {dread}


test oo-object-clay-method-native-methodcheck-0013 {Test that const//feeling would mimic method interheritance for a native class} {
  $OBJECTAB feeling
} {dread}
test oo-object-clay-method-mixin-0013 {Test that const//feeling would mimic method interheritance for a mixed in class} {
  $MIXINAB feeling
} {dread}
    

test oo-object-clay-method-native-0014 {Test native object gets the property const//sound} {
  $OBJECTAB clay get const/ sound
} {zoink}
test oo-object-clay-method-mixin-0014 {Test mixin object gets the property const//sound} {
  $MIXINAB clay get const/ sound
} {zoink}


test oo-object-clay-method-native-methodcheck-0014 {Test that const//sound would mimic method interheritance for a native class} {
  $OBJECTAB sound
} {zoink}
test oo-object-clay-method-mixin-0014 {Test that const//sound would mimic method interheritance for a mixed in class} {
  $MIXINAB sound
} {zoink}
    

test oo-object-clay-method-native-0015 {Test native object gets the property info//subelement} {
  $OBJECTAB clay get info/ subelement
} {spoon yes}
test oo-object-clay-method-mixin-0015 {Test mixin object gets the property info//subelement} {
  $MIXINAB clay get info/ subelement
} {spoon yes}


test oo-object-clay-method-native-0016 {Test native object gets the property info//animal} {
  $OBJECTAB clay get info/ animal
} {no}
test oo-object-clay-method-mixin-0016 {Test mixin object gets the property info//animal} {
  $MIXINAB clay get info/ animal
} {no}


test oo-object-clay-method-native-0017 {Test native object gets the property info//building} {
  $OBJECTAB clay get info/ building
} {no}
test oo-object-clay-method-mixin-0017 {Test mixin object gets the property info//building} {
  $MIXINAB clay get info/ building
} {no}

# -------------------------------------------------------------------------
# OBJECT descended from ::foo::classb ::foo::classa
set OBJECTBA [::foo::class.ba new]
# Object where classes were mixed in ::foo::classb ::foo::classa
set MIXINBA  [::oo::object new]
# Test modified 2018-10-30, mixin order was wrong before
oo::objdefine $MIXINBA mixin ::foo::classa ::foo::classb


test oo-object-clay-method-native-0018 {Test native object gets the property} {
  $OBJECTBA clay get const/ color
} {blue}
test oo-object-clay-method-mixin-0018 {Test mixin object gets the property} {
  $MIXINBA clay get const/ color
} {blue}


test oo-object-clay-method-native-methodcheck-0018 {Test that const//color would mimic method interheritance for a native class} {
  $OBJECTBA color
} {blue}
test oo-object-clay-method-mixin-0018 {Test that const//color would mimic method interheritance for a mixed in class} {
  $MIXINBA color
} {blue}
    

test oo-object-clay-method-native-0019 {Test native object gets the property} {
  $OBJECTBA clay get const/ flavor
} {strawberry}
test oo-object-clay-method-mixin-0019 {Test mixin object gets the property} {
  $MIXINBA clay get const/ flavor
} {strawberry}


test oo-object-clay-method-native-methodcheck-0019 {Test that const//flavor would mimic method interheritance for a native class} {
  $OBJECTBA flavor
} {strawberry}
test oo-object-clay-method-mixin-0019 {Test that const//flavor would mimic method interheritance for a mixed in class} {
  $MIXINBA flavor
} {strawberry}
    

test oo-object-clay-method-native-0020 {Test native object gets the property} {
  $OBJECTBA clay get const/ sound
} {zoink}
test oo-object-clay-method-mixin-0020 {Test mixin object gets the property} {
  $MIXINBA clay get const/ sound
} {zoink}


test oo-object-clay-method-native-methodcheck-0020 {Test that const//sound would mimic method interheritance for a native class} {
  $OBJECTBA sound
} {zoink}
test oo-object-clay-method-mixin-0020 {Test that const//sound would mimic method interheritance for a mixed in class} {
  $MIXINBA sound
} {zoink}
    

test oo-object-clay-method-native-0021 {Test native object gets the property} {
  $OBJECTBA clay get const/ feeling
} {dread}
test oo-object-clay-method-mixin-0021 {Test mixin object gets the property} {
  $MIXINBA clay get const/ feeling
} {dread}


test oo-object-clay-method-native-methodcheck-0021 {Test that const//feeling would mimic method interheritance for a native class} {
  $OBJECTBA feeling
} {dread}
test oo-object-clay-method-mixin-0021 {Test that const//feeling would mimic method interheritance for a mixed in class} {
  $MIXINBA feeling
} {dread}
    

test oo-object-clay-method-native-0022 {Test native object gets the property} {
  $OBJECTBA clay get info/ animal
} {no}
test oo-object-clay-method-mixin-0022 {Test mixin object gets the property} {
  $MIXINBA clay get info/ animal
} {no}


test oo-object-clay-method-native-0023 {Test native object gets the property} {
  $OBJECTBA clay get info/ building
} {no}
test oo-object-clay-method-mixin-0023 {Test mixin object gets the property} {
  $MIXINBA clay get info/ building
} {no}


test oo-object-clay-method-native-0024 {Test native object gets the property} {
  $OBJECTBA clay get info/ subelement
} {pedantic yes}
test oo-object-clay-method-mixin-0024 {Test mixin object gets the property} {
  $MIXINBA clay get info/ subelement
} {pedantic yes}


###
# put a do-nothing constructor on the books
###
::clay::define ::clay::object {
  constructor args {}
}

oo::objdefine ::clay::object method foo args { return bar }

test clay-core-method-0001 {Test that adding methods to the core ::clay::object class works} {
  ::clay::object foo
} {bar}

namespace eval ::TEST {}
::clay::define ::TEST::myclass {
  clay color red
  clay flavor strawberry

}

###
# Test adding a clay property
###
test clay-class-clay-0001 {Test that a clay statement is recorded in the object of the class} {
  ::TEST::myclass clay get color
} red
test clay-class-clay-0002 {Test that a clay statement is recorded in the object of the class} {
  ::TEST::myclass clay get flavor
} strawberry

###
# Test that objects of the class get the same properties
###
set OBJ [::clay::object new {}]
set OBJ2 [::TEST::myclass new {}]

test clay-object-clay-a-0001 {Test that objects not thee class do not get properties} {
  $OBJ clay get color
} {}
test clay-object-clay-a-0002 {Test that objects not thee class do not get properties} {
  $OBJ clay get flavor
} {}
test clay-object-clay-a-0003 {Test that objects of the class get properties} {
  $OBJ2 clay get color
} red
test clay-object-clay-a-0004 {Test that objects of the class get properties} {
  $OBJ2 clay get flavor
} strawberry

###
# Test modified 2018-10-21
###
test clay-object-clay-a-0005 {Test the clay ancestors function} {
  $OBJ clay ancestors
} {::clay::object}

###
# Test modified 2018-10-21
###
test clay-object-clay-a-0006 {Test the clay ancestors function} {
  $OBJ2 clay ancestors
} {::TEST::myclass ::clay::object}

test clay-object-clay-a-0007 {Test the clay provenance  function} {
  $OBJ2 clay provenance  flavor
} ::TEST::myclass

###
# Test that object local setting override the class
###
test clay-object-clay-a-0008 {Test that object local setting override the class} {
  $OBJ2 clay set color purple
  $OBJ2 clay get color
} purple
test clay-object-clay-a-0009 {Test that object local setting override the class} {
  $OBJ2 clay provenance  color
} self

::clay::define ::TEST::myclasse {
  superclass ::TEST::myclass

  clay color blue
  method do args {
    return "I did $args"
  }

  Ensemble which::color {} {
    return [my clay get color]
  }
  clay set method_ensemble which farbe: {tailcall my Which_color {*}$args}
}

###
# Test clay information is passed town to subclasses
###
test clay-class-clay-0003 {Test that a clay statement is recorded in the object of the class} {
  ::TEST::myclasse clay get color
} blue
test clay-class-clay-0004 {Test that clay statements from the ancestors of this class are not present (we handle them seperately in objects)} {
  ::TEST::myclasse clay get flavor
} {}
test clay-class-clay-0005 {Test that clay statements from the ancestors of this class are found with the FIND method} {
  ::TEST::myclasse clay find flavor
} {strawberry}

###
# Test that properties reach objects
###
set OBJ3 [::TEST::myclasse new {}]
test clay-object-clay-b-0001 {Test that objects of the class get properties} {
  $OBJ3 clay get color
} blue
test clay-object-clay-b-0002 {Test the clay provenance  function} {
  $OBJ3 clay provenance  color
} ::TEST::myclasse
test clay-object-clay-b-0003 {Test that objects of the class get properties} {
  $OBJ3 clay get flavor
} strawberry
test clay-object-clay-b-0004 {Test the clay provenance  function} {
  $OBJ3 clay provenance  flavor
} ::TEST::myclass

###
# Test modified 2018-10-21
###
test clay-object-clay-b-0005 {Test the clay provenance  function} {
  $OBJ3 clay ancestors
} {::TEST::myclasse ::TEST::myclass ::clay::object}

###
# Test defining a standard method
###
test clay-object-method-0001 {Test and standard method} {
  $OBJ3 do this really cool thing
} {I did this really cool thing}

test clay-object-method-0003 {Test an ensemble} {
  $OBJ3 which color
} blue
# Test setting properties
test clay-object-method-0004 {Test an ensemble} {
  $OBJ3 clay set color black
  $OBJ3 which color
} black

# Test setting properties
test clay-object-method-0004 {Test an ensemble alias} {
  $OBJ3 which farbe
} black


###
# Added 2019-06-24
# Test that grabbing a leaf does not pollute the cache
###
::clay::define ::TEST::class_with_deep_tree {
  clay set tree deep has depth 1
  clay set tree shallow has depth 0
}

$OBJ3 clay mixinmap deep ::TEST::class_with_deep_tree

test clay-deep-nested-0001 {Test that a leaf query does not pollute the cache} {
  $OBJ3 clay get tree shallow has depth
} 0
test clay-deep-nested-0001 {Test that a leaf query does not pollute the cache} {
  $OBJ3 clay get tree
} {deep {has {depth 1}} shallow {has {depth 0}}}



###
# Test that if you try to replace a global command you get an error
###
test clay-nspace-0001 {Test that if you try to replace a global command you get an error} -body {
::clay::define open {
  method bar {} { return foo }

}
}  -returnCodes {error} -result "::open does not refer to an object"

::clay::define fubar {
  method bar {} { return foo }
}
test clay-nspace-0002 {Test a non qualified class ends up in the current namespace} {
  info commands ::fubar
} {::fubar}

namespace eval ::cluster {
::clay::define fubar {
  method bar {} { return foo }
}

::clay::define ::clay::pot {
  method bar {} { return foo }
}

}
test clay-nspace-0003 {Test a non qualified class ends up in the current namespace} {
  info commands ::cluster::fubar
} {::cluster::fubar}
test clay-nspace-0003 {Test a fully qualified class ends up in the proper namespace} {
  info commands ::clay::pot
} {::clay::pot}

#set ::clay::trace 3

###
# New test - Added 2019-09-15
# Test that the "method" variable is exposed to a default method
###

::clay::define ::ensembleWithDefault {
  Ensemble foo::bar {} { return A }
  Ensemble foo::baz {} { return B }
  Ensemble foo::bang {} { return C }

  Ensemble foo::default {} { return $method }
}


set OBJ [::ensembleWithDefault new]
test clay-ensemble-default-0001 {Test a normal ensemble method} {
  $OBJ foo bar
} {A}
test clay-ensemble-default-0002 {Test a normal ensemble method} {
  $OBJ foo baz
} {B}
test clay-ensemble-default-0003 {Test a normal ensemble method} {
  $OBJ foo <list>
} [lsort -dictionary {bar baz bang}]

test clay-ensemble-default-0004 {Test a normal ensemble method} {
  $OBJ foo bing
} {bing}
test clay-ensemble-default-0005 {Test a normal ensemble method} {
  $OBJ foo bong
} {bong}
###
# Mixin tests
###

###
# Define a core class
###
::clay::define ::TEST::thing {

  method do args {
    return "I did $args"
  }
}


::clay::define ::TEST::vegetable {

  clay color unknown
  clay flavor unknown

  Ensemble which::flavor {} {
    return [my clay get flavor]
  }
  Ensemble which::color {} {
    return [my clay get color]
  }

}

::clay::define ::TEST::animal {

  clay color unknown
  clay sound unknown

  Ensemble which::sound {} {
    return [my clay get sound]
  }
  Ensemble which::color {} {
    return [my clay get color]
  }
  method sound {} {
    return unknown
  }
}

::clay::define ::TEST::species.cat {
  superclass ::TEST::animal
  clay sound meow
  method sound {} {
    return meow
  }
}

::clay::define ::TEST::coloring.calico {
  clay color calico

}

::clay::define ::TEST::condition.dark {
  Ensemble which::color {} {
    return grey
  }
}

::clay::define ::TEST::mood.happy {
  Ensemble which::sound {} {
    return purr
  }
  method sound {} {
    return purr
  }
}
test clay-object-0001 {Test than an object is created when clay::define is invoked} {
  info commands ::TEST::mood.happy
} ::TEST::mood.happy

set OBJ [::TEST::thing new]
test clay-mixin-a-0001 {Test that prior to a mixin an ensemble doesn't exist} -body {
  $OBJ which color
} -returnCodes error -result {unknown method "which": must be clay, destroy or do}

test clay-mixin-a-0002 {Test and standard method from an ancestor} {
  $OBJ do this really cool thing
} {I did this really cool thing}

$OBJ clay mixinmap species ::TEST::animal
test clay-mixin-b-0001 {Test that an ensemble is created during a mixin} {
  $OBJ which color
} {unknown}

test clay-mixin-b-0002 {Test that an ensemble is created during a mixin} {
  $OBJ which sound
} {unknown}

test clay-mixin-b-0003 {Test that an ensemble is created during a mixin}  -body {$OBJ which flavor} -returnCodes {error}  -result {unknown method which flavor. Valid: color sound}

###
# Test Modified: 2018-10-21
###
test clay-mixin-b-0004 {Test that mixins resolve in the correct order} {
  $OBJ clay ancestors
} {::TEST::animal ::TEST::thing ::clay::object}

###
# Replacing a mixin replaces the behaviors
###
$OBJ clay mixinmap species ::TEST::vegetable
test clay-mixin-c-0001 {Test that an ensemble is created during a mixin} {
  $OBJ which color
} {unknown}
test clay-mixin-c-0002 {Test that an ensemble is created during a mixin}  -body {$OBJ which sound}  -returnCodes {error}  -result {unknown method which sound. Valid: color flavor}
test clay-mixin-c-0003 {Test that an ensemble is created during a mixin} {
  $OBJ which flavor
} {unknown}
###
# Test Modified: 2018-10-21
###
test clay-mixin-c-0004 {Test that mixins resolve in the correct order} {
  $OBJ clay ancestors
} {::TEST::vegetable ::TEST::thing ::clay::object}

###
# Replacing a mixin
$OBJ clay mixinmap species ::TEST::species.cat
test clay-mixin-e-0001 {Test that an ensemble is created during a mixin} {
  $OBJ which color
} {unknown}
test clay-mixin-e-0002a {Test that an ensemble is created during a mixin} {
  $OBJ sound
} {meow}
test clay-mixin-e-0002b {Test that an ensemble is created during a mixin} {
  $OBJ clay get sound
} {meow}
test clay-mixin-e-0002 {Test that an ensemble is created during a mixin} {
  $OBJ which sound
} {meow}
test clay-mixin-e-0003 {Test that an ensemble is created during a mixin}  -body {$OBJ which flavor} -returnCodes {error}  -result {unknown method which flavor. Valid: color sound}
###
# Test Modified: 2018-10-30, 2018-10-21, 2018-10-10
###
test clay-mixin-e-0004 {Test that clay data follows the rules of inheritence and order of mixin} {
  $OBJ clay ancestors
} {::TEST::species.cat ::TEST::animal ::TEST::thing ::clay::object}

$OBJ clay mixinmap coloring ::TEST::coloring.calico
test clay-mixin-f-0001 {Test that an ensemble is created during a mixin} {
  $OBJ which color
} {calico}
test clay-mixin-f-0002 {Test that an ensemble is created during a mixin} {
  $OBJ which sound
} {meow}
test clay-mixin-f-0003 {Test that an ensemble is created during a mixin}  -body {$OBJ which flavor} -returnCodes {error}  -result {unknown method which flavor. Valid: color sound}

###
# Test modified 2018-10-30, 2018-10-21, 2018-10-10
###
test clay-mixin-f-0004 {Test that clay data follows the rules of inheritence and order of mixin} {
  $OBJ clay ancestors
} {::TEST::coloring.calico ::TEST::species.cat ::TEST::animal ::TEST::thing ::clay::object}

test clay-mixin-f-0005 {Test that clay data from a mixin works} {
  $OBJ clay provenance  color
} {::TEST::coloring.calico}

###
# Test variable initialization
###
::clay::define ::TEST::has_var {
  Variable my_variable 10

  method get_my_variable {} {
    my variable my_variable
    return $my_variable
  }
}

set OBJ [::TEST::has_var new]
test clay-class-variable-0001 {Test that the parser injected the right value in the right place for clay to catch it} {
  $OBJ clay get variable/ my_variable
} {10}

# Modified 2018-10-30 (order is different)
test clay-class-variable-0002 {Test that the parser injected the right value in the right place for clay to catch it} {
  $OBJ clay get variable
} {my_variable 10 DestroyEvent 0}

# Modified 2018-10-30 (order is different)
test clay-class-variable-0003 {Test that the parser injected the right value in the right place for clay to catch it} {
  $OBJ clay dget variable
} {. {} my_variable 10 DestroyEvent 0}

test clay-class-variable-0004 {Test that variables declared in the class definition are initialized} {
  $OBJ get_my_variable
} 10

###
# Test array initialization
###
::clay::define ::TEST::has_array {
  Array my_array {timeout 10}

  method get_my_array {field} {
    my variable my_array
    return $my_array($field)
  }
}

set OBJ [::TEST::has_array new]
test clay-class-array-0001 {Test that the parser injected the right value in the right place for clay to catch it} {
  $OBJ clay get array
} {my_array {timeout 10}}

test clay-class-array-0002 {Test that the parser injected the right value in the right place for clay to catch it} {
  $OBJ clay dget array
} {. {} my_array {. {} timeout 10}}

test clay-class-array-0003 {Test that variables declared in the class definition are initialized} {
  $OBJ get_my_array timeout
} 10

::clay::define ::TEST::has_more_array {
  superclass ::TEST::has_array
  Array my_array {color blue}
}
test clay-class-array-0008 {Test that the parser injected the right value in the right place for clay to catch it} {
  ::TEST::has_more_array clay get array
} {my_array {color blue}}

test clay-class-array-0009 {Test that the parser injected the right value in the right place for clay to catch it} {
  ::TEST::has_more_array clay find array
} {my_array {timeout 10 color blue}}

# Modified 2018-10-30 (order is different)
set BOBJ [::TEST::has_more_array new]
test clay-class-array-0004 {Test that the parser injected the right value in the right place for clay to catch it} {
  $BOBJ clay get array
} {my_array {color blue timeout 10}}

# Modified 2018-10-30 (order is different)
test clay-class-array-0005 {Test that the parser injected the right value in the right place for clay to catch it} {
  $BOBJ clay dget array
} {. {} my_array {. {} color blue timeout 10}}

test clay-class-arrau-0006 {Test that variables declared in the class definition are initialized} {
  $BOBJ get_my_array timeout
} 10
test clay-class-arrau-0007 {Test that variables declared in the class definition are initialized} {
  $BOBJ get_my_array color
} blue

::clay::define ::TEST::has_empty_array {
  Array my_array {}

  method my_array_exists {} {
    my variable my_array
    return [info exists my_array]
  }
  method get {field} {
    my variable my_array
    return $my_array($field)
  }
  method set {field value} {
    my variable my_array
    set my_array($field) $value
  }
}

test clay-class-array-0008 {Test that an declaration of an array with no values produces and empty array} {
  set COBJ [::TEST::has_empty_array new]
  $COBJ my_array_exists
} 1

test clay-class-array-0009 {Test that an declaration of an array with no values produces and empty array} {
  $COBJ set test "A random value"
  $COBJ get test
} {A random value}
###
# Test dict initialization
###
::clay::define ::TEST::has_dict {
  Dict my_dict {timeout 10}

  method get_my_dict {args} {
    my variable my_dict
    if {[llength $args]==0} {
      return $my_dict
    }
    return [dict get $my_dict {*}$args]
  }

}

set OBJ [::TEST::has_dict new]
test clay-class-dict-0001 {Test that the parser injected the right value in the right place for clay to catch it} {
  $OBJ clay get dict
} {my_dict {timeout 10}}

test clay-class-dict-0002 {Test that the parser injected the right value in the right place for clay to catch it} {
  $OBJ clay dget dict
} {. {} my_dict {. {} timeout 10}}

test clay-class-dict-0003 {Test that variables declared in the class definition are initialized} {
  $OBJ get_my_dict timeout
} 10

test clay-class-dict-0004 {Test that an empty dict is annotated} {
  $OBJ clay get dict
} {my_dict {timeout 10}}


::clay::define ::TEST::has_more_dict {
  superclass ::TEST::has_dict
  Dict my_dict {color blue}
}
set BOBJ [::TEST::has_more_dict new]

# Modified 2018-10-30
test clay-class-dict-0004 {Test that the parser injected the right value in the right place for clay to catch it} {
  $BOBJ clay get dict
} {my_dict {color blue timeout 10}}

# Modified 2018-10-30
test clay-class-dict-0005 {Test that the parser injected the right value in the right place for clay to catch it} {
  $BOBJ clay dget dict
} {. {} my_dict {. {} color blue timeout 10}}

test clay-class-dict-0006 {Test that variables declared in the class definition are initialized} {
  $BOBJ get_my_dict timeout
} 10

test clay-class-dict-0007 {Test that variables declared in the class definition are initialized} {
  $BOBJ get_my_dict color
} blue

::clay::define ::TEST::has_empty_dict {
  Dict my_empty_dict {}

  method get_my_empty_dict {args} {
    my variable my_empty_dict
    if {[llength $args]==0} {
      return $my_empty_dict
    }
    return [dict get $my_empty_dict {*}$args]
  }
}

set COBJ [::TEST::has_empty_dict new]

test clay-class-dict-0008 {Test that the parser injected the right value in the right place for clay to catch it} {
  $COBJ clay dget dict
} {my_empty_dict {. {}}}

test clay-class-dict-0009 {Test that an empty dict is initialized} {
  $COBJ get_my_empty_dict
} {}

###
# Test object delegation
###
::clay::define ::TEST::organelle {
  method add args {
    set total 0
    foreach item $args {
      set total [expr {$total+$item}]
    }
    return $total
  }
}
::clay::define ::TEST::master {
  constructor {} {
    set mysub [namespace current]::sub
    ::TEST::organelle create $mysub
    my clay delegate sub $mysub
  }
}

set OBJ [::TEST::master new]
###
# Test that delegation is working
###
test clay-delegation-0001 {Test an array driven ensemble} {
  $OBJ <sub> add 5 5
} 10


###
# Test the Ensemble keyword
###
::clay::define ::TEST::with_ensemble {

  Ensemble myensemble {pattern args} {
    set ensemble [self method]
    set emap [my clay ensemble_map $ensemble]
    set mlist [dict keys $emap [string tolower $pattern]]
    if {[llength $mlist] != 1} {
      error "Couldn't figure out what to do with $pattern"
    }
    set method [lindex $mlist 0]
    set argspec [dict get $emap $method argspec]
    set body    [dict get $emap $method body]
    if {$argspec ni {args {}}} {
      ::clay::dynamic_arguments $ensemble $method [list $argspec] {*}$args
    }
    eval $body
  }

  Ensemble myensemble::go args {
    return 1
  }
}

::clay::define ::TEST::with_ensemble.dance {
  Ensemble myensemble::dance args {
    return 1
  }
}
::clay::define ::TEST::with_ensemble.cannot_dance {
  Ensemble myensemble::dance args {
    return 0
  }
}

set OBJA [::clay::object new]
set OBJB [::clay::object new]

$OBJA clay mixinmap  core ::TEST::with_ensemble  friends ::TEST::with_ensemble.dance

$OBJB clay mixinmap  core ::TEST::with_ensemble  friends ::TEST::with_ensemble.cannot_dance

# Test go
test clay-dynamic-ensemble-0001 {Test ensemble with static method} {
  $OBJA myensemble go
} {1}
test clay-dynamic-ensemble-0002 {Test ensemble with static method} {
  $OBJB myensemble go
} {1}
# Test dance
test clay-dynamic-ensemble-0003 {Test ensemble with static method} {
  $OBJA myensemble dance
} {1}
test clay-dynamic-ensemble-0004 {Test ensemble with static method} {
  $OBJB myensemble dance
} {0}


###
# Class method testing
###

clay::class create WidgetClass {
  Class_Method working {} {
    return {Works}
  }

  Class_Method unknown args {
    set tkpath [lindex $args 0]
    if {[string index $tkpath 0] eq "."} {
      set obj [my new $tkpath {*}[lrange $args 1 end]]
      $obj tkalias $tkpath
      return $tkpath
    }
    next {*}$args
  }

  constructor {TkPath args} {
    my variable hull
    set hull $TkPath
    my clay delegate hull $TkPath
  }

  method tkalias tkname {
    set oldname $tkname
    my variable tkalias
    set tkalias $tkname
    set self [self]
    set hullwidget [::info object namespace $self]::tkwidget
    my clay delegate tkwidget $hullwidget
    #rename ::$tkalias $hullwidget
    my clay delegate hullwidget $hullwidget
    #::tool::object_rename [self] ::$tkalias
    rename [self] ::$tkalias
    #my Hull_Bind $tkname
    return $hullwidget
  }
}

test tool-class-method-000 {Test that class methods actually work...} {
  WidgetClass working
} {Works}

test tool-class-method-001 {Test Tk style creator} {
  WidgetClass .foo
  .foo clay delegate hull
} {.foo}

::clay::define WidgetNewClass {
  superclass WidgetClass
}

test tool-class-method-002 {Test Tk style creator inherited by morph} {
  WidgetNewClass .bar
  .bar clay delegate hull
} {.bar}



###
# Test ensemble inheritence
###
clay::define NestedClassA {
  Ensemble do::family {} {
    return NestedClassA
  }
  Ensemble do::something {} {
    return A
  }
  Ensemble do::whop {} {
    return A
  }
}
clay::define NestedClassB {
  superclass NestedClassA
  Ensemble do::family {} {
    set r [next family]
    lappend r NestedClassB
    return $r
  }
  Ensemble do::whop {} {
    return B
  }
}
clay::define NestedClassC {
  superclass NestedClassB

  Ensemble do::somethingelse {} {
    return C
  }
}
clay::define NestedClassD {
  superclass NestedClassB

  Ensemble do::somethingelse {} {
    return D
  }
}

clay::define NestedClassE {
  superclass NestedClassD NestedClassC
}

clay::define NestedClassF {
  superclass NestedClassC NestedClassD
}

NestedClassC create NestedObjectC

###
# These tests no longer work because method ensembles are now dynamically
# generated by object, that are not attached to the class anymore
#
####
#test tool-ensemble-001 {Test that an ensemble can access [next] even if no object of the ancestor class have been instantiated} {
#  NestedObjectC do family
#} {::NestedClassA ::NestedClassB ::NestedClassC}

test tool-ensemble-002 {Test that a later ensemble definition trumps a more primitive one} {
  NestedObjectC do whop
} {B}
test tool-ensemble-003 {Test that an ensemble definitions in an ancestor carry over} {
  NestedObjectC do something
} {A}

NestedClassE create NestedObjectE
NestedClassF create NestedObjectF


test tool-ensemble-004 {Test that ensembles follow the same rules for inheritance as methods} {
  NestedObjectE do somethingelse
} {D}

test tool-ensemble-005 {Test that ensembles follow the same rules for inheritance as methods} {
  NestedObjectF do somethingelse
} {C}

###
# Set of tests to exercise the mixinmap system
###
clay::define MixinMainClass {
  Variable mainvar unchanged

  Ensemble test::which {} {
    my variable mainvar
    return $mainvar
  }

  Ensemble test::main args {
    puts [list this is main $method $args]
  }

}

set mixoutscript {my test untool $class}
set mixinscript {my test tool $class}
clay::define MixinTool {
  Variable toolvar unchanged.mixin
  clay set mixin/ unmap-script $mixoutscript
  clay set mixin/ map-script $mixinscript
  clay set mixin/ name {Generic Tool}

  Ensemble test::untool class {
    my variable toolvar mainvar
    set mainvar {}
    set toolvar {}
  }

  Ensemble test::tool class {
    my variable toolvar mainvar
    set mainvar [$class clay get mixin name]
    set toolvar [$class clay get mixin name]
  }
}

clay::define MixinToolA {
  superclass MixinTool

  clay set mixin/ name {Tool A}
}

clay::define MixinToolB {
  superclass MixinTool

  clay set mixin/ name {Tool B}

  method test_newfunc {} {
    return "B"
  }
}

test tool-mixinspec-001 {Test application of mixin specs} {
  MixinTool clay get mixin map-script
} $mixinscript

test tool-mixinspec-002 {Test application of mixin specs} {
  MixinToolA clay get mixin map-script
} {}

test tool-mixinspec-003 {Test application of mixin specs} {
  MixinToolA clay find mixin map-script
} $mixinscript

test tool-mixinspec-004 {Test application of mixin specs} {
  MixinToolB clay find mixin map-script
} $mixinscript


MixinMainClass create mixintest

test tool-mixinmap-001 {Test object prior to mixins} {
  mixintest test which
} {unchanged}

mixintest clay mixinmap tool MixinToolA
test tool-mixinmap-002 {Test mixin map script ran} {
  mixintest test which
} {Tool A}

mixintest clay mixinmap tool MixinToolB

test tool-mixinmap-003 {Test mixin map script ran} {
  mixintest test which
} {Tool B}

test tool-mixinmap-003 {Test mixin map script ran} {
  mixintest test_newfunc
} {B}

mixintest clay mixinmap tool {}
test tool-mixinmap-004 {Test object prior to mixins} {
  mixintest test which
} {}



clay::define ::clay::object {
  method path {} {
    return [self class]
  }
}


clay::define ::MixinRoot {
  clay set opts core   root
  clay set opts option unset
  clay set opts color  unset

  Ensemble info::root {} {
    return MixinRoot
  }
  Ensemble info::shade {} {
    return avacodo
  }
  Ensemble info::default {} {
    return Undefined
  }

  method did {} {
    return MixinRoot
  }

  method path {} {
    return [list [self class] {*}[next]]
  }
}

clay::define ::MixinOption1 {
  clay set opts option option1

  Ensemble info::option {} {
    return MixinOption1
  }
  Ensemble info::other {} {
    return MixinOption1
  }

  method did {} {
    return MixinOption1
  }

  method path {} {
    return [list [self class] {*}[next]]
  }
}

clay::define ::MixinOption2 {
  superclass ::MixinOption1

  clay set opts option option2

  Ensemble info::option {} {
    return MixinOption2
  }

  method did {} {
    return MixinOption2
  }

  method path {} {
    return [list [self class] {*}[next]]
  }
}


clay::define ::MixinColor1 {
  clay set opts color blue

  Ensemble info::color {} {
    return MixinColor1
  }
  Ensemble info::shade {} {
    return blue
  }

  method did {} {
    return MixinColor1
  }

  method path {} {
    return [list [self class] {*}[next]]
  }
}

clay::define ::MixinColor2 {
  clay set opts color green

  Ensemble info::color {} {
    return MixinColor2
  }
  Ensemble info::shade {} {
    return green
  }

  method did {} {
    return MixinColor2
  }

  method path {} {
    return [list [self class] {*}[next]]
  }
}

set obj [clay::object new]

$obj clay mixinmap root ::MixinRoot


test tool-prototype-0001-0001 {Mixin core} {
  $obj info root
} {MixinRoot}


test tool-prototype-0001-0002 {Mixin core} {
  $obj info option
} {Undefined}


test tool-prototype-0001-0003 {Mixin core} {
  $obj info color
} {Undefined}


test tool-prototype-0001-0004 {Mixin core} {
  $obj info other
} {Undefined}


test tool-prototype-0001-0005 {Mixin core} {
  $obj info shade
} {avacodo}


test tool-prototype-0001-0006 {Mixin core} {
  $obj did
} {MixinRoot}


test tool-prototype-0001-0007 {Mixin core} {
  $obj path
} {::MixinRoot ::clay::object}


test tool-prototype-0001-0008 {Mixin core} {
  $obj clay get opts
} {core root option unset color unset}


test tool-prototype-0001-0009 {Mixin core} {
  $obj clay get opts core
} {root}


test tool-prototype-0001-0010 {Mixin core} {
  $obj clay get opts option
} {unset}


test tool-prototype-0001-0011 {Mixin core} {
  $obj clay get opts color
} {unset}


test tool-prototype-0001-0012 {Mixin core} {
  $obj clay ancestors
} {::MixinRoot ::clay::object}

$obj clay mixinmap option ::MixinOption1

test tool-prototype-0002-0001 {Mixin option1} {
  $obj info root
} {MixinRoot}


test tool-prototype-0002-0002 {Mixin option1} {
  $obj info option
} {MixinOption1}


test tool-prototype-0002-0003 {Mixin option1} {
  $obj info color
} {Undefined}


test tool-prototype-0002-0004 {Mixin option1} {
  $obj info other
} {MixinOption1}


test tool-prototype-0002-0005 {Mixin option1} {
  $obj info shade
} {avacodo}


test tool-prototype-0002-0006 {Mixin option1} {
  $obj did
} {MixinOption1}


test tool-prototype-0002-0007 {Mixin option1} {
  $obj path
} {::MixinOption1 ::MixinRoot ::clay::object}


test tool-prototype-0002-0008 {Mixin option1} {
  $obj clay get opts
} {option option1 core root color unset}


test tool-prototype-0002-0009 {Mixin option1} {
  $obj clay get opts core
} {root}


test tool-prototype-0002-0010 {Mixin option1} {
  $obj clay get opts option
} {option1}


test tool-prototype-0002-0011 {Mixin option1} {
  $obj clay get opts color
} {unset}


test tool-prototype-0002-0012 {Mixin option1} {
  $obj clay ancestors
} {::MixinOption1 ::MixinRoot ::clay::object}


set obj2 [clay::object new]
$obj2 clay mixinmap root ::MixinRoot option ::MixinOption1

$obj clay mixinmap option ::MixinOption1

test tool-prototype-0003-0001 {Mixin option1 - clean object} {
  $obj2 info root
} {MixinRoot}


test tool-prototype-0003-0002 {Mixin option1 - clean object} {
  $obj2 info option
} {MixinOption1}


test tool-prototype-0003-0003 {Mixin option1 - clean object} {
  $obj2 info color
} {Undefined}


test tool-prototype-0003-0004 {Mixin option1 - clean object} {
  $obj2 info other
} {MixinOption1}


test tool-prototype-0003-0005 {Mixin option1 - clean object} {
  $obj2 info shade
} {avacodo}


test tool-prototype-0003-0006 {Mixin option1 - clean object} {
  $obj2 did
} {MixinOption1}


test tool-prototype-0003-0007 {Mixin option1 - clean object} {
  $obj2 path
} {::MixinOption1 ::MixinRoot ::clay::object}


test tool-prototype-0003-0008 {Mixin option1 - clean object} {
  $obj2 clay get opts
} {option option1 core root color unset}


test tool-prototype-0003-0009 {Mixin option1 - clean object} {
  $obj2 clay get opts core
} {root}


test tool-prototype-0003-0010 {Mixin option1 - clean object} {
  $obj2 clay get opts option
} {option1}


test tool-prototype-0003-0011 {Mixin option1 - clean object} {
  $obj2 clay get opts color
} {unset}


test tool-prototype-0003-0012 {Mixin option1 - clean object} {
  $obj2 clay ancestors
} {::MixinOption1 ::MixinRoot ::clay::object}

$obj clay mixinmap option ::MixinOption2

test tool-prototype-0004-0001 {Mixin option2} {
  $obj info root
} {MixinRoot}


test tool-prototype-0004-0002 {Mixin option2} {
  $obj info option
} {MixinOption2}


test tool-prototype-0004-0003 {Mixin option2} {
  $obj info color
} {Undefined}


test tool-prototype-0004-0004 {Mixin option2} {
  $obj info other
} {MixinOption1}


test tool-prototype-0004-0005 {Mixin option2} {
  $obj info shade
} {avacodo}


test tool-prototype-0004-0006 {Mixin option2} {
  $obj did
} {MixinOption2}


test tool-prototype-0004-0007 {Mixin option2} {
  $obj path
} {::MixinOption2 ::MixinOption1 ::MixinRoot ::clay::object}


test tool-prototype-0004-0008 {Mixin option2} {
  $obj clay get opts
} {option option2 core root color unset}


test tool-prototype-0004-0009 {Mixin option2} {
  $obj clay get opts core
} {root}


test tool-prototype-0004-0010 {Mixin option2} {
  $obj clay get opts option
} {option2}


test tool-prototype-0004-0011 {Mixin option2} {
  $obj clay get opts color
} {unset}


test tool-prototype-0004-0012 {Mixin option2} {
  $obj clay ancestors
} {::MixinOption2 ::MixinOption1 ::MixinRoot ::clay::object}

$obj clay mixinmap color MixinColor1

test tool-prototype-0005-0001 {Mixin color1} {
  $obj info root
} {MixinRoot}


test tool-prototype-0005-0002 {Mixin color1} {
  $obj info option
} {MixinOption2}


test tool-prototype-0005-0003 {Mixin color1} {
  $obj info color
} {MixinColor1}


test tool-prototype-0005-0004 {Mixin color1} {
  $obj info other
} {MixinOption1}


test tool-prototype-0005-0005 {Mixin color1} {
  $obj info shade
} {blue}


test tool-prototype-0005-0006 {Mixin color1} {
  $obj did
} {MixinColor1}


test tool-prototype-0005-0007 {Mixin color1} {
  $obj path
} {::MixinColor1 ::MixinOption2 ::MixinOption1 ::MixinRoot ::clay::object}


test tool-prototype-0005-0008 {Mixin color1} {
  $obj clay get opts
} {color blue option option2 core root}


test tool-prototype-0005-0009 {Mixin color1} {
  $obj clay get opts core
} {root}


test tool-prototype-0005-0010 {Mixin color1} {
  $obj clay get opts option
} {option2}


test tool-prototype-0005-0011 {Mixin color1} {
  $obj clay get opts color
} {blue}


test tool-prototype-0005-0012 {Mixin color1} {
  $obj clay ancestors
} {::MixinColor1 ::MixinOption2 ::MixinOption1 ::MixinRoot ::clay::object}

$obj clay mixinmap color MixinColor2

test tool-prototype-0006-0001 {Mixin color2} {
  $obj info root
} {MixinRoot}


test tool-prototype-0006-0002 {Mixin color2} {
  $obj info option
} {MixinOption2}


test tool-prototype-0006-0003 {Mixin color2} {
  $obj info color
} {MixinColor2}


test tool-prototype-0006-0004 {Mixin color2} {
  $obj info other
} {MixinOption1}


test tool-prototype-0006-0005 {Mixin color2} {
  $obj info shade
} {green}


test tool-prototype-0006-0006 {Mixin color2} {
  $obj clay get opts
} {color green option option2 core root}


test tool-prototype-0006-0007 {Mixin color2} {
  $obj clay get opts core
} {root}


test tool-prototype-0006-0008 {Mixin color2} {
  $obj clay get opts option
} {option2}


test tool-prototype-0006-0009 {Mixin color2} {
  $obj clay get opts color
} {green}


test tool-prototype-0006-0010 {Mixin color2} {
  $obj clay ancestors
} {::MixinColor2 ::MixinOption2 ::MixinOption1 ::MixinRoot ::clay::object}

$obj clay mixinmap option MixinOption1

test tool-prototype-0007-0001 {Mixin color2 + Option1} {
  $obj info root
} {MixinRoot}


test tool-prototype-0007-0002 {Mixin color2 + Option1} {
  $obj info option
} {MixinOption1}


test tool-prototype-0007-0003 {Mixin color2 + Option1} {
  $obj info color
} {MixinColor2}


test tool-prototype-0007-0004 {Mixin color2 + Option1} {
  $obj info other
} {MixinOption1}


test tool-prototype-0007-0005 {Mixin color2 + Option1} {
  $obj info shade
} {green}


test tool-prototype-0007-0006 {Mixin color2 + Option1} {
  $obj clay get opts
} {color green option option1 core root}


test tool-prototype-0007-0007 {Mixin color2 + Option1} {
  $obj clay get opts core
} {root}


test tool-prototype-0007-0008 {Mixin color2 + Option1} {
  $obj clay get opts option
} {option1}


test tool-prototype-0007-0009 {Mixin color2 + Option1} {
  $obj clay get opts color
} {green}


test tool-prototype-0007-0010 {Mixin color2 + Option1} {
  $obj clay ancestors
} {::MixinColor2 ::MixinOption1 ::MixinRoot ::clay::object}

$obj clay mixinmap option {}

test tool-prototype-0008-0001 {Mixin color2 + no option} {
  $obj info root
} {MixinRoot}


test tool-prototype-0008-0002 {Mixin color2 + no option} {
  $obj info option
} {Undefined}


test tool-prototype-0008-0003 {Mixin color2 + no option} {
  $obj info color
} {MixinColor2}


test tool-prototype-0008-0004 {Mixin color2 + no option} {
  $obj info other
} {Undefined}


test tool-prototype-0008-0005 {Mixin color2 + no option} {
  $obj info shade
} {green}


test tool-prototype-0008-0006 {Mixin color2 + no option} {
  $obj clay get opts
} {color green core root option unset}


test tool-prototype-0008-0007 {Mixin color2 + no option} {
  $obj clay get opts core
} {root}


test tool-prototype-0008-0008 {Mixin color2 + no option} {
  $obj clay get opts option
} {unset}


test tool-prototype-0008-0009 {Mixin color2 + no option} {
  $obj clay get opts color
} {green}


test tool-prototype-0008-0010 {Mixin color2 + no option} {
  $obj clay ancestors
} {::MixinColor2 ::MixinRoot ::clay::object}

$obj clay mixinmap color {}

test tool-prototype-0009-0001 {Mixin core (return to normal)} {
  $obj info root
} {MixinRoot}


test tool-prototype-0009-0002 {Mixin core (return to normal)} {
  $obj info option
} {Undefined}


test tool-prototype-0009-0003 {Mixin core (return to normal)} {
  $obj info color
} {Undefined}


test tool-prototype-0009-0004 {Mixin core (return to normal)} {
  $obj info other
} {Undefined}


test tool-prototype-0009-0005 {Mixin core (return to normal)} {
  $obj info shade
} {avacodo}


test tool-prototype-0009-0006 {Mixin core (return to normal)} {
  $obj clay get opts
} {core root option unset color unset}


test tool-prototype-0009-0007 {Mixin core (return to normal)} {
  $obj clay get opts core
} {root}


test tool-prototype-0009-0008 {Mixin core (return to normal)} {
  $obj clay get opts option
} {unset}


test tool-prototype-0009-0009 {Mixin core (return to normal)} {
  $obj clay get opts color
} {unset}


test tool-prototype-0009-0010 {Mixin core (return to normal)} {
  $obj clay ancestors
} {::MixinRoot ::clay::object}


###
# Tip479 Tests
###
clay::define tip479class {

  Method newitem dictargs {
    id {type: number}
    color {default: green}
    shape {options: {round square}}
    flavor {default: grape}
  } {
    my variable items
    foreach {f v} $args {
      dict set items $id $f $v
    }
    if {"color" ni [dict keys $args]} {
      dict set items $id color $color
    }
    return [dict get $items $id]
  }

  method itemget {id field} {
    my variable items
    return [dict get $id $field]
  }
}

set obj [tip479class new]
test tip479-001 {Test that a later ensemble definition trumps a more primitive one} {
  $obj newitem id 1 color orange shape round
} {id 1 color orange shape round}

# Fail because we left off a mandatory argument
test tip479-002 {Test that a later ensemble definition trumps a more primitive one} -body {
  $obj newitem id 2
} -result {shape is required} -returnCodes error

###
# Leave off a value that has a default
# note: Method had special handling for color, but not flavor
###
test tip479-003 {Test that a later ensemble definition trumps a more primitive one} {
  $obj newitem id 3 shape round
} {id 3 shape round color green}

###
# Add extra arguments
###
test tip479-004 {Test that a later ensemble definition trumps a more primitive one} {
  $obj newitem id 4 shape round trim leather
} {id 4 shape round trim leather color green}

clay::define tip479classE {

  Ensemble item::new dictargs {
    id {type: number}
    color {default: green}
    shape {options: {round square}}
    flavor {default: grape}
  } {
    my variable items
    foreach {f v} $args {
      dict set items $id $f $v
    }
    if {"color" ni [dict keys $args]} {
      dict set items $id color $color
    }
    return [dict get $items $id]
  }

  Ensemble item::get {id field} {
    my variable items
    return [dict get $id $field]
  }
}


set obj [tip479classE new]
test tip479-001 {Test that a later ensemble definition trumps a more primitive one} {
  $obj item new id 1 color orange shape round
} {id 1 color orange shape round}

# Fail because we left off a mandatory argument
test tip479-002 {Test that a later ensemble definition trumps a more primitive one} -body {
  $obj item new id 2
} -result {shape is required} -returnCodes error

###
# Leave off a value that has a default
# note: Method had special handling for color, but not flavor
###
test tip479-003 {Test that a later ensemble definition trumps a more primitive one} {
  $obj item new id 3 shape round
} {id 3 shape round color green}

###
# Add extra arguments
###
test tip479-004 {Test that a later ensemble definition trumps a more primitive one} {
  $obj item new id 4 shape round trim leather
} {id 4 shape round trim leather color green}

testsuiteCleanup

# Local variables:
# mode: tcl
# indent-tabs-mode: nil
# End:

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

if {![package vsatisfies [package provide Tcl] 8.7]} {return}
puts "Repeating tests with 8.7 features"

namespace eval ::oo::dialect {
    variable has ; set has(tip470) 1
}

# clay.test - Copyright (c) 2018 Sean Woods
# -------------------------------------------------------------------------

set MODDIR [file dirname [file dirname [file join [pwd] [info script]]]]
if {[file exists [file join $MODDIR devtools testutilities.tcl]]} {
  # Running inside tcllib
  set TCLLIBMOD $MODDIR
} else {
  set TCLLIBMOD [file join $MODDIR .. .. tcllib modules]
}
source [file join $TCLLIBMOD devtools testutilities.tcl]

testsNeedTcl     8.6
testsNeedTcltest 2
testsNeed        TclOO 1

support {}
testing {
    useLocal clay.tcl clay
}

set ::clay::trace 0

# -------------------------------------------------------------------------
# Handle multiple implementation testing
#

array set preserve [array get ::clay::uuid::accel]

proc implementations {} {
    variable ::clay::uuid::accel
    foreach {a v} [array get accel] {if {$v} {lappend r $a}}
    lappend r tcl; set r
}

proc select_implementation {impl} {
    variable ::clay::uuid::accel
    foreach e [array names accel] { set accel($e) 0 }
    if {[string compare "tcl" $impl] != 0} {
        set accel($impl) 1
    }
}

proc reset_implementation {} {
    variable ::clay::uuid::accel
    array set accel [array get ::preserve]
}

# -------------------------------------------------------------------------
# Setup any constraints
#

# -------------------------------------------------------------------------
# Now the package specific tests....
# -------------------------------------------------------------------------

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

foreach impl [implementations] {
    select_implementation $impl

    test uuid-1.0-$impl "uuid requires args" {
        list [catch {clay::uuid} msg]
    } {1}

    test uuid-1.1-$impl "uuid generate should create a 36 char string uuid" {
        list [catch {string length [clay::uuid generate]} msg] $msg
    } {0 36}

    test uuid-1.2-$impl "uuid comparison of uuid with self should be true" {
        list [catch {
            set a [clay::uuid generate]
            clay::uuid equal $a $a
        } msg] $msg
    } {0 1}

    test uuid-1.3-$impl "uuid comparison of two different uuids should be false" {
        list [catch {
            set a [clay::uuid generate]
            set b [clay::uuid generate]
            clay::uuid equal $a $b
        } msg] $msg
    } {0 0}

    reset_implementation
}


# Modification History:
###
# Modification 2018-10-30
# Fixed an error in our ancestry mapping and developed tests to
# ensure we are actually following in the order TclOO follows methods
###
# Modification 2018-10-21
# The clay metaclass no longer exports the clay method
# to oo::class and oo::object, and clay::ancestors no
# longer returns any class that lacks the clay method
###
# Modification 2018-10-10
# clay::ancestors now rigged to descend into all classes depth-first
# and then place metaclasses at the end of the search
###
# -------------------------------------------------------------------------

# -------------------------------------------------------------------------
# Test Helpers
###
proc dict_compare {a b} {
  set result {}
  set A {}
  dict for {f v} $a {
    set f [string trim $f :/]
    if {$f eq {.}} continue
    dict set A $f $v
  }
  set B {}
  dict for {f v} $b {
    set f [string trim $f :/]
    if {$f eq {.}} continue
    dict set B $f $v
  }
  dict for {f v} $A {
    if {[dict exists $B $f]} {
      if {[dict get $B $f] ne $v} {
        lappend result [list B $f [dict get $B $f] [list != $v]]
      }
    } else {
      lappend result [list B $f $v missing]
    }
  }
  dict for {f v} $B {
    if {![dict exists $A $f]} {
      lappend result [list A $f $v missing]
    }
  }
  return $result
}

test dict-compare-001 {Test our testing method} {
  dict_compare {} {}
} {}

test dict-compare-002 {Test our testing method} {
  dict_compare {a 1} {}
} {{B a 1 missing}}

test dict-compare-003 {Test our testing method} {
  dict_compare {a 1 b 2} {a 1 b 2}
} {}

test dict-compare-003.a {Test our testing method} {
  dict_compare {a 1 b 2} {b 2 a 1 }
} {}

test dict-compare-003.b {Test our testing method} {
  dict_compare {b 2 a 1} {a 1 b 2}
} {}


test dict-compare-004 {Test our testing method} {
  dict_compare {a: 1 b: 2} {a 1 b 2}
} {}

test dict-compare-005 {Test our testing method} {
  dict_compare {a 1 b 3} {a 1 b 2}
} {{B b 2 {!= 3}}}


###
# Test canonical mapping
###


test {test-storage-0001} {Test ::clay::tree::storage with foo bar baz} {
  clay::tree::storage {foo bar baz}
} {foo bar baz}


test {test-storage-0002} {Test ::clay::tree::storage with foo bar baz/} {
  clay::tree::storage {foo bar baz/}
} {foo bar baz}


test {test-storage-0003} {Test ::clay::tree::storage with foo bar .} {
  clay::tree::storage {foo bar .}
} {foo bar .}


test {test-storage-0004} {Test ::clay::tree::storage with foo/ bar/ .} {
  clay::tree::storage {foo/ bar/ .}
} {foo bar .}


test {test-storage-0005} {Test ::clay::tree::storage with foo . bar . baz .} {
  clay::tree::storage {foo . bar . baz .}
} {foo . bar . baz .}


test {test-storage-0006} {Test ::clay::tree::storage with foo bar baz bat:} {
  clay::tree::storage {foo bar baz bat:}
} {foo bar baz bat:}


test {test-storage-0007} {Test ::clay::tree::storage with foo:} {
  clay::tree::storage {foo:}
} {foo:}


test {test-storage-0008} {Test ::clay::tree::storage with foo/bar/baz/bat:} {
  clay::tree::storage {foo/bar/baz/bat:}
} {foo bar baz bat:}


dict set r foo/ bar/ baz 1
dict set s foo/ bar/ baz 0
set t [clay::tree::merge $r $s]

test rmerge-0001 {Test that the root is marked as a branch} {
  dict get $t foo bar baz
} 0

set r [dict create]
clay::tree::dictmerge r {
  foo/ {
    bar/ {
      baz 1
      bing: 2
      bang { bim 3 boom 4 }
      womp: {a 1 b 2}
    }
  }
}

test dictmerge-0001 {Test that the root is marked as a branch} {
  dict exists $r .
} 1
test dictmerge-0002 {Test that branch foo is marked correctly} {
  dict exists $r foo .
} 1
test dictmerge-0003 {Test that branch bar is marked correctly} {
  dict exists $r foo bar .
} 1
test dictmerge-0004 {Test that leaf foo/bar/bang is not marked as branch despite being a dict} {
  dict exists $r foo bar bang .
} 0
test dictmerge-0004 {Test that leaf foo/bar/bang/bim exists} {
  dict exists $r foo bar bang bim
} 1
test dictmerge-0005 {Test that leaf foo/bar/bang/boom exists} {
  dict exists $r foo bar bang boom
} 1

###
# Replace bang with bang/
###
clay::tree::dictmerge r {
  foo/ {
    bar/ {
      bang/ {
        whoop 1
      }
    }
  }
}

test dictmerge-0006 {Test that leaf foo/bar/bang/bim ceases to exist} {
  dict exists $r foo bar bang bim
} 0
test dictmerge-0007 {Test that leaf foo/bar/bang/boom exists} {
  dict exists $r foo bar bang boom
} 0

test dictmerge-0008 {Test that leaf foo/bar/bang is now a branch} {
  dict exists $r foo bar bang .
} 1

test branch-0001 {Test that foo/ is a branch} {
  clay::tree::is_branch $r foo/
} 1
test branch-0002 {Test that foo is a branch} {
  clay::tree::is_branch $r foo
} 1
test branch-0003 {Test that foo/bar/ is a branch} {
  clay::tree::is_branch $r {foo/ bar/}
} 1
test branch-0004 {Test that foo bar is not branch} {
  clay::tree::is_branch $r {foo bar}
} 1
test branch-0004 {Test that foo/ bar is not branch} {
  clay::tree::is_branch $r {foo/ bar}
} 0


test {test-branch-0001} {Test that  foo is_branch = 1} {
  clay::tree::is_branch $r { foo}
} 1


test {test-branch-0002} {Test that  foo: is_branch = 0} {
  clay::tree::is_branch $r { foo:}
} 0


test {test-branch-0003} {Test that  foo/ is_branch = 1} {
  clay::tree::is_branch $r { foo/}
} 1


test {test-branch-0004} {Test that  .foo is_branch = 0} {
  clay::tree::is_branch $r { .foo}
} 0


test {test-branch-0005} {Test that foo bar is_branch = 1} {
  clay::tree::is_branch $r {foo bar}
} 1


test {test-branch-0006} {Test that foo bar: is_branch = 0} {
  clay::tree::is_branch $r {foo bar:}
} 0


test {test-branch-0007} {Test that foo bar/ is_branch = 1} {
  clay::tree::is_branch $r {foo bar/}
} 1


test {test-branch-0008} {Test that foo .bar is_branch = 0} {
  clay::tree::is_branch $r {foo .bar}
} 0


test {test-branch-0009} {Test that foo bar baz is_branch = 0} {
  clay::tree::is_branch $r {foo bar baz}
} 0


test {test-branch-0010} {Test that foo bar baz: is_branch = 0} {
  clay::tree::is_branch $r {foo bar baz:}
} 0


test {test-branch-0011} {Test that foo bar baz/ is_branch = 1} {
  clay::tree::is_branch $r {foo bar baz/}
} 1


test {test-branch-0012} {Test that foo bar .baz is_branch = 0} {
  clay::tree::is_branch $r {foo bar .baz}
} 0


test {test-branch-0013} {Test that foo bar bing is_branch = 0} {
  clay::tree::is_branch $r {foo bar bing}
} 0


test {test-branch-0014} {Test that foo bar bing: is_branch = 0} {
  clay::tree::is_branch $r {foo bar bing:}
} 0


test {test-branch-0015} {Test that foo bar bing/ is_branch = 1} {
  clay::tree::is_branch $r {foo bar bing/}
} 1


test {test-branch-0016} {Test that foo bar .bing is_branch = 0} {
  clay::tree::is_branch $r {foo bar .bing}
} 0


test {test-branch-0017} {Test that foo bar bang is_branch = 1} {
  clay::tree::is_branch $r {foo bar bang}
} 1


test {test-branch-0018} {Test that foo bar bang: is_branch = 0} {
  clay::tree::is_branch $r {foo bar bang:}
} 0


test {test-branch-0019} {Test that foo bar bang/ is_branch = 1} {
  clay::tree::is_branch $r {foo bar bang/}
} 1


test {test-branch-0020} {Test that foo bar .bang is_branch = 0} {
  clay::tree::is_branch $r {foo bar .bang}
} 0


test {test-branch-0021} {Test that foo bar bang whoop is_branch = 0} {
  clay::tree::is_branch $r {foo bar bang whoop}
} 0


test {test-branch-0022} {Test that foo bar bang whoop: is_branch = 0} {
  clay::tree::is_branch $r {foo bar bang whoop:}
} 0


test {test-branch-0023} {Test that foo bar bang whoop/ is_branch = 1} {
  clay::tree::is_branch $r {foo bar bang whoop/}
} 1


test {test-branch-0024} {Test that foo bar bang .whoop is_branch = 0} {
  clay::tree::is_branch $r {foo bar bang .whoop}
} 0


# -------------------------------------------------------------------------
# dictmerge Testing - oometa
unset -nocomplain foo
clay::tree::dictmerge foo {
  option/ {
    color/ {
      label Color
      default green
    }
  }
}
clay::tree::dictmerge foo {
  option/ {
    color/ {
      default purple
    }
  }
}

test oometa-0001 {Invoking dictmerge with empty args on a non existent variable create an empty variable} {
  dict get $foo option color default
} purple
test oometa-0002 {Invoking dictmerge with empty args on a non existent variable create an empty variable} {
  dict get $foo option color label
} Color

unset -nocomplain foo
set foo {. {}}
::clay::tree::dictmerge foo {. {} color {. {} default green label Color}}
::clay::tree::dictmerge foo {. {} color {. {} default purple}}
test oometa-0003 {Recursive merge problem from oometa/clay find} {
  dict get $foo color default
} purple
test oometa-0004 {Recursive merge problem from oometa/clay find} {
  dict get $foo color label
} Color

unset -nocomplain foo
set foo {. {}}
::clay::tree::dictmerge foo {. {} color {. {} default purple}}
::clay::tree::dictmerge foo {. {} color {. {} default green label Color}}
test oometa-0005 {Recursive merge problem from oometa/clay find} {
  dict get $foo color default
} green
test oometa-0006 {Recursive merge problem from oometa/clay find} {
  dict get $foo color label
} Color

test oometa-0008 {Un-Sanitized output} {
  set foo
} {. {} color {. {} default green label Color}}

test oometa-0009 {Sanitize} {
  clay::tree::sanitize $foo
} {color {default green label Color}}


# -------------------------------------------------------------------------
# dictmerge Testing - clay
unset -nocomplain foo
test clay-0001 {Invoking dictmerge with empty args on a non existent variable create an empty variable} {
  ::clay::tree::dictmerge foo
  set foo
} {. {}}

unset -nocomplain foo
::clay::tree::dictset foo bar/ baz/ bell bang

test clay-0002 {For new entries dictmerge is essentially a set} {
  dict get $foo bar baz bell
} {bang}
::clay::tree::dictset foo bar/ baz/ boom/ bang
test clay-0003 {For entries that do exist a zipper merge is performed} {
  dict get $foo bar baz bell
} {bang}
test clay-0004 {For entries that do exist a zipper merge is performed} {
  dict get $foo bar baz boom
} {bang}

::clay::tree::dictset foo bar/ baz/ bop {color green flavor strawberry}

test clay-0005 {Leaves are replaced even if they look like a dict} {
  dict get $foo bar baz bop
} {color green flavor strawberry}

::clay::tree::dictset foo bar/ baz/ bop {color yellow}
test clay-0006 {Leaves are replaced even if they look like a dict} {
  dict get $foo bar baz bop
} {color yellow}

::clay::tree::dictset foo bar/ baz/ bang/ {color green flavor strawberry}
test clay-0007a {Branches are merged} {
  dict get $foo bar baz bang
} {. {} color green flavor strawberry}

::clay::tree::dictset foo bar/ baz/ bang/ color yellow
test clay-0007b {Branches are merged}  {
  dict get $foo bar baz bang
} {. {} color yellow flavor strawberry}

::clay::tree::dictset foo bar/ baz/ bang/ {color blue}
test clay-0007c {Branches are merged}  {
  dict get $foo bar baz bang
} {. {} color blue flavor strawberry}

::clay::tree::dictset foo bar/ baz/ bang/ shape: {Sort of round}
test clay-0007d {Branches are merged} {
  dict get $foo bar baz bang
} {. {} color blue flavor strawberry shape: {Sort of round}}

::clay::tree::dictset foo bar/ baz/ bang/ color yellow
test clay-0007e {Branches are merged}  {
  dict get $foo bar baz bang
} {. {} color yellow flavor strawberry shape: {Sort of round}}

::clay::tree::dictset foo bar/ baz/ bang/ {color blue}
test clay-0007f {Branches are merged}  {
  dict get $foo bar baz bang
} {. {} color blue flavor strawberry shape: {Sort of round}}

::clay::tree::dictset foo dict my_var 10
::clay::tree::dictset foo dict my_other_var 9

test clay-0007g {Branches are merged}  {
  dict get $foo dict
} {. {} my_var 10 my_other_var 9}

::clay::tree::dictset foo dict/ my_other_other_var 8
test clay-0007h {Branches are merged}  {
  dict get $foo dict
} {. {} my_var 10 my_other_var 9 my_other_other_var 8}


::clay::tree::dictmerge foo {option/ {color {type color} flavor {sense taste}}}
::clay::tree::dictmerge foo {option/ {format {default ascii}}}

test clay-0008 {Whole dicts are merged}  {
  dict get $foo option color
} {type color}
test clay-0009 {Whole dicts are merged}  {
  dict get $foo option flavor
} {sense taste}
test clay-0010 {Whole dicts are merged}  {
  dict get $foo option format
} {default ascii}

###
# Tests for the httpd module
###
test clay-0010 {Test that leaves are merged properly}
set bar {}
::clay::tree::dictmerge bar {
   proxy/ {port 10101 host myhost.localhost}
}
::clay::tree::dictmerge bar {
   mimetxt {Host: localhost
Content_Type: text/plain
Content-Length: 15
}
   http {HTTP_HOST {} CONTENT_LENGTH 15 HOST localhost CONTENT_TYPE text/plain UUID 3a7b4cdc-28d7-49b7-b18d-9d7d18382b9e REMOTE_ADDR 127.0.0.1 REMOTE_HOST 127.0.0.1 REQUEST_METHOD POST REQUEST_URI /echo REQUEST_PATH echo REQUEST_VERSION 1.0 DOCUMENT_ROOT {} QUERY_STRING {} REQUEST_RAW {POST /echo HTTP/1.0} SERVER_PORT 10001 SERVER_NAME 127.0.0.1 SERVER_PROTOCOL HTTP/1.1 SERVER_SOFTWARE {TclHttpd 4.2.0} LOCALHOST 0} UUID 3a7b4cdc-28d7-49b7-b18d-9d7d18382b9e uriinfo {fragment {} port {} path echo scheme http host {} query {} pbare 0 pwd {} user {}}
   mixin {reply ::test::content.echo}
   prefix /echo
   proxy_port 10010
   proxy/ {host localhost}
}

test clay-0011 {Whole dicts are merged}  {
  dict get $bar proxy_port
} {10010}

test clay-0012 {Whole dicts are merged}  {
  dict get $bar http CONTENT_LENGTH
} 15
test clay-0013 {Whole dicts are merged}  {
  dict get $bar proxy host
} localhost
test clay-0014 {Whole dicts are merged}  {
  dict get $bar proxy port
} 10101


###
# Dialect Testing
###
::clay::dialect::create ::alpha

proc ::alpha::define::is_alpha {} {
  dict set ::testinfo([current_class]) is_alpha 1
}

::alpha::define ::alpha::object {
  is_alpha
}

::clay::dialect::create ::bravo ::alpha

proc ::bravo::define::is_bravo {} {
  dict set ::testinfo([current_class]) is_bravo 1
}

::bravo::define ::bravo::object {
  is_bravo
}

::clay::dialect::create ::charlie ::bravo

proc ::charlie::define::is_charlie {} {
  dict set ::testinfo([current_class]) is_charlie 1
}

::charlie::define ::charlie::object {
  is_charlie
}

::clay::dialect::create ::delta ::charlie

proc ::delta::define::is_delta {} {
  dict set ::testinfo([current_class]) is_delta 1
}

::delta::define ::delta::object {
  is_delta
}

::delta::class create adam {
  is_alpha
  is_bravo
  is_charlie
  is_delta
}

test oodialect-keyword-001 {Testing keyword application} {
  set ::testinfo(::adam)
} {is_alpha 1 is_bravo 1 is_charlie 1 is_delta 1}

test oodialect-keyword-002 {Testing keyword application} {
  set ::testinfo(::alpha::object)
} {is_alpha 1}

test oodialect-keyword-003 {Testing keyword application} {
  set ::testinfo(::bravo::object)
} {is_bravo 1}

test oodialect-keyword-004 {Testing keyword application} {
  set ::testinfo(::charlie::object)
} {is_charlie 1}

test oodialect-keyword-005 {Testing keyword application} {
  set ::testinfo(::delta::object)
} {is_delta 1}

###
# Declare an object from a namespace
###
namespace eval ::test1 {
  ::alpha::class create a {
    aliases A
    is_alpha
  }
  ::alpha::define b {
    aliases B BEE
    is_alpha
  }
  ::alpha::class create ::c {
    aliases C
    is_alpha
  }
  ::alpha::define ::d {
    aliases D
    is_alpha
  }
}

test oodialect-naming-001 {Testing keyword application} {
  set ::testinfo(::test1::a)
} {is_alpha 1}

test oodialect-naming-002 {Testing keyword application} {
  set ::testinfo(::test1::b)
} {is_alpha 1}

test oodialect-naming-003 {Testing keyword application} {
  set ::testinfo(::c)
} {is_alpha 1}

test oodialect-naming-004 {Testing keyword application} {
  set ::testinfo(::d)
} {is_alpha 1}

test oodialect-aliasing-001 {Testing keyword application} {
namespace eval ::test1 {
    ::alpha::define e {
       superclass A
    }
}
} ::test1::e

test oodialect-aliasing-002 {Testing keyword application} {
namespace eval ::test1 {
    ::bravo::define f {
       superclass A
    }
}
} ::test1::f


test oodialect-aliasing-003 {Testing aliase method on class} {
  ::test1::a aliases
} {::test1::A}

###
# Test modified 2018-10-21
###
test oodialect-ancestry-003 {Testing heritage} {
  ::clay::ancestors ::test1::f
} {}

###
# Test modified 2018-10-21
###
test oodialect-ancestry-004 {Testing heritage} {
  ::clay::ancestors ::alpha::object
} {}

###
# Test modified 2018-10-21
###
test oodialect-ancestry-005 {Testing heritage} {
  ::clay::ancestors ::delta::object
} {}



# -------------------------------------------------------------------------
# clay submodule testing
# -------------------------------------------------------------------------



# Test canonical path building
set path {const/ foo/ bar/ baz/}


test oo-clay-path-0001 "Test path: const foo bar baz" {
  ::clay::path const foo bar baz
} $path


test oo-clay-path-0002 "Test path: const/ foo/ bar/ baz" {
  ::clay::path const/ foo/ bar/ baz
} $path


test oo-clay-path-0003 "Test path: const/foo/bar/baz" {
  ::clay::path const/foo/bar/baz
} $path


test oo-clay-path-0004 "Test path: const/foo bar/baz" {
  ::clay::path const/foo bar/baz
} $path


test oo-clay-path-0005 "Test path: const/foo/bar baz" {
  ::clay::path const/foo/bar baz
} $path


test oo-clay-path-0006 "Test path: const foo/bar/baz" {
  ::clay::path const foo/bar/baz
} $path


test oo-clay-path-0007 "Test path: const foo bar/baz" {
  ::clay::path const foo bar/baz
} $path


test oo-clay-path-0008 "Test path: const/foo bar baz" {
  ::clay::path const/foo bar baz
} $path

set path {const/ foo/ bar/ baz/ bing}

test oo-clay-leaf-0001 "Test leaf: const foo bar baz bing" {
  ::clay::leaf const foo bar baz bing
} $path


test oo-clay-leaf-0002 "Test leaf: const/ foo/ bar/ baz/ bing" {
  ::clay::leaf const/ foo/ bar/ baz/ bing
} $path


test oo-clay-leaf-0003 "Test leaf: const/foo/bar/baz/bing" {
  ::clay::leaf const/foo/bar/baz/bing
} $path


test oo-clay-leaf-0004 "Test leaf: const/foo bar/baz/bing:" {
  ::clay::leaf const/foo bar/baz/bing:
} $path


test oo-clay-leaf-0005 "Test leaf: const/foo/bar baz bing" {
  ::clay::leaf const/foo/bar baz bing
} $path


test oo-clay-leaf-0006 "Test leaf: const/foo/bar baz bing:" {
  ::clay::leaf const/foo/bar baz bing:
} $path


test oo-clay-leaf-0007 "Test leaf: const foo/bar/baz/bing" {
  ::clay::leaf const foo/bar/baz/bing
} $path


test oo-clay-leaf-0008 "Test leaf: const foo bar/baz/bing" {
  ::clay::leaf const foo bar/baz/bing
} $path


test oo-clay-leaf-0009 "Test leaf: const/foo bar baz bing" {
  ::clay::leaf const/foo bar baz bing
} $path

namespace eval ::foo {}

clay::define ::foo::classa {

  clay set const color  blue
  clay set const/flavor strawberry
  clay set {const/ sound} zoink
  clay set info/ {
    animal no
    building no
    subelement {pedantic yes}
  }

  # Provide a method that returns a constant so we can compare clay's inheritance to
  # TclOO
  method color {} {
    return blue
  }
  method flavor {} {
    return strawberry
  }
  method sound {} {
    return zoink
  }

}


test oo-class-clay-method-0001 "Test ::foo::classa const/ color exists" {
  ::foo::classa clay exists const/ color
} 1


test oo-class-clay-method-0001 "Test ::foo::classa const/ color value" {
  ::foo::classa clay get const/ color
} {blue}


test oo-class-clay-method-0003 "Test ::foo::classa const/ flavor exists" {
  ::foo::classa clay exists const/ flavor
} 1


test oo-class-clay-method-0003 "Test ::foo::classa const/ flavor value" {
  ::foo::classa clay get const/ flavor
} {strawberry}


test oo-class-clay-method-0005 "Test ::foo::classa const/ sound exists" {
  ::foo::classa clay exists const/ sound
} 1


test oo-class-clay-method-0005 "Test ::foo::classa const/ sound value" {
  ::foo::classa clay get const/ sound
} {zoink}


test oo-class-clay-method-0007 "Test ::foo::classa info/ animal exists" {
  ::foo::classa clay exists info/ animal
} 1


test oo-class-clay-method-0007 "Test ::foo::classa info/ animal value" {
  ::foo::classa clay get info/ animal
} {no}


test oo-class-clay-method-0009 "Test ::foo::classa info/ building exists" {
  ::foo::classa clay exists info/ building
} 1


test oo-class-clay-method-0009 "Test ::foo::classa info/ building value" {
  ::foo::classa clay get info/ building
} {no}


test oo-class-clay-method-0011 "Test ::foo::classa info/ subelement exists" {
  ::foo::classa clay exists info/ subelement
} 1


test oo-class-clay-method-0011 "Test ::foo::classa info/ subelement value" {
  ::foo::classa clay get info/ subelement
} {pedantic yes}


clay::define ::foo::classb {
  clay set const/ color black
  method color {} {return black}
  clay set const/ flavor vanilla
  method flavor {} {return vanilla}
  clay set const/ feeling dread
  method feeling {} {return dread}
  clay set info/ subelement {spoon yes}
  method subelement {} {return {spoon yes}}

}


test oo-class-clay-method-0013 "Test ::foo::classb const/ color exists" {
  ::foo::classb clay exists const/ color
} 1


test oo-class-clay-method-0013 "Test ::foo::classb const/ color value" {
  ::foo::classb clay get const/ color
} {black}


test oo-class-clay-method-0015 "Test ::foo::classb const/ flavor exists" {
  ::foo::classb clay exists const/ flavor
} 1


test oo-class-clay-method-0015 "Test ::foo::classb const/ flavor value" {
  ::foo::classb clay get const/ flavor
} {vanilla}


test oo-class-clay-method-0017 "Test ::foo::classb const/ feeling exists" {
  ::foo::classb clay exists const/ feeling
} 1


test oo-class-clay-method-0017 "Test ::foo::classb const/ feeling value" {
  ::foo::classb clay get const/ feeling
} {dread}


test oo-class-clay-method-0019 "Test ::foo::classb info/ subelement exists" {
  ::foo::classb clay exists info/ subelement
} 1


test oo-class-clay-method-0019 "Test ::foo::classb info/ subelement value" {
  ::foo::classb clay get info/ subelement
} {spoon yes}


clay::define ::foo::class.ab {
superclass ::foo::classb ::foo::classa
}


clay::define ::foo::class.ba {
superclass ::foo::classa ::foo::classb
}

# -------------------------------------------------------------------------
# Singleton
::clay::define ::test::singletonbehavior {
  method bar {} {
    return CLASS
  }
  method booze {} {
    return CLASS
  }
  Ensemble foo::bang {} {
    return CLASS
  }
  Ensemble foo::both {} {
    return CLASS
  }
  Ensemble foo::mixin {} {
    return CLASS
  }
  Ensemble foo::sloppy {} {
    return CLASS
  }
}
::clay::define ::test::flavor.strawberry {
  clay define property flavor strawbery
  method bar {} {
    return STRAWBERRY
  }
  Ensemble foo::bing {} {
    return STRAWBERRY
  }
  Ensemble foo::both {} {
    return STRAWBERRY
  }
  Ensemble foo::mixin {} {
    return STRAWBERRY
  }
  Ensemble foo::sloppy {} {
    return STRAWBERRY
  }
}
::clay::singleton ::TEST {
  class ::test::singletonbehavior
  clay mixinmap flavor ::test::flavor.strawberry
  clay set property color green
  method bar {} {
    return OBJECT
  }
  method booze {} {
    return OBJECT
  }
  method baz {} {
    return OBJECT
  }
  Ensemble foo::bar {} {
    return OBJECT
  }
  Ensemble foo::both {} {
    return OBJECT
  }
}

test oo-object-singleton-001 {Test singleton superclass keyword} {
  ::TEST clay delegate class
} {::test::singletonbehavior}

test oo-object-singleton-002 {Test singleton ensemble 1} {
  ::TEST foo <list>
} {bang bar bing both mixin sloppy}

test oo-object-singleton-003 {Test singleton ensemble from script} {
  ::TEST foo bar
} {OBJECT}
test oo-object-singleton-004 {Test singleton ensemble from mixin} {
  ::TEST foo bing
} {STRAWBERRY}
test oo-object-singleton-005 {Test singleton ensemble from class} {
  ::TEST foo bang
} {CLASS}
# Test note: the behavior from TclOO is unexpected
# Intuitively, a local method should override a mixin
# but this is not the case
test oo-object-singleton-006 {Test singleton ensemble from conflict, should resolve to object} {
  ::TEST foo both
} {STRAWBERRY}
test oo-object-singleton-007 {Test singleton ensemble from conflict, should resolve to mixin} {
  ::TEST foo sloppy
} {STRAWBERRY}
###
# Test note:
# This should work but does not
###
#test oo-object-singleton-009 {Test property from mixin/class} {
#  ::TEST clay get property flavor
#} {strawberry}
test oo-object-singleton-008 {Test property from script} {
  ::TEST clay get property color
} {green}


# Test note: the behavior from TclOO is unexpected
# Intuitively, a local method should override a mixin
# but this is not the case
test oo-object-singleton-010 {Test method declared in script} {
  ::TEST bar
} {STRAWBERRY}

test oo-object-singleton-011 {Test method declared in script} {
  ::TEST booze
} {OBJECT}
TEST destroy

# OBJECT of ::foo::classa
set OBJECTA [::foo::classa new]

###
# Test object degation
###
proc ::foo::fakeobject {a b} {
  return [expr {$a + $b}]
}

::clay::object create TEST
TEST clay delegate funct ::foo::fakeobject
test oo-object-delegate-001 {Test object delegation} {
  ::TEST clay delegate
} {<class> ::clay::object <funct> ::foo::fakeobject}

test oo-object-delegate-002 {Test object delegation} {
  ::TEST clay delegate funct
} {::foo::fakeobject}

test oo-object-delegate-002a {Test object delegation} {
  ::TEST clay delegate <funct>
} {::foo::fakeobject}

test oo-object-delegate-003 {Test object delegation} {
  ::TEST <funct> 1 1
} {2}
test oo-object-delegate-004 {Test object delegation} {
  ::TEST <funct> 10 -7
} {3}

# Replace the function out from under
proc ::foo::fakeobject {a b} {
  return [expr {$a * $b}]
}
test oo-object-delegate-005 {Test object delegation} {
  ::TEST <funct> 10 -7
} {-70}

# Object with ::foo::classa mixed in
set MIXINA  [::oo::object new]
oo::objdefine $MIXINA mixin ::foo::classa


test oo-object-clay-method-native-0001 {Test native object gets the property const//color} {
  $OBJECTA clay get const/ color
} {blue}
test oo-object-clay-method-mixin-0001 {Test mixin object gets the property const//color} {
  $MIXINA clay get const/ color
} {blue}


test oo-object-clay-method-native-methodcheck-0001 {Test that const//color would mimic method interheritance for a native class} {
  $OBJECTA color
} {blue}
test oo-object-clay-method-mixin-0001 {Test that const//color would mimic method interheritance for a mixed in class} {
  $MIXINA color
} {blue}
    

test oo-object-clay-method-native-0002 {Test native object gets the property const//flavor} {
  $OBJECTA clay get const/ flavor
} {strawberry}
test oo-object-clay-method-mixin-0002 {Test mixin object gets the property const//flavor} {
  $MIXINA clay get const/ flavor
} {strawberry}


test oo-object-clay-method-native-methodcheck-0002 {Test that const//flavor would mimic method interheritance for a native class} {
  $OBJECTA flavor
} {strawberry}
test oo-object-clay-method-mixin-0002 {Test that const//flavor would mimic method interheritance for a mixed in class} {
  $MIXINA flavor
} {strawberry}
    

test oo-object-clay-method-native-0003 {Test native object gets the property const//sound} {
  $OBJECTA clay get const/ sound
} {zoink}
test oo-object-clay-method-mixin-0003 {Test mixin object gets the property const//sound} {
  $MIXINA clay get const/ sound
} {zoink}


test oo-object-clay-method-native-methodcheck-0003 {Test that const//sound would mimic method interheritance for a native class} {
  $OBJECTA sound
} {zoink}
test oo-object-clay-method-mixin-0003 {Test that const//sound would mimic method interheritance for a mixed in class} {
  $MIXINA sound
} {zoink}
    

test oo-object-clay-method-native-0004 {Test native object gets the property info//animal} {
  $OBJECTA clay get info/ animal
} {no}
test oo-object-clay-method-mixin-0004 {Test mixin object gets the property info//animal} {
  $MIXINA clay get info/ animal
} {no}


test oo-object-clay-method-native-0005 {Test native object gets the property info//building} {
  $OBJECTA clay get info/ building
} {no}
test oo-object-clay-method-mixin-0005 {Test mixin object gets the property info//building} {
  $MIXINA clay get info/ building
} {no}


test oo-object-clay-method-native-0006 {Test native object gets the property info//subelement} {
  $OBJECTA clay get info/ subelement
} {pedantic yes}
test oo-object-clay-method-mixin-0006 {Test mixin object gets the property info//subelement} {
  $MIXINA clay get info/ subelement
} {pedantic yes}

# -------------------------------------------------------------------------
# OBJECT of ::foo::classb
set OBJECTB [::foo::classb new]
# Object with ::foo::classb mixed in
set MIXINB  [::oo::object new]
oo::objdefine $MIXINB mixin ::foo::classb


test oo-object-clay-method-native-0007 {Test native object gets the property const//color} {
  $OBJECTB clay get const/ color
} {black}
test oo-object-clay-method-mixin-0007 {Test mixin object gets the property const//color} {
  $MIXINB clay get const/ color
} {black}


test oo-object-clay-method-native-methodcheck-0007 {Test that const//color would mimic method interheritance for a native class} {
  $OBJECTB color
} {black}
test oo-object-clay-method-mixin-0007 {Test that const//color would mimic method interheritance for a mixed in class} {
  $MIXINB color
} {black}
    

test oo-object-clay-method-native-0008 {Test native object gets the property const//flavor} {
  $OBJECTB clay get const/ flavor
} {vanilla}
test oo-object-clay-method-mixin-0008 {Test mixin object gets the property const//flavor} {
  $MIXINB clay get const/ flavor
} {vanilla}


test oo-object-clay-method-native-methodcheck-0008 {Test that const//flavor would mimic method interheritance for a native class} {
  $OBJECTB flavor
} {vanilla}
test oo-object-clay-method-mixin-0008 {Test that const//flavor would mimic method interheritance for a mixed in class} {
  $MIXINB flavor
} {vanilla}
    

test oo-object-clay-method-native-0009 {Test native object gets the property const//feeling} {
  $OBJECTB clay get const/ feeling
} {dread}
test oo-object-clay-method-mixin-0009 {Test mixin object gets the property const//feeling} {
  $MIXINB clay get const/ feeling
} {dread}


test oo-object-clay-method-native-methodcheck-0009 {Test that const//feeling would mimic method interheritance for a native class} {
  $OBJECTB feeling
} {dread}
test oo-object-clay-method-mixin-0009 {Test that const//feeling would mimic method interheritance for a mixed in class} {
  $MIXINB feeling
} {dread}
    

test oo-object-clay-method-native-0010 {Test native object gets the property info//subelement} {
  $OBJECTB clay get info/ subelement
} {spoon yes}
test oo-object-clay-method-mixin-0010 {Test mixin object gets the property info//subelement} {
  $MIXINB clay get info/ subelement
} {spoon yes}

# -------------------------------------------------------------------------
# OBJECT descended from ::foo::classa ::foo::classb
set OBJECTAB [::foo::class.ab new]
# Object where classes were mixed in ::foo::classa ::foo::classb
set MIXINAB  [::oo::object new]
# Test modified 2018-10-30, mixin order was wrong before
oo::objdefine $MIXINAB mixin ::foo::classb ::foo::classa


test oo-object-clay-method-native-0011 {Test native object gets the property const//color} {
  $OBJECTAB clay get const/ color
} {black}
test oo-object-clay-method-mixin-0011 {Test mixin object gets the property const//color} {
  $MIXINAB clay get const/ color
} {black}


test oo-object-clay-method-native-methodcheck-0011 {Test that const//color would mimic method interheritance for a native class} {
  $OBJECTAB color
} {black}
test oo-object-clay-method-mixin-0011 {Test that const//color would mimic method interheritance for a mixed in class} {
  $MIXINAB color
} {black}
    

test oo-object-clay-method-native-0012 {Test native object gets the property const//flavor} {
  $OBJECTAB clay get const/ flavor
} {vanilla}
test oo-object-clay-method-mixin-0012 {Test mixin object gets the property const//flavor} {
  $MIXINAB clay get const/ flavor
} {vanilla}


test oo-object-clay-method-native-methodcheck-0012 {Test that const//flavor would mimic method interheritance for a native class} {
  $OBJECTAB flavor
} {vanilla}
test oo-object-clay-method-mixin-0012 {Test that const//flavor would mimic method interheritance for a mixed in class} {
  $MIXINAB flavor
} {vanilla}
    

test oo-object-clay-method-native-0013 {Test native object gets the property const//feeling} {
  $OBJECTAB clay get const/ feeling
} {dread}
test oo-object-clay-method-mixin-0013 {Test mixin object gets the property const//feeling} {
  $MIXINAB clay get const/ feeling
} {dread}


test oo-object-clay-method-native-methodcheck-0013 {Test that const//feeling would mimic method interheritance for a native class} {
  $OBJECTAB feeling
} {dread}
test oo-object-clay-method-mixin-0013 {Test that const//feeling would mimic method interheritance for a mixed in class} {
  $MIXINAB feeling
} {dread}
    

test oo-object-clay-method-native-0014 {Test native object gets the property const//sound} {
  $OBJECTAB clay get const/ sound
} {zoink}
test oo-object-clay-method-mixin-0014 {Test mixin object gets the property const//sound} {
  $MIXINAB clay get const/ sound
} {zoink}


test oo-object-clay-method-native-methodcheck-0014 {Test that const//sound would mimic method interheritance for a native class} {
  $OBJECTAB sound
} {zoink}
test oo-object-clay-method-mixin-0014 {Test that const//sound would mimic method interheritance for a mixed in class} {
  $MIXINAB sound
} {zoink}
    

test oo-object-clay-method-native-0015 {Test native object gets the property info//subelement} {
  $OBJECTAB clay get info/ subelement
} {spoon yes}
test oo-object-clay-method-mixin-0015 {Test mixin object gets the property info//subelement} {
  $MIXINAB clay get info/ subelement
} {spoon yes}


test oo-object-clay-method-native-0016 {Test native object gets the property info//animal} {
  $OBJECTAB clay get info/ animal
} {no}
test oo-object-clay-method-mixin-0016 {Test mixin object gets the property info//animal} {
  $MIXINAB clay get info/ animal
} {no}


test oo-object-clay-method-native-0017 {Test native object gets the property info//building} {
  $OBJECTAB clay get info/ building
} {no}
test oo-object-clay-method-mixin-0017 {Test mixin object gets the property info//building} {
  $MIXINAB clay get info/ building
} {no}

# -------------------------------------------------------------------------
# OBJECT descended from ::foo::classb ::foo::classa
set OBJECTBA [::foo::class.ba new]
# Object where classes were mixed in ::foo::classb ::foo::classa
set MIXINBA  [::oo::object new]
# Test modified 2018-10-30, mixin order was wrong before
oo::objdefine $MIXINBA mixin ::foo::classa ::foo::classb


test oo-object-clay-method-native-0018 {Test native object gets the property} {
  $OBJECTBA clay get const/ color
} {blue}
test oo-object-clay-method-mixin-0018 {Test mixin object gets the property} {
  $MIXINBA clay get const/ color
} {blue}


test oo-object-clay-method-native-methodcheck-0018 {Test that const//color would mimic method interheritance for a native class} {
  $OBJECTBA color
} {blue}
test oo-object-clay-method-mixin-0018 {Test that const//color would mimic method interheritance for a mixed in class} {
  $MIXINBA color
} {blue}
    

test oo-object-clay-method-native-0019 {Test native object gets the property} {
  $OBJECTBA clay get const/ flavor
} {strawberry}
test oo-object-clay-method-mixin-0019 {Test mixin object gets the property} {
  $MIXINBA clay get const/ flavor
} {strawberry}


test oo-object-clay-method-native-methodcheck-0019 {Test that const//flavor would mimic method interheritance for a native class} {
  $OBJECTBA flavor
} {strawberry}
test oo-object-clay-method-mixin-0019 {Test that const//flavor would mimic method interheritance for a mixed in class} {
  $MIXINBA flavor
} {strawberry}
    

test oo-object-clay-method-native-0020 {Test native object gets the property} {
  $OBJECTBA clay get const/ sound
} {zoink}
test oo-object-clay-method-mixin-0020 {Test mixin object gets the property} {
  $MIXINBA clay get const/ sound
} {zoink}


test oo-object-clay-method-native-methodcheck-0020 {Test that const//sound would mimic method interheritance for a native class} {
  $OBJECTBA sound
} {zoink}
test oo-object-clay-method-mixin-0020 {Test that const//sound would mimic method interheritance for a mixed in class} {
  $MIXINBA sound
} {zoink}
    

test oo-object-clay-method-native-0021 {Test native object gets the property} {
  $OBJECTBA clay get const/ feeling
} {dread}
test oo-object-clay-method-mixin-0021 {Test mixin object gets the property} {
  $MIXINBA clay get const/ feeling
} {dread}


test oo-object-clay-method-native-methodcheck-0021 {Test that const//feeling would mimic method interheritance for a native class} {
  $OBJECTBA feeling
} {dread}
test oo-object-clay-method-mixin-0021 {Test that const//feeling would mimic method interheritance for a mixed in class} {
  $MIXINBA feeling
} {dread}
    

test oo-object-clay-method-native-0022 {Test native object gets the property} {
  $OBJECTBA clay get info/ animal
} {no}
test oo-object-clay-method-mixin-0022 {Test mixin object gets the property} {
  $MIXINBA clay get info/ animal
} {no}


test oo-object-clay-method-native-0023 {Test native object gets the property} {
  $OBJECTBA clay get info/ building
} {no}
test oo-object-clay-method-mixin-0023 {Test mixin object gets the property} {
  $MIXINBA clay get info/ building
} {no}


test oo-object-clay-method-native-0024 {Test native object gets the property} {
  $OBJECTBA clay get info/ subelement
} {pedantic yes}
test oo-object-clay-method-mixin-0024 {Test mixin object gets the property} {
  $MIXINBA clay get info/ subelement
} {pedantic yes}


###
# put a do-nothing constructor on the books
###
::clay::define ::clay::object {
  constructor args {}
}

oo::objdefine ::clay::object method foo args { return bar }

test clay-core-method-0001 {Test that adding methods to the core ::clay::object class works} {
  ::clay::object foo
} {bar}

namespace eval ::TEST {}
::clay::define ::TEST::myclass {
  clay color red
  clay flavor strawberry

}

###
# Test adding a clay property
###
test clay-class-clay-0001 {Test that a clay statement is recorded in the object of the class} {
  ::TEST::myclass clay get color
} red
test clay-class-clay-0002 {Test that a clay statement is recorded in the object of the class} {
  ::TEST::myclass clay get flavor
} strawberry

###
# Test that objects of the class get the same properties
###
set OBJ [::clay::object new {}]
set OBJ2 [::TEST::myclass new {}]

test clay-object-clay-a-0001 {Test that objects not thee class do not get properties} {
  $OBJ clay get color
} {}
test clay-object-clay-a-0002 {Test that objects not thee class do not get properties} {
  $OBJ clay get flavor
} {}
test clay-object-clay-a-0003 {Test that objects of the class get properties} {
  $OBJ2 clay get color
} red
test clay-object-clay-a-0004 {Test that objects of the class get properties} {
  $OBJ2 clay get flavor
} strawberry

###
# Test modified 2018-10-21
###
test clay-object-clay-a-0005 {Test the clay ancestors function} {
  $OBJ clay ancestors
} {::clay::object}

###
# Test modified 2018-10-21
###
test clay-object-clay-a-0006 {Test the clay ancestors function} {
  $OBJ2 clay ancestors
} {::TEST::myclass ::clay::object}

test clay-object-clay-a-0007 {Test the clay provenance  function} {
  $OBJ2 clay provenance  flavor
} ::TEST::myclass

###
# Test that object local setting override the class
###
test clay-object-clay-a-0008 {Test that object local setting override the class} {
  $OBJ2 clay set color purple
  $OBJ2 clay get color
} purple
test clay-object-clay-a-0009 {Test that object local setting override the class} {
  $OBJ2 clay provenance  color
} self

::clay::define ::TEST::myclasse {
  superclass ::TEST::myclass

  clay color blue
  method do args {
    return "I did $args"
  }

  Ensemble which::color {} {
    return [my clay get color]
  }
  clay set method_ensemble which farbe: {tailcall my Which_color {*}$args}
}

###
# Test clay information is passed town to subclasses
###
test clay-class-clay-0003 {Test that a clay statement is recorded in the object of the class} {
  ::TEST::myclasse clay get color
} blue
test clay-class-clay-0004 {Test that clay statements from the ancestors of this class are not present (we handle them seperately in objects)} {
  ::TEST::myclasse clay get flavor
} {}
test clay-class-clay-0005 {Test that clay statements from the ancestors of this class are found with the FIND method} {
  ::TEST::myclasse clay find flavor
} {strawberry}

###
# Test that properties reach objects
###
set OBJ3 [::TEST::myclasse new {}]
test clay-object-clay-b-0001 {Test that objects of the class get properties} {
  $OBJ3 clay get color
} blue
test clay-object-clay-b-0002 {Test the clay provenance  function} {
  $OBJ3 clay provenance  color
} ::TEST::myclasse
test clay-object-clay-b-0003 {Test that objects of the class get properties} {
  $OBJ3 clay get flavor
} strawberry
test clay-object-clay-b-0004 {Test the clay provenance  function} {
  $OBJ3 clay provenance  flavor
} ::TEST::myclass

###
# Test modified 2018-10-21
###
test clay-object-clay-b-0005 {Test the clay provenance  function} {
  $OBJ3 clay ancestors
} {::TEST::myclasse ::TEST::myclass ::clay::object}

###
# Test defining a standard method
###
test clay-object-method-0001 {Test and standard method} {
  $OBJ3 do this really cool thing
} {I did this really cool thing}

test clay-object-method-0003 {Test an ensemble} {
  $OBJ3 which color
} blue
# Test setting properties
test clay-object-method-0004 {Test an ensemble} {
  $OBJ3 clay set color black
  $OBJ3 which color
} black

# Test setting properties
test clay-object-method-0004 {Test an ensemble alias} {
  $OBJ3 which farbe
} black


###
# Added 2019-06-24
# Test that grabbing a leaf does not pollute the cache
###
::clay::define ::TEST::class_with_deep_tree {
  clay set tree deep has depth 1
  clay set tree shallow has depth 0
}

$OBJ3 clay mixinmap deep ::TEST::class_with_deep_tree

test clay-deep-nested-0001 {Test that a leaf query does not pollute the cache} {
  $OBJ3 clay get tree shallow has depth
} 0
test clay-deep-nested-0001 {Test that a leaf query does not pollute the cache} {
  $OBJ3 clay get tree
} {deep {has {depth 1}} shallow {has {depth 0}}}



###
# Test that if you try to replace a global command you get an error
###
test clay-nspace-0001 {Test that if you try to replace a global command you get an error} -body {
::clay::define open {
  method bar {} { return foo }

}
}  -returnCodes {error} -result "::open does not refer to an object"

::clay::define fubar {
  method bar {} { return foo }
}
test clay-nspace-0002 {Test a non qualified class ends up in the current namespace} {
  info commands ::fubar
} {::fubar}

namespace eval ::cluster {
::clay::define fubar {
  method bar {} { return foo }
}

::clay::define ::clay::pot {
  method bar {} { return foo }
}

}
test clay-nspace-0003 {Test a non qualified class ends up in the current namespace} {
  info commands ::cluster::fubar
} {::cluster::fubar}
test clay-nspace-0003 {Test a fully qualified class ends up in the proper namespace} {
  info commands ::clay::pot
} {::clay::pot}

#set ::clay::trace 3

###
# New test - Added 2019-09-15
# Test that the "method" variable is exposed to a default method
###

::clay::define ::ensembleWithDefault {
  Ensemble foo::bar {} { return A }
  Ensemble foo::baz {} { return B }
  Ensemble foo::bang {} { return C }

  Ensemble foo::default {} { return $method }
}


set OBJ [::ensembleWithDefault new]
test clay-ensemble-default-0001 {Test a normal ensemble method} {
  $OBJ foo bar
} {A}
test clay-ensemble-default-0002 {Test a normal ensemble method} {
  $OBJ foo baz
} {B}
test clay-ensemble-default-0003 {Test a normal ensemble method} {
  $OBJ foo <list>
} [lsort -dictionary {bar baz bang}]

test clay-ensemble-default-0004 {Test a normal ensemble method} {
  $OBJ foo bing
} {bing}
test clay-ensemble-default-0005 {Test a normal ensemble method} {
  $OBJ foo bong
} {bong}
###
# Mixin tests
###

###
# Define a core class
###
::clay::define ::TEST::thing {

  method do args {
    return "I did $args"
  }
}


::clay::define ::TEST::vegetable {

  clay color unknown
  clay flavor unknown

  Ensemble which::flavor {} {
    return [my clay get flavor]
  }
  Ensemble which::color {} {
    return [my clay get color]
  }

}

::clay::define ::TEST::animal {

  clay color unknown
  clay sound unknown

  Ensemble which::sound {} {
    return [my clay get sound]
  }
  Ensemble which::color {} {
    return [my clay get color]
  }
  method sound {} {
    return unknown
  }
}

::clay::define ::TEST::species.cat {
  superclass ::TEST::animal
  clay sound meow
  method sound {} {
    return meow
  }
}

::clay::define ::TEST::coloring.calico {
  clay color calico

}

::clay::define ::TEST::condition.dark {
  Ensemble which::color {} {
    return grey
  }
}

::clay::define ::TEST::mood.happy {
  Ensemble which::sound {} {
    return purr
  }
  method sound {} {
    return purr
  }
}
test clay-object-0001 {Test than an object is created when clay::define is invoked} {
  info commands ::TEST::mood.happy
} ::TEST::mood.happy

set OBJ [::TEST::thing new]
test clay-mixin-a-0001 {Test that prior to a mixin an ensemble doesn't exist} -body {
  $OBJ which color
} -returnCodes error -result {unknown method "which": must be clay, destroy or do}

test clay-mixin-a-0002 {Test and standard method from an ancestor} {
  $OBJ do this really cool thing
} {I did this really cool thing}

$OBJ clay mixinmap species ::TEST::animal
test clay-mixin-b-0001 {Test that an ensemble is created during a mixin} {
  $OBJ which color
} {unknown}

test clay-mixin-b-0002 {Test that an ensemble is created during a mixin} {
  $OBJ which sound
} {unknown}

test clay-mixin-b-0003 {Test that an ensemble is created during a mixin}  -body {$OBJ which flavor} -returnCodes {error}  -result {unknown method which flavor. Valid: color sound}

###
# Test Modified: 2018-10-21
###
test clay-mixin-b-0004 {Test that mixins resolve in the correct order} {
  $OBJ clay ancestors
} {::TEST::animal ::TEST::thing ::clay::object}

###
# Replacing a mixin replaces the behaviors
###
$OBJ clay mixinmap species ::TEST::vegetable
test clay-mixin-c-0001 {Test that an ensemble is created during a mixin} {
  $OBJ which color
} {unknown}
test clay-mixin-c-0002 {Test that an ensemble is created during a mixin}  -body {$OBJ which sound}  -returnCodes {error}  -result {unknown method which sound. Valid: color flavor}
test clay-mixin-c-0003 {Test that an ensemble is created during a mixin} {
  $OBJ which flavor
} {unknown}
###
# Test Modified: 2018-10-21
###
test clay-mixin-c-0004 {Test that mixins resolve in the correct order} {
  $OBJ clay ancestors
} {::TEST::vegetable ::TEST::thing ::clay::object}

###
# Replacing a mixin
$OBJ clay mixinmap species ::TEST::species.cat
test clay-mixin-e-0001 {Test that an ensemble is created during a mixin} {
  $OBJ which color
} {unknown}
test clay-mixin-e-0002a {Test that an ensemble is created during a mixin} {
  $OBJ sound
} {meow}
test clay-mixin-e-0002b {Test that an ensemble is created during a mixin} {
  $OBJ clay get sound
} {meow}
test clay-mixin-e-0002 {Test that an ensemble is created during a mixin} {
  $OBJ which sound
} {meow}
test clay-mixin-e-0003 {Test that an ensemble is created during a mixin}  -body {$OBJ which flavor} -returnCodes {error}  -result {unknown method which flavor. Valid: color sound}
###
# Test Modified: 2018-10-30, 2018-10-21, 2018-10-10
###
test clay-mixin-e-0004 {Test that clay data follows the rules of inheritence and order of mixin} {
  $OBJ clay ancestors
} {::TEST::species.cat ::TEST::animal ::TEST::thing ::clay::object}

$OBJ clay mixinmap coloring ::TEST::coloring.calico
test clay-mixin-f-0001 {Test that an ensemble is created during a mixin} {
  $OBJ which color
} {calico}
test clay-mixin-f-0002 {Test that an ensemble is created during a mixin} {
  $OBJ which sound
} {meow}
test clay-mixin-f-0003 {Test that an ensemble is created during a mixin}  -body {$OBJ which flavor} -returnCodes {error}  -result {unknown method which flavor. Valid: color sound}

###
# Test modified 2018-10-30, 2018-10-21, 2018-10-10
###
test clay-mixin-f-0004 {Test that clay data follows the rules of inheritence and order of mixin} {
  $OBJ clay ancestors
} {::TEST::coloring.calico ::TEST::species.cat ::TEST::animal ::TEST::thing ::clay::object}

test clay-mixin-f-0005 {Test that clay data from a mixin works} {
  $OBJ clay provenance  color
} {::TEST::coloring.calico}

###
# Test variable initialization
###
::clay::define ::TEST::has_var {
  Variable my_variable 10

  method get_my_variable {} {
    my variable my_variable
    return $my_variable
  }
}

set OBJ [::TEST::has_var new]
test clay-class-variable-0001 {Test that the parser injected the right value in the right place for clay to catch it} {
  $OBJ clay get variable/ my_variable
} {10}

# Modified 2018-10-30 (order is different)
test clay-class-variable-0002 {Test that the parser injected the right value in the right place for clay to catch it} {
  $OBJ clay get variable
} {my_variable 10 DestroyEvent 0}

# Modified 2018-10-30 (order is different)
test clay-class-variable-0003 {Test that the parser injected the right value in the right place for clay to catch it} {
  $OBJ clay dget variable
} {. {} my_variable 10 DestroyEvent 0}

test clay-class-variable-0004 {Test that variables declared in the class definition are initialized} {
  $OBJ get_my_variable
} 10

###
# Test array initialization
###
::clay::define ::TEST::has_array {
  Array my_array {timeout 10}

  method get_my_array {field} {
    my variable my_array
    return $my_array($field)
  }
}

set OBJ [::TEST::has_array new]
test clay-class-array-0001 {Test that the parser injected the right value in the right place for clay to catch it} {
  $OBJ clay get array
} {my_array {timeout 10}}

test clay-class-array-0002 {Test that the parser injected the right value in the right place for clay to catch it} {
  $OBJ clay dget array
} {. {} my_array {. {} timeout 10}}

test clay-class-array-0003 {Test that variables declared in the class definition are initialized} {
  $OBJ get_my_array timeout
} 10

::clay::define ::TEST::has_more_array {
  superclass ::TEST::has_array
  Array my_array {color blue}
}
test clay-class-array-0008 {Test that the parser injected the right value in the right place for clay to catch it} {
  ::TEST::has_more_array clay get array
} {my_array {color blue}}

test clay-class-array-0009 {Test that the parser injected the right value in the right place for clay to catch it} {
  ::TEST::has_more_array clay find array
} {my_array {timeout 10 color blue}}

# Modified 2018-10-30 (order is different)
set BOBJ [::TEST::has_more_array new]
test clay-class-array-0004 {Test that the parser injected the right value in the right place for clay to catch it} {
  $BOBJ clay get array
} {my_array {color blue timeout 10}}

# Modified 2018-10-30 (order is different)
test clay-class-array-0005 {Test that the parser injected the right value in the right place for clay to catch it} {
  $BOBJ clay dget array
} {. {} my_array {. {} color blue timeout 10}}

test clay-class-arrau-0006 {Test that variables declared in the class definition are initialized} {
  $BOBJ get_my_array timeout
} 10
test clay-class-arrau-0007 {Test that variables declared in the class definition are initialized} {
  $BOBJ get_my_array color
} blue

::clay::define ::TEST::has_empty_array {
  Array my_array {}

  method my_array_exists {} {
    my variable my_array
    return [info exists my_array]
  }
  method get {field} {
    my variable my_array
    return $my_array($field)
  }
  method set {field value} {
    my variable my_array
    set my_array($field) $value
  }
}

test clay-class-array-0008 {Test that an declaration of an array with no values produces and empty array} {
  set COBJ [::TEST::has_empty_array new]
  $COBJ my_array_exists
} 1

test clay-class-array-0009 {Test that an declaration of an array with no values produces and empty array} {
  $COBJ set test "A random value"
  $COBJ get test
} {A random value}
###
# Test dict initialization
###
::clay::define ::TEST::has_dict {
  Dict my_dict {timeout 10}

  method get_my_dict {args} {
    my variable my_dict
    if {[llength $args]==0} {
      return $my_dict
    }
    return [dict get $my_dict {*}$args]
  }

}

set OBJ [::TEST::has_dict new]
test clay-class-dict-0001 {Test that the parser injected the right value in the right place for clay to catch it} {
  $OBJ clay get dict
} {my_dict {timeout 10}}

test clay-class-dict-0002 {Test that the parser injected the right value in the right place for clay to catch it} {
  $OBJ clay dget dict
} {. {} my_dict {. {} timeout 10}}

test clay-class-dict-0003 {Test that variables declared in the class definition are initialized} {
  $OBJ get_my_dict timeout
} 10

test clay-class-dict-0004 {Test that an empty dict is annotated} {
  $OBJ clay get dict
} {my_dict {timeout 10}}


::clay::define ::TEST::has_more_dict {
  superclass ::TEST::has_dict
  Dict my_dict {color blue}
}
set BOBJ [::TEST::has_more_dict new]

# Modified 2018-10-30
test clay-class-dict-0004 {Test that the parser injected the right value in the right place for clay to catch it} {
  $BOBJ clay get dict
} {my_dict {color blue timeout 10}}

# Modified 2018-10-30
test clay-class-dict-0005 {Test that the parser injected the right value in the right place for clay to catch it} {
  $BOBJ clay dget dict
} {. {} my_dict {. {} color blue timeout 10}}

test clay-class-dict-0006 {Test that variables declared in the class definition are initialized} {
  $BOBJ get_my_dict timeout
} 10

test clay-class-dict-0007 {Test that variables declared in the class definition are initialized} {
  $BOBJ get_my_dict color
} blue

::clay::define ::TEST::has_empty_dict {
  Dict my_empty_dict {}

  method get_my_empty_dict {args} {
    my variable my_empty_dict
    if {[llength $args]==0} {
      return $my_empty_dict
    }
    return [dict get $my_empty_dict {*}$args]
  }
}

set COBJ [::TEST::has_empty_dict new]

test clay-class-dict-0008 {Test that the parser injected the right value in the right place for clay to catch it} {
  $COBJ clay dget dict
} {my_empty_dict {. {}}}

test clay-class-dict-0009 {Test that an empty dict is initialized} {
  $COBJ get_my_empty_dict
} {}

###
# Test object delegation
###
::clay::define ::TEST::organelle {
  method add args {
    set total 0
    foreach item $args {
      set total [expr {$total+$item}]
    }
    return $total
  }
}
::clay::define ::TEST::master {
  constructor {} {
    set mysub [namespace current]::sub
    ::TEST::organelle create $mysub
    my clay delegate sub $mysub
  }
}

set OBJ [::TEST::master new]
###
# Test that delegation is working
###
test clay-delegation-0001 {Test an array driven ensemble} {
  $OBJ <sub> add 5 5
} 10


###
# Test the Ensemble keyword
###
::clay::define ::TEST::with_ensemble {

  Ensemble myensemble {pattern args} {
    set ensemble [self method]
    set emap [my clay ensemble_map $ensemble]
    set mlist [dict keys $emap [string tolower $pattern]]
    if {[llength $mlist] != 1} {
      error "Couldn't figure out what to do with $pattern"
    }
    set method [lindex $mlist 0]
    set argspec [dict get $emap $method argspec]
    set body    [dict get $emap $method body]
    if {$argspec ni {args {}}} {
      ::clay::dynamic_arguments $ensemble $method [list $argspec] {*}$args
    }
    eval $body
  }

  Ensemble myensemble::go args {
    return 1
  }
}

::clay::define ::TEST::with_ensemble.dance {
  Ensemble myensemble::dance args {
    return 1
  }
}
::clay::define ::TEST::with_ensemble.cannot_dance {
  Ensemble myensemble::dance args {
    return 0
  }
}

set OBJA [::clay::object new]
set OBJB [::clay::object new]

$OBJA clay mixinmap  core ::TEST::with_ensemble  friends ::TEST::with_ensemble.dance

$OBJB clay mixinmap  core ::TEST::with_ensemble  friends ::TEST::with_ensemble.cannot_dance

# Test go
test clay-dynamic-ensemble-0001 {Test ensemble with static method} {
  $OBJA myensemble go
} {1}
test clay-dynamic-ensemble-0002 {Test ensemble with static method} {
  $OBJB myensemble go
} {1}
# Test dance
test clay-dynamic-ensemble-0003 {Test ensemble with static method} {
  $OBJA myensemble dance
} {1}
test clay-dynamic-ensemble-0004 {Test ensemble with static method} {
  $OBJB myensemble dance
} {0}


###
# Class method testing
###

clay::class create WidgetClass {
  Class_Method working {} {
    return {Works}
  }

  Class_Method unknown args {
    set tkpath [lindex $args 0]
    if {[string index $tkpath 0] eq "."} {
      set obj [my new $tkpath {*}[lrange $args 1 end]]
      $obj tkalias $tkpath
      return $tkpath
    }
    next {*}$args
  }

  constructor {TkPath args} {
    my variable hull
    set hull $TkPath
    my clay delegate hull $TkPath
  }

  method tkalias tkname {
    set oldname $tkname
    my variable tkalias
    set tkalias $tkname
    set self [self]
    set hullwidget [::info object namespace $self]::tkwidget
    my clay delegate tkwidget $hullwidget
    #rename ::$tkalias $hullwidget
    my clay delegate hullwidget $hullwidget
    #::tool::object_rename [self] ::$tkalias
    rename [self] ::$tkalias
    #my Hull_Bind $tkname
    return $hullwidget
  }
}

test tool-class-method-000 {Test that class methods actually work...} {
  WidgetClass working
} {Works}

test tool-class-method-001 {Test Tk style creator} {
  WidgetClass .foo
  .foo clay delegate hull
} {.foo}

::clay::define WidgetNewClass {
  superclass WidgetClass
}

test tool-class-method-002 {Test Tk style creator inherited by morph} {
  WidgetNewClass .bar
  .bar clay delegate hull
} {.bar}



###
# Test ensemble inheritence
###
clay::define NestedClassA {
  Ensemble do::family {} {
    return NestedClassA
  }
  Ensemble do::something {} {
    return A
  }
  Ensemble do::whop {} {
    return A
  }
}
clay::define NestedClassB {
  superclass NestedClassA
  Ensemble do::family {} {
    set r [next family]
    lappend r NestedClassB
    return $r
  }
  Ensemble do::whop {} {
    return B
  }
}
clay::define NestedClassC {
  superclass NestedClassB

  Ensemble do::somethingelse {} {
    return C
  }
}
clay::define NestedClassD {
  superclass NestedClassB

  Ensemble do::somethingelse {} {
    return D
  }
}

clay::define NestedClassE {
  superclass NestedClassD NestedClassC
}

clay::define NestedClassF {
  superclass NestedClassC NestedClassD
}

NestedClassC create NestedObjectC

###
# These tests no longer work because method ensembles are now dynamically
# generated by object, that are not attached to the class anymore
#
####
#test tool-ensemble-001 {Test that an ensemble can access [next] even if no object of the ancestor class have been instantiated} {
#  NestedObjectC do family
#} {::NestedClassA ::NestedClassB ::NestedClassC}

test tool-ensemble-002 {Test that a later ensemble definition trumps a more primitive one} {
  NestedObjectC do whop
} {B}
test tool-ensemble-003 {Test that an ensemble definitions in an ancestor carry over} {
  NestedObjectC do something
} {A}

NestedClassE create NestedObjectE
NestedClassF create NestedObjectF


test tool-ensemble-004 {Test that ensembles follow the same rules for inheritance as methods} {
  NestedObjectE do somethingelse
} {D}

test tool-ensemble-005 {Test that ensembles follow the same rules for inheritance as methods} {
  NestedObjectF do somethingelse
} {C}

###
# Set of tests to exercise the mixinmap system
###
clay::define MixinMainClass {
  Variable mainvar unchanged

  Ensemble test::which {} {
    my variable mainvar
    return $mainvar
  }

  Ensemble test::main args {
    puts [list this is main $method $args]
  }

}

set mixoutscript {my test untool $class}
set mixinscript {my test tool $class}
clay::define MixinTool {
  Variable toolvar unchanged.mixin
  clay set mixin/ unmap-script $mixoutscript
  clay set mixin/ map-script $mixinscript
  clay set mixin/ name {Generic Tool}

  Ensemble test::untool class {
    my variable toolvar mainvar
    set mainvar {}
    set toolvar {}
  }

  Ensemble test::tool class {
    my variable toolvar mainvar
    set mainvar [$class clay get mixin name]
    set toolvar [$class clay get mixin name]
  }
}

clay::define MixinToolA {
  superclass MixinTool

  clay set mixin/ name {Tool A}
}

clay::define MixinToolB {
  superclass MixinTool

  clay set mixin/ name {Tool B}

  method test_newfunc {} {
    return "B"
  }
}

test tool-mixinspec-001 {Test application of mixin specs} {
  MixinTool clay get mixin map-script
} $mixinscript

test tool-mixinspec-002 {Test application of mixin specs} {
  MixinToolA clay get mixin map-script
} {}

test tool-mixinspec-003 {Test application of mixin specs} {
  MixinToolA clay find mixin map-script
} $mixinscript

test tool-mixinspec-004 {Test application of mixin specs} {
  MixinToolB clay find mixin map-script
} $mixinscript


MixinMainClass create mixintest

test tool-mixinmap-001 {Test object prior to mixins} {
  mixintest test which
} {unchanged}

mixintest clay mixinmap tool MixinToolA
test tool-mixinmap-002 {Test mixin map script ran} {
  mixintest test which
} {Tool A}

mixintest clay mixinmap tool MixinToolB

test tool-mixinmap-003 {Test mixin map script ran} {
  mixintest test which
} {Tool B}

test tool-mixinmap-003 {Test mixin map script ran} {
  mixintest test_newfunc
} {B}

mixintest clay mixinmap tool {}
test tool-mixinmap-004 {Test object prior to mixins} {
  mixintest test which
} {}



clay::define ::clay::object {
  method path {} {
    return [self class]
  }
}


clay::define ::MixinRoot {
  clay set opts core   root
  clay set opts option unset
  clay set opts color  unset

  Ensemble info::root {} {
    return MixinRoot
  }
  Ensemble info::shade {} {
    return avacodo
  }
  Ensemble info::default {} {
    return Undefined
  }

  method did {} {
    return MixinRoot
  }

  method path {} {
    return [list [self class] {*}[next]]
  }
}

clay::define ::MixinOption1 {
  clay set opts option option1

  Ensemble info::option {} {
    return MixinOption1
  }
  Ensemble info::other {} {
    return MixinOption1
  }

  method did {} {
    return MixinOption1
  }

  method path {} {
    return [list [self class] {*}[next]]
  }
}

clay::define ::MixinOption2 {
  superclass ::MixinOption1

  clay set opts option option2

  Ensemble info::option {} {
    return MixinOption2
  }

  method did {} {
    return MixinOption2
  }

  method path {} {
    return [list [self class] {*}[next]]
  }
}


clay::define ::MixinColor1 {
  clay set opts color blue

  Ensemble info::color {} {
    return MixinColor1
  }
  Ensemble info::shade {} {
    return blue
  }

  method did {} {
    return MixinColor1
  }

  method path {} {
    return [list [self class] {*}[next]]
  }
}

clay::define ::MixinColor2 {
  clay set opts color green

  Ensemble info::color {} {
    return MixinColor2
  }
  Ensemble info::shade {} {
    return green
  }

  method did {} {
    return MixinColor2
  }

  method path {} {
    return [list [self class] {*}[next]]
  }
}

set obj [clay::object new]

$obj clay mixinmap root ::MixinRoot


test tool-prototype-0001-0001 {Mixin core} {
  $obj info root
} {MixinRoot}


test tool-prototype-0001-0002 {Mixin core} {
  $obj info option
} {Undefined}


test tool-prototype-0001-0003 {Mixin core} {
  $obj info color
} {Undefined}


test tool-prototype-0001-0004 {Mixin core} {
  $obj info other
} {Undefined}


test tool-prototype-0001-0005 {Mixin core} {
  $obj info shade
} {avacodo}


test tool-prototype-0001-0006 {Mixin core} {
  $obj did
} {MixinRoot}


test tool-prototype-0001-0007 {Mixin core} {
  $obj path
} {::MixinRoot ::clay::object}


test tool-prototype-0001-0008 {Mixin core} {
  $obj clay get opts
} {core root option unset color unset}


test tool-prototype-0001-0009 {Mixin core} {
  $obj clay get opts core
} {root}


test tool-prototype-0001-0010 {Mixin core} {
  $obj clay get opts option
} {unset}


test tool-prototype-0001-0011 {Mixin core} {
  $obj clay get opts color
} {unset}


test tool-prototype-0001-0012 {Mixin core} {
  $obj clay ancestors
} {::MixinRoot ::clay::object}

$obj clay mixinmap option ::MixinOption1

test tool-prototype-0002-0001 {Mixin option1} {
  $obj info root
} {MixinRoot}


test tool-prototype-0002-0002 {Mixin option1} {
  $obj info option
} {MixinOption1}


test tool-prototype-0002-0003 {Mixin option1} {
  $obj info color
} {Undefined}


test tool-prototype-0002-0004 {Mixin option1} {
  $obj info other
} {MixinOption1}


test tool-prototype-0002-0005 {Mixin option1} {
  $obj info shade
} {avacodo}


test tool-prototype-0002-0006 {Mixin option1} {
  $obj did
} {MixinOption1}


test tool-prototype-0002-0007 {Mixin option1} {
  $obj path
} {::MixinOption1 ::MixinRoot ::clay::object}


test tool-prototype-0002-0008 {Mixin option1} {
  $obj clay get opts
} {option option1 core root color unset}


test tool-prototype-0002-0009 {Mixin option1} {
  $obj clay get opts core
} {root}


test tool-prototype-0002-0010 {Mixin option1} {
  $obj clay get opts option
} {option1}


test tool-prototype-0002-0011 {Mixin option1} {
  $obj clay get opts color
} {unset}


test tool-prototype-0002-0012 {Mixin option1} {
  $obj clay ancestors
} {::MixinOption1 ::MixinRoot ::clay::object}


set obj2 [clay::object new]
$obj2 clay mixinmap root ::MixinRoot option ::MixinOption1

$obj clay mixinmap option ::MixinOption1

test tool-prototype-0003-0001 {Mixin option1 - clean object} {
  $obj2 info root
} {MixinRoot}


test tool-prototype-0003-0002 {Mixin option1 - clean object} {
  $obj2 info option
} {MixinOption1}


test tool-prototype-0003-0003 {Mixin option1 - clean object} {
  $obj2 info color
} {Undefined}


test tool-prototype-0003-0004 {Mixin option1 - clean object} {
  $obj2 info other
} {MixinOption1}


test tool-prototype-0003-0005 {Mixin option1 - clean object} {
  $obj2 info shade
} {avacodo}


test tool-prototype-0003-0006 {Mixin option1 - clean object} {
  $obj2 did
} {MixinOption1}


test tool-prototype-0003-0007 {Mixin option1 - clean object} {
  $obj2 path
} {::MixinOption1 ::MixinRoot ::clay::object}


test tool-prototype-0003-0008 {Mixin option1 - clean object} {
  $obj2 clay get opts
} {option option1 core root color unset}


test tool-prototype-0003-0009 {Mixin option1 - clean object} {
  $obj2 clay get opts core
} {root}


test tool-prototype-0003-0010 {Mixin option1 - clean object} {
  $obj2 clay get opts option
} {option1}


test tool-prototype-0003-0011 {Mixin option1 - clean object} {
  $obj2 clay get opts color
} {unset}


test tool-prototype-0003-0012 {Mixin option1 - clean object} {
  $obj2 clay ancestors
} {::MixinOption1 ::MixinRoot ::clay::object}

$obj clay mixinmap option ::MixinOption2

test tool-prototype-0004-0001 {Mixin option2} {
  $obj info root
} {MixinRoot}


test tool-prototype-0004-0002 {Mixin option2} {
  $obj info option
} {MixinOption2}


test tool-prototype-0004-0003 {Mixin option2} {
  $obj info color
} {Undefined}


test tool-prototype-0004-0004 {Mixin option2} {
  $obj info other
} {MixinOption1}


test tool-prototype-0004-0005 {Mixin option2} {
  $obj info shade
} {avacodo}


test tool-prototype-0004-0006 {Mixin option2} {
  $obj did
} {MixinOption2}


test tool-prototype-0004-0007 {Mixin option2} {
  $obj path
} {::MixinOption2 ::MixinOption1 ::MixinRoot ::clay::object}


test tool-prototype-0004-0008 {Mixin option2} {
  $obj clay get opts
} {option option2 core root color unset}


test tool-prototype-0004-0009 {Mixin option2} {
  $obj clay get opts core
} {root}


test tool-prototype-0004-0010 {Mixin option2} {
  $obj clay get opts option
} {option2}


test tool-prototype-0004-0011 {Mixin option2} {
  $obj clay get opts color
} {unset}


test tool-prototype-0004-0012 {Mixin option2} {
  $obj clay ancestors
} {::MixinOption2 ::MixinOption1 ::MixinRoot ::clay::object}

$obj clay mixinmap color MixinColor1

test tool-prototype-0005-0001 {Mixin color1} {
  $obj info root
} {MixinRoot}


test tool-prototype-0005-0002 {Mixin color1} {
  $obj info option
} {MixinOption2}


test tool-prototype-0005-0003 {Mixin color1} {
  $obj info color
} {MixinColor1}


test tool-prototype-0005-0004 {Mixin color1} {
  $obj info other
} {MixinOption1}


test tool-prototype-0005-0005 {Mixin color1} {
  $obj info shade
} {blue}


test tool-prototype-0005-0006 {Mixin color1} {
  $obj did
} {MixinColor1}


test tool-prototype-0005-0007 {Mixin color1} {
  $obj path
} {::MixinColor1 ::MixinOption2 ::MixinOption1 ::MixinRoot ::clay::object}


test tool-prototype-0005-0008 {Mixin color1} {
  $obj clay get opts
} {color blue option option2 core root}


test tool-prototype-0005-0009 {Mixin color1} {
  $obj clay get opts core
} {root}


test tool-prototype-0005-0010 {Mixin color1} {
  $obj clay get opts option
} {option2}


test tool-prototype-0005-0011 {Mixin color1} {
  $obj clay get opts color
} {blue}


test tool-prototype-0005-0012 {Mixin color1} {
  $obj clay ancestors
} {::MixinColor1 ::MixinOption2 ::MixinOption1 ::MixinRoot ::clay::object}

$obj clay mixinmap color MixinColor2

test tool-prototype-0006-0001 {Mixin color2} {
  $obj info root
} {MixinRoot}


test tool-prototype-0006-0002 {Mixin color2} {
  $obj info option
} {MixinOption2}


test tool-prototype-0006-0003 {Mixin color2} {
  $obj info color
} {MixinColor2}


test tool-prototype-0006-0004 {Mixin color2} {
  $obj info other
} {MixinOption1}


test tool-prototype-0006-0005 {Mixin color2} {
  $obj info shade
} {green}


test tool-prototype-0006-0006 {Mixin color2} {
  $obj clay get opts
} {color green option option2 core root}


test tool-prototype-0006-0007 {Mixin color2} {
  $obj clay get opts core
} {root}


test tool-prototype-0006-0008 {Mixin color2} {
  $obj clay get opts option
} {option2}


test tool-prototype-0006-0009 {Mixin color2} {
  $obj clay get opts color
} {green}


test tool-prototype-0006-0010 {Mixin color2} {
  $obj clay ancestors
} {::MixinColor2 ::MixinOption2 ::MixinOption1 ::MixinRoot ::clay::object}

$obj clay mixinmap option MixinOption1

test tool-prototype-0007-0001 {Mixin color2 + Option1} {
  $obj info root
} {MixinRoot}


test tool-prototype-0007-0002 {Mixin color2 + Option1} {
  $obj info option
} {MixinOption1}


test tool-prototype-0007-0003 {Mixin color2 + Option1} {
  $obj info color
} {MixinColor2}


test tool-prototype-0007-0004 {Mixin color2 + Option1} {
  $obj info other
} {MixinOption1}


test tool-prototype-0007-0005 {Mixin color2 + Option1} {
  $obj info shade
} {green}


test tool-prototype-0007-0006 {Mixin color2 + Option1} {
  $obj clay get opts
} {color green option option1 core root}


test tool-prototype-0007-0007 {Mixin color2 + Option1} {
  $obj clay get opts core
} {root}


test tool-prototype-0007-0008 {Mixin color2 + Option1} {
  $obj clay get opts option
} {option1}


test tool-prototype-0007-0009 {Mixin color2 + Option1} {
  $obj clay get opts color
} {green}


test tool-prototype-0007-0010 {Mixin color2 + Option1} {
  $obj clay ancestors
} {::MixinColor2 ::MixinOption1 ::MixinRoot ::clay::object}

$obj clay mixinmap option {}

test tool-prototype-0008-0001 {Mixin color2 + no option} {
  $obj info root
} {MixinRoot}


test tool-prototype-0008-0002 {Mixin color2 + no option} {
  $obj info option
} {Undefined}


test tool-prototype-0008-0003 {Mixin color2 + no option} {
  $obj info color
} {MixinColor2}


test tool-prototype-0008-0004 {Mixin color2 + no option} {
  $obj info other
} {Undefined}


test tool-prototype-0008-0005 {Mixin color2 + no option} {
  $obj info shade
} {green}


test tool-prototype-0008-0006 {Mixin color2 + no option} {
  $obj clay get opts
} {color green core root option unset}


test tool-prototype-0008-0007 {Mixin color2 + no option} {
  $obj clay get opts core
} {root}


test tool-prototype-0008-0008 {Mixin color2 + no option} {
  $obj clay get opts option
} {unset}


test tool-prototype-0008-0009 {Mixin color2 + no option} {
  $obj clay get opts color
} {green}


test tool-prototype-0008-0010 {Mixin color2 + no option} {
  $obj clay ancestors
} {::MixinColor2 ::MixinRoot ::clay::object}

$obj clay mixinmap color {}

test tool-prototype-0009-0001 {Mixin core (return to normal)} {
  $obj info root
} {MixinRoot}


test tool-prototype-0009-0002 {Mixin core (return to normal)} {
  $obj info option
} {Undefined}


test tool-prototype-0009-0003 {Mixin core (return to normal)} {
  $obj info color
} {Undefined}


test tool-prototype-0009-0004 {Mixin core (return to normal)} {
  $obj info other
} {Undefined}


test tool-prototype-0009-0005 {Mixin core (return to normal)} {
  $obj info shade
} {avacodo}


test tool-prototype-0009-0006 {Mixin core (return to normal)} {
  $obj clay get opts
} {core root option unset color unset}


test tool-prototype-0009-0007 {Mixin core (return to normal)} {
  $obj clay get opts core
} {root}


test tool-prototype-0009-0008 {Mixin core (return to normal)} {
  $obj clay get opts option
} {unset}


test tool-prototype-0009-0009 {Mixin core (return to normal)} {
  $obj clay get opts color
} {unset}


test tool-prototype-0009-0010 {Mixin core (return to normal)} {
  $obj clay ancestors
} {::MixinRoot ::clay::object}


###
# Tip479 Tests
###
clay::define tip479class {

  Method newitem dictargs {
    id {type: number}
    color {default: green}
    shape {options: {round square}}
    flavor {default: grape}
  } {
    my variable items
    foreach {f v} $args {
      dict set items $id $f $v
    }
    if {"color" ni [dict keys $args]} {
      dict set items $id color $color
    }
    return [dict get $items $id]
  }

  method itemget {id field} {
    my variable items
    return [dict get $id $field]
  }
}

set obj [tip479class new]
test tip479-001 {Test that a later ensemble definition trumps a more primitive one} {
  $obj newitem id 1 color orange shape round
} {id 1 color orange shape round}

# Fail because we left off a mandatory argument
test tip479-002 {Test that a later ensemble definition trumps a more primitive one} -body {
  $obj newitem id 2
} -result {shape is required} -returnCodes error

###
# Leave off a value that has a default
# note: Method had special handling for color, but not flavor
###
test tip479-003 {Test that a later ensemble definition trumps a more primitive one} {
  $obj newitem id 3 shape round
} {id 3 shape round color green}

###
# Add extra arguments
###
test tip479-004 {Test that a later ensemble definition trumps a more primitive one} {
  $obj newitem id 4 shape round trim leather
} {id 4 shape round trim leather color green}

clay::define tip479classE {

  Ensemble item::new dictargs {
    id {type: number}
    color {default: green}
    shape {options: {round square}}
    flavor {default: grape}
  } {
    my variable items
    foreach {f v} $args {
      dict set items $id $f $v
    }
    if {"color" ni [dict keys $args]} {
      dict set items $id color $color
    }
    return [dict get $items $id]
  }

  Ensemble item::get {id field} {
    my variable items
    return [dict get $id $field]
  }
}


set obj [tip479classE new]
test tip479-001 {Test that a later ensemble definition trumps a more primitive one} {
  $obj item new id 1 color orange shape round
} {id 1 color orange shape round}

# Fail because we left off a mandatory argument
test tip479-002 {Test that a later ensemble definition trumps a more primitive one} -body {
  $obj item new id 2
} -result {shape is required} -returnCodes error

###
# Leave off a value that has a default
# note: Method had special handling for color, but not flavor
###
test tip479-003 {Test that a later ensemble definition trumps a more primitive one} {
  $obj item new id 3 shape round
} {id 3 shape round color green}

###
# Add extra arguments
###
test tip479-004 {Test that a later ensemble definition trumps a more primitive one} {
  $obj item new id 4 shape round trim leather
} {id 4 shape round trim leather color green}



testsuiteCleanup
return
# Local variables:
# mode: tcl
# indent-tabs-mode: nil
# End: