Tcl Library Source Code

set srcdir [file dirname [file normalize [file join [pwd] [info script]]]]
set moddir [file dirname $srcdir]

set version 0.8
set module clay
set filename clay
if {[file exists [file join $moddir .. .. scripts practcl.tcl]]} {
  source [file join $moddir .. .. scripts practcl.tcl]
} elseif {[file exists [file join $moddir .. practcl build doctool.tcl]]} {
  source [file join $moddir .. practcl build doctool.tcl]
} else {
  package require practcl 0.14
}
::practcl::doctool create AutoDoc

set fout [open [file join $moddir ${filename}.tcl] w]
dict set modmap %module% $module
dict set modmap %version% $version
dict set modmap %license% BSD
dict set modmap %filename% $filename

set authors {{Sean Woods} {<[email protected]>}}

puts $fout [string map $modmap {###
# %filename%.tcl
#
# Copyright (c) 2018 Sean Woods
#
# BSD License
###
# @@ Meta Begin
# Package %module% %version%
# Meta platform     tcl
# Meta summary      A minimalist framework for complex TclOO development
# Meta description  This package introduces the method "clay" to both oo::object
# Meta description  and oo::class which facilitate complex interactions between objects
# Meta description  and their ancestor and mixed in classes.
# Meta category     TclOO
# Meta subject      framework
# Meta require      {Tcl 8.6}}]
foreach {name email} $authors {
  puts $fout   "# Meta author       $name"
}
puts $fout [string map $modmap {# Meta license      %license%
# @@ Meta End
}]

puts $fout [string map $modmap {###
# Amalgamated package for %module%
# Do not edit directly, tweak the source in build/ and rerun
# build.tcl
###
package provide %module% %version%
namespace eval ::%module% {}
}]


# Track what files we have included so far
set loaded {}
lappend loaded build.tcl test.tcl

foreach file {
  procs.tcl
  core.tcl uuid.tcl
  dict.tcl list.tcl dictargs.tcl
  dialect.tcl
  metaclass.tcl
  ensemble.tcl
  class.tcl
  object.tcl
} {
  lappend loaded $file
  set content [::practcl::cat [file join $srcdir {*}$file]]
  AutoDoc scan_text $content
  puts $fout "###\n# START: [file tail $file]\n###"
  puts $fout [::practcl::docstrip $content]
  puts $fout "###\n# END: [file tail $file]\n###"
}
# These files can be loaded in any order
foreach file [lsort -dictionary [glob [file join $srcdir *.tcl]]] {
  if {[file tail $file] in $loaded} continue
  lappend loaded $file
  set content [::practcl::cat [file join $srcdir {*}$file]]
  AutoDoc scan_text $content
  puts $fout "###\n# START: [file tail $file]\n###"
  puts $fout [::practcl::docstrip $content]
  puts $fout "###\n# END: [file tail $file]\n###"
}

# Provide some cleanup and our final package provide
puts $fout [string map $modmap {
namespace eval ::%module% {
  namespace export *
}
}]
close $fout

###
# Build our pkgIndex.tcl file
###
set fout [open [file join $moddir pkgIndex.tcl] w]
puts $fout [string map $modmap {# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if {![package vsatisfies [package provide Tcl] 8.6]} {return}
}]
puts $fout [string map $modmap {
package ifneeded %module% %version% [list source [file join $dir %module%.tcl]]
}]

close $fout

###
# Generate the test script
###
namespace eval ::clay {}
source [file join $srcdir procs.tcl]
set fout [open [file join $moddir $filename.test] w]
puts $fout {
namespace eval ::oo::dialect {}
set ::oo::dialect::has(tip470) 0
}
puts $fout [source [file join $srcdir test.tcl]]
puts $fout {

if {![package vsatisfies [package provide Tcl] 8.7]} {return}
puts "Repeating tests with 8.7 features"
namespace eval ::oo::dialect {}
set ::oo::dialect::has(tip470) 1
}
puts $fout [source [file join $srcdir test.tcl]]
close $fout
set manout [open [file join $moddir $filename.man] w]
puts $manout [AutoDoc manpage map $modmap \
  header [::practcl::cat [file join $srcdir manual.txt]] \
  authors $authors \
  footer [::practcl::cat [file join $srcdir footer.txt]] \
]
close $manout

::oo::define ::clay::class {

  ###
  # description:
  # The [method clay] method allows a class object access
  # to a combination of its own clay data as
  # well as to that of its ancestors
  # ensemble:
  # ancestors {
  #   argspec {}
  #   description {Return this class and all ancestors in search order.}
  # }
  # dump {
  #   argspec {}
  #   description {Return a complete dump of this object's clay data, but only this object's clay data.}
  # }
  # find {
  #   argspec {path {mandatory 1 positional 1 repeating 1}}
  #   description {
  #     Pull a chunk of data from the clay system. If the last element of [emph path] is a branch,
  #     returns a recursive merge of all data from this object and it's constituent classes of the data in that branch.
  #     If the last element is a leaf, search this object for a matching leaf, or search all  constituent classes for a matching
  #     leaf and return the first value found.
  #     If no value is found, returns an empty string.
  #     If a branch is returned the topmost . entry is omitted.
  #   }
  # }
  # get {
  #   argspec {path {mandatory 1 positional 1 repeating 1}}
  #   description {
  #     Pull a chunk of data from the class's clay system.
  #     If no value is found, returns an empty string.
  #     If a branch is returned the topmost . entry is omitted.
  #   }
  # }
  # GET {
  #   argspec {path {mandatory 1 positional 1 repeating 1}}
  #   description {
  #     Pull a chunk of data from the class's clay system.
  #     If no value is found, returns an empty string.
  #   }
  #}
  # merge {
  #   argspec {dict {mandatory 1 positional 1 repeating 1}}
  #   description {Recursively merge the dictionaries given into the object's local clay storage.}
  # }
  # replace {
  #   argspec {dictionary {mandatory 1 positional 1}}
  #   description {Replace the contents of the internal clay storage with the dictionary given.}
  # }
  # search {
  #   argspec {path {mandatory 1 positional 1 repeating 1}}
  #   description {Return the first matching value for the path in either this class's clay data or one of its ancestors}
  # }
  # set {
  #   argspec {path {mandatory 1 positional 1 repeating 1} value {mandatory 1 postional 1}}
  #   description {Merge the conents of [const value] with the object's clay storage at [const path].}
  # }
  ###
  method clay {submethod args} {
    my variable clay
    if {![info exists clay]} {
      set clay {}
    }
    switch $submethod {
      ancestors {
        tailcall ::clay::ancestors [self]
      }
      branch {
        set path [::clay::tree::storage $args]
        if {![dict exists $clay {*}$path .]} {
          dict set clay {*}$path . {}
        }
      }
      exists {
        if {![info exists clay]} {
          return 0
        }
        set path [::clay::tree::storage $args]
        if {[dict exists $clay {*}$path]} {
          return 1
        }
        if {[dict exists $clay {*}[lrange $path 0 end-1] [lindex $path end]:]} {
          return 1
        }
        return 0
      }
      dump {
        return $clay
      }
      dget {
         if {![info exists clay]} {
          return {}
        }
        set path [::clay::tree::storage $args]
        if {[dict exists $clay {*}$path]} {
          return [dict get $clay {*}$path]
        }
        if {[dict exists $clay {*}[lrange $path 0 end-1] [lindex $path end]:]} {
          return [dict get $clay {*}[lrange $path 0 end-1] [lindex $path end]:]
        }
        return {}
      }
      is_branch {
        set path [::clay::tree::storage $args]
        return [dict exists $clay {*}$path .]
      }
      getnull -
      get {
        if {![info exists clay]} {
          return {}
        }
        set path [::clay::tree::storage $args]
        if {[llength $path]==0} {
          return $clay
        }
        if {[dict exists $clay {*}$path .]} {
          return [::clay::tree::sanitize [dict get $clay {*}$path]]
        }
        if {[dict exists $clay {*}$path]} {
          return [dict get $clay {*}$path]
        }
        if {[dict exists $clay {*}[lrange $path 0 end-1] [lindex $path end]:]} {
          return [dict get $clay {*}[lrange $path 0 end-1] [lindex $path end]:]
        }
        return {}
      }
      find {
        set path [::clay::tree::storage $args]
        if {![info exists clay]} {
          set clay {}
        }
        set clayorder [::clay::ancestors [self]]
        set found 0
        if {[llength $path]==0} {
          set result [dict create . {}]
          foreach class $clayorder {
            ::clay::tree::dictmerge result [$class clay dump]
          }
          return [::clay::tree::sanitize $result]
        }
        foreach class $clayorder {
          if {[$class clay exists {*}$path .]} {
            # Found a branch break
            set found 1
            break
          }
          if {[$class clay exists {*}$path]} {
            # Found a leaf. Return that value immediately
            return [$class clay get {*}$path]
          }
          if {[dict exists $clay {*}[lrange $path 0 end-1] [lindex $path end]:]} {
            return [dict get $clay {*}[lrange $path 0 end-1] [lindex $path end]:]
          }
        }
        if {!$found} {
          return {}
        }
        set result {}
        # Leaf searches return one data field at a time
        # Search in our local dict
        # Search in the in our list of classes for an answer
        foreach class [lreverse $clayorder] {
          ::clay::tree::dictmerge result [$class clay dget {*}$path]
        }
        return [::clay::tree::sanitize $result]
      }
      merge {
        foreach arg $args {
          ::clay::tree::dictmerge clay {*}$arg
        }
      }
      noop {
        # Do nothing. Used as a sign of clay savviness
      }
      search {
        foreach aclass [::clay::ancestors [self]] {
          if {[$aclass clay exists {*}$args]} {
            return [$aclass clay get {*}$args]
          }
        }
      }
      set {
        ::clay::tree::dictset clay {*}$args
      }
      unset {
        dict unset clay {*}$args
      }
      default {
        dict $submethod clay {*}$args
      }
    }
  }
}

package require Tcl 8.6 ;# try in pipeline.tcl. Possibly other things.
if {[info commands irmmd5] eq {}} {
  if {[catch {package require odielibc}]} {
    package require md5 2
  }
}
::namespace eval ::clay {}
::namespace eval ::clay::classes {}
::namespace eval ::clay::define {}
::namespace eval ::clay::tree {}
::namespace eval ::clay::dict {}
::namespace eval ::clay::list {}
::namespace eval ::clay::uuid {}

if {![info exists ::clay::idle_destroy]} {
  set ::clay::idle_destroy {}
}

###
# Adapted from Tcllib's oo::dialect
#
# Copyright (c) 2015-2018 Sean Woods
# Copyright (c) 2015 Donald K Fellows
#
# BSD License
###
# @@ Meta Begin
# Package clay::dialect 0.4
# Meta platform     tcl
# Meta summary      A utility for defining a domain specific language for TclOO systems
# Meta description  This package allows developers to generate
# Meta description  domain specific languages to describe TclOO
# Meta description  classes and objects.
# Meta category     TclOO
# Meta subject      oodialect
# Meta require      {Tcl 8.6}
# Meta author       Sean Woods
# Meta author       Donald K. Fellows
# Meta license      BSD
# @@ Meta End
namespace eval ::clay::dialect {
  namespace export create
  # Allow test rigs to overwrite the flags before invoking this script
  foreach {flag test} {
    tip470 {package vsatisfies [package provide Tcl] 8.7}
  } {
    if {![info exists ::clay::dialect::has($flag)]} {
      set ::clay::dialect::has($flag) [eval $test]
    }
  }
}


proc ::clay::dialect::Push {class} {
  ::variable class_stack
  lappend class_stack $class
}
proc ::clay::dialect::Peek {} {
  ::variable class_stack
  return [lindex $class_stack end]
}
proc ::clay::dialect::Pop {} {
  ::variable class_stack
  set class_stack [lrange $class_stack 0 end-1]
}

if {$::clay::dialect::has(tip470)} {
proc ::clay::dialect::current_class {} {
  return [uplevel 1 self]
}
} else {
proc ::clay::dialect::current_class {} {
  tailcall Peek
}
}

###
# This proc will generate a namespace, a "mother of all classes", and a
# rudimentary set of policies for this dialect.
###
proc ::clay::dialect::create {name {parent ""}} {
  variable has
  set NSPACE [NSNormalize [uplevel 1 {namespace current}] $name]
  ::namespace eval $NSPACE {::namespace eval define {}}
  ###
  # Build the "define" namespace
  ###

  if {$parent eq ""} {
    ###
    # With no "parent" language, begin with all of the keywords in
    # oo::define
    ###
    foreach command [info commands ::oo::define::*] {
      set procname [namespace tail $command]
      interp alias {} ${NSPACE}::define::$procname {} \
        ::clay::dialect::DefineThunk $procname
    }
    # Create an empty dynamic_methods proc
    proc ${NSPACE}::dynamic_methods {class} {}
    namespace eval $NSPACE {
      ::namespace export dynamic_methods
      ::namespace eval define {::namespace export *}
    }
    set ANCESTORS {}
  } else {
    ###
    # If we have a parent language, that language already has the
    # [oo::define] keywords as well as additional keywords and behaviors.
    # We should begin with that
    ###
    set pnspace [NSNormalize [uplevel 1 {namespace current}] $parent]
    apply [list parent {
      ::namespace export dynamic_methods
      ::namespace import -force ${parent}::dynamic_methods
    } $NSPACE] $pnspace

    apply [list parent {
      ::namespace import -force ${parent}::define::*
      ::namespace export *
    } ${NSPACE}::define] $pnspace
      set ANCESTORS [list ${pnspace}::object]
  }
  ###
  # Build our dialect template functions
  ###
  proc ${NSPACE}::define {oclass args} [string map [list %NSPACE% $NSPACE] {
  ###
  # To facilitate library reloading, allow
  # a dialect to create a class from DEFINE
  ###
  set class [::clay::dialect::NSNormalize [uplevel 1 {namespace current}] $oclass]
    if {[info commands $class] eq {}} {
      %NSPACE%::class create $class {*}${args}
    } else {
      ::clay::dialect::Define %NSPACE% $class {*}${args}
    }
}]
  interp alias {} ${NSPACE}::define::current_class {} \
    ::clay::dialect::current_class
  interp alias {} ${NSPACE}::define::aliases {} \
    ::clay::dialect::Aliases $NSPACE
  interp alias {} ${NSPACE}::define::superclass {} \
    ::clay::dialect::SuperClass $NSPACE

  if {[info command ${NSPACE}::class] ne {}} {
    ::rename ${NSPACE}::class {}
  }
  ###
  # Build the metaclass for our language
  ###
  ::oo::class create ${NSPACE}::class {
    superclass ::clay::dialect::MotherOfAllMetaClasses
  }
  # Wire up the create method to add in the extra argument we need; the
  # MotherOfAllMetaClasses will know what to do with it.
  ::oo::objdefine ${NSPACE}::class \
    method create {name {definitionScript ""}} \
      "next \$name [list ${NSPACE}::define] \$definitionScript"

  ###
  # Build the mother of all classes. Note that $ANCESTORS is already
  # guaranteed to be a list in canonical form.
  ###
  uplevel #0 [string map [list %NSPACE% [list $NSPACE] %name% [list $name] %ANCESTORS% $ANCESTORS] {
    %NSPACE%::class create %NSPACE%::object {
     superclass %ANCESTORS%
      # Put MOACish stuff in here
    }
  }]
  if { "${NSPACE}::class" ni $::clay::dialect::core_classes } {
    lappend ::clay::dialect::core_classes "${NSPACE}::class"
  }
  if { "${NSPACE}::object" ni $::clay::dialect::core_classes } {
    lappend ::clay::dialect::core_classes "${NSPACE}::object"
  }
}

# Support commands; not intended to be called directly.
proc ::clay::dialect::NSNormalize {namespace qualname} {
  if {![string match ::* $qualname]} {
    set qualname ${namespace}::$qualname
  }
  regsub -all {::+} $qualname "::"
}

proc ::clay::dialect::DefineThunk {target args} {
  tailcall ::oo::define [Peek] $target {*}$args
}

proc ::clay::dialect::Canonical {namespace NSpace class} {
  namespace upvar $namespace cname cname
  #if {[string match ::* $class]} {
  #  return $class
  #}
  if {[info exists cname($class)]} {
    return $cname($class)
  }
  if {[info exists ::clay::dialect::cname($class)]} {
    return $::clay::dialect::cname($class)
  }
  if {[info exists ::clay::dialect::cname(${NSpace}::${class})]} {
    return $::clay::dialect::cname(${NSpace}::${class})
  }
  foreach item [list "${NSpace}::$class" "::$class"] {
    if {[info commands $item] ne {}} {
      return $item
    }
  }
  return ${NSpace}::$class
}

###
# Implementation of the languages' define command
###
proc ::clay::dialect::Define {namespace class args} {
  Push $class
  try {
  	if {[llength $args]==1} {
      namespace eval ${namespace}::define [lindex $args 0]
    } else {
      ${namespace}::define::[lindex $args 0] {*}[lrange $args 1 end]
    }
  	${namespace}::dynamic_methods $class
  } finally {
    Pop
  }
}

###
# Implementation of how we specify the other names that this class will answer
# to
###

proc ::clay::dialect::Aliases {namespace args} {
  set class [Peek]
  namespace upvar $namespace cname cname
  set NSpace [join [lrange [split $class ::] 1 end-2] ::]
  set cname($class) $class
  foreach name $args {
    set cname($name) $class
    #set alias $name
    set alias [NSNormalize $NSpace $name]
    # Add a local metaclass reference
    if {![info exists ::clay::dialect::cname($alias)]} {
      lappend ::clay::dialect::aliases($class) $alias
      ##
      # Add a global reference, first come, first served
      ##
      set ::clay::dialect::cname($alias) $class
    }
  }
}

###
# Implementation of a superclass keyword which will enforce the inheritance of
# our language's mother of all classes
###

proc ::clay::dialect::SuperClass {namespace args} {
  set class [Peek]
  namespace upvar $namespace class_info class_info
  dict set class_info($class) superclass 1
  set ::clay::dialect::cname($class) $class
  set NSpace [join [lrange [split $class ::] 1 end-2] ::]
  set unique {}
  foreach item $args {
    set Item [Canonical $namespace $NSpace $item]
    dict set unique $Item $item
  }
  set root ${namespace}::object
  if {$class ne $root} {
    dict set unique $root $root
  }
  tailcall ::oo::define $class superclass {*}[dict keys $unique]
}

###
# Implementation of the common portions of the the metaclass for our
# languages.
###
if {[info command ::clay::dialect::MotherOfAllMetaClasses] eq {}} {
::oo::class create ::clay::dialect::MotherOfAllMetaClasses {
  superclass ::oo::class
  constructor {define definitionScript} {
    $define [self] {
      superclass
    }
    $define [self] $definitionScript
  }
  method aliases {} {
    if {[info exists ::clay::dialect::aliases([self])]} {
      return $::clay::dialect::aliases([self])
    }
  }
}
}

namespace eval ::clay::dialect {
  variable core_classes {::oo::class ::oo::object}
}

###
# If the path (given by the list of elements) exists, return that value.
# Otherwise return an empty string. Designed to replace [example {
# if {[dict exists $dictionary {*}$args]} {
#   return [dict get $dictionary {*}$args]
# } else {
#   return {}
# }
# }]
# example:
# set value [dict getnull $arglist $option]
# arglist:
# dictionary {mandatory 1 positional 1}
# element {mandatory 0 positional 1 repeating 1}
###
::clay::PROC ::tcl::dict::getnull {dictionary args} {
  if {[exists $dictionary {*}$args]} {
    get $dictionary {*}$args
  }
} {
  namespace ensemble configure dict -map [dict replace\
      [namespace ensemble configure dict -map] getnull ::tcl::dict::getnull]
}


###
# Test if value is a dict.
# [para]
# This command is added to the [fun dict] ensemble as [fun {dict is_dict}]
###
::clay::PROC ::tcl::dict::is_dict { d } {
  # is it a dict, or can it be treated like one?
  if {[catch {dict size $d} err]} {
    #::set ::errorInfo {}
    return 0
  }
  return 1
} {
  namespace ensemble configure dict -map [dict replace\
      [namespace ensemble configure dict -map] is_dict ::tcl::dict::is_dict]
}

###
# A routine to recursively dig through dicts and merge
# adapted from http://stevehavelka.com/tcl-dict-operation-nested-merge/
###
::clay::PROC ::tcl::dict::rmerge {args} {
  ::set result [dict create . {}]
  # Merge b into a, and handle nested dicts appropriately
  ::foreach b $args {
    for { k v } $b {
      ::set field [string trim $k :/]
      if {![::clay::tree::is_branch $b $k]} {
        # Element names that end in ":" are assumed to be literals
        set result $k $v
      } elseif { [exists $result $k] } {
        # key exists in a and b?  let's see if both values are dicts
        # both are dicts, so merge the dicts
        if { [is_dict [get $result $k]] && [is_dict $v] } {
          set result $k [rmerge [get $result $k] $v]
        } else {
          set result $k $v
        }
      } else {
        set result $k $v
      }
    }
  }
  return $result
} {
  namespace ensemble configure dict -map [dict replace\
      [namespace ensemble configure dict -map] rmerge ::tcl::dict::rmerge]
}

###
# Return true if the element [variable path] with the value [variable dict]
# is a dict. [variable path] is given as a list to descend into sub-dicts of
# the current dict.
# The rules are as follows:
# [list_begin enumerated]
# [enum]
# If the last character of the last element of [variable path] is a colon (:)
# return false
# [enum]
# If the last character of the last element of [variable path] is a slash (/)
# return true
# [enum]
# If a sub-element if [variable path] named [const .info] is present return true
# [list_end]
# [para]
# [para]
# This command is added to the [fun dict] ensemble as [fun {clay::tree::is_branch}]
# example:
# > set mydict {sub/ {sub/ {field {A block of text}}}
# > clay::tree::is_branch $mydict sub/
# 1
# > clay::tree::is_branch $mydict {sub/ sub/}
# 1
# > clay::tree::is_branch $mydict {sub/ sub/ field}
# 0
###
::clay::PROC ::clay::tree::is_branch { dict path } {
  set field [lindex $path end]
  if {[string index $field end] eq ":"} {
    return 0
  }
  if {[string index $field 0] eq "."} {
    return 0
  }
  if {[string index $field end] eq "/"} {
    return 1
  }
  return [dict exists $dict {*}$path .]
}

###
# Output a dictionary as an indented stream of
# data suitable for output to the screen. The system uses
# the rules for [fun {clay::tree::is_branch}] to determine if
# an value in a dictionary is a leaf or a branch.
# example:
# > set mydict {sub/ {sub/ {field {A block of text}}}
# > clay::tree::print $mydict
# sub/ {
#   sub/ {
#     field {A block of text}
#   }
# }
###
::clay::PROC ::clay::tree::print {dict} {
  ::set result {}
  ::set level -1
  ::clay::tree::_dictputb $level result $dict
  return $result
}

###
# Helper function for ::clay::tree::print
# Formats the string representation for a dictionary element within
# a human readable stream of lines, and determines if it needs to call itself
# with further indentation to express a sub-branch
###
::clay::PROC ::clay::tree::_dictputb {level varname dict} {
  upvar 1 $varname result
  incr level
  dict for {field value} $dict {
    if {$field eq "."} continue
    if {[clay::tree::is_branch $dict $field]} {
      putb result "[string repeat "  " $level]$field \{"
      _dictputb $level result $value
      putb result "[string repeat "  " $level]\}"
    } else {
      putb result "[string repeat "  " $level][list $field $value]"
    }
  }
}

###
# Output a dictionary removing any . entries added by [fun {clay::tree::merge}]
###
proc ::clay::tree::sanitize {dict} {
  ::set result {}
  ::set level -1
  ::clay::tree::_sanitizeb {} result $dict
  return $result
}

###
# Helper function for ::clay::tree::sanitize
# Formats the string representation for a dictionary element within
# a human readable stream of lines, and determines if it needs to call itself
# with further indentation to express a sub-branch
###
proc ::clay::tree::_sanitizeb {path varname dict} {
  upvar 1 $varname result
  dict for {field value} $dict {
    if {$field eq "."} continue
    if {[clay::tree::is_branch $dict $field]} {
      _sanitizeb [list {*}$path $field] result $value
    } else {
      dict set result {*}$path $field $value
    }
  }
}

###
# Return the path as a storage path for clay::tree
# with all branch terminators removed.
# This command will also break arguments up if they
# contain /.
# example:
# > clay::tree::storage {foo bar baz bang}
# foo bar baz bang
# > clay::tree::storage {foo bar baz bang/}
# foo bar baz bang
# > clay::tree::storage {foo bar baz bang:}
# foo bar baz bang:
# > clay::tree::storage {foo/bar/baz bang:}
# foo bar baz bang:
# > clay::tree::storage {foo/bar/baz/bang}
# foo bar baz bang
###
proc ::clay::tree::storage {rawpath} {
  set isleafvar 0
  set path {}
  set tail [string index $rawpath end]
  foreach element $rawpath {
    set items [split [string trim $element /] /]
    foreach item $items {
      if {$item eq {}} continue
      lappend path $item
    }
  }
  return $path
}

###
# Set an element with a recursive dictionary,
# marking all branches on the way down to the
# final element.
# If the value does not exists in the nested dictionary
# it is added as a leaf. If the value already exists as a branch
# the value given is merged if the value is a valid dict. If the
# incoming value is not a valid dict, the value overrides the value
# stored, and the value is treated as a leaf from then on.
# example:
# > set r {}
# > ::clay::tree::dictset r option color default Green
# . {} option {. {} color {. {} default Green}}
# > ::clay::tree::dictset r option {Something not dictlike}
# . {} option {Something not dictlike}
# # Note that if the value is not a dict, and you try to force it to be
# # an error with be thrown on the merge
# > ::clay::tree::dictset r option color default Blue
# missing value to go with key
###
proc ::clay::tree::dictset {varname args} {
  upvar 1 $varname result
  if {[llength $args] < 2} {
    error "Usage: ?path...? path value"
  } elseif {[llength $args]==2} {
    set rawpath [lindex $args 0]
  } else {
    set rawpath  [lrange $args 0 end-1]
  }
  set value [lindex $args end]
  set path [storage $rawpath]
  set dot .
  set one {}
  dict set result $dot $one
  set dpath {}
  foreach item [lrange $path 0 end-1] {
    set field $item
    lappend dpath [string trim $item /]
    dict set result {*}$dpath $dot $one
  }
  set field [lindex $rawpath end]
  set ext   [string index $field end]
  if {$ext eq {:} || ![dict is_dict $value]} {
    dict set result {*}$path $value
    return
  }
  if {$ext eq {/} && ![dict exists $result {*}$path $dot]} {
    dict set result {*}$path $dot $one
  }
  if {[dict exists $result {*}$path $dot]} {
    dict set result {*}$path [::clay::tree::merge [dict get $result {*}$path] $value]
    return
  }
  dict set result {*}$path $value
}

###
# A recursive form of dict merge, intended for modifying variables in place.
# example:
# > set mydict {sub/ {sub/ {description {a block of text}}}}
# > ::clay::tree::dictmerge mydict {sub/ {sub/ {field {another block of text}}}}]
# > clay::tree::print $mydict
# sub/ {
#   sub/ {
#     description {a block of text}
#     field {another block of text}
#   }
# }
###
proc ::clay::tree::dictmerge {varname args} {
  upvar 1 $varname result
  set dot .
  set one {}
  dict set result $dot $one
  foreach dict $args {
    dict for {f v} $dict {
      set field [string trim $f /]
      set bbranch [clay::tree::is_branch $dict $f]
      if {![dict exists $result $field]} {
        dict set result $field $v
        if {$bbranch} {
          dict set result $field [clay::tree::merge $v]
        } else {
          dict set result $field $v
        }
      } elseif {[dict exists $result $field $dot]} {
        if {$bbranch} {
          dict set result $field [clay::tree::merge [dict get $result $field] $v]
        } else {
          dict set result $field $v
        }
      }
    }
  }
  return $result
}



###
# A recursive form of dict merge
# [para]
# A routine to recursively dig through dicts and merge
# adapted from http://stevehavelka.com/tcl-dict-operation-nested-merge/
# example:
# > set mydict {sub/ {sub/ {description {a block of text}}}}
# > set odict [clay::tree::merge $mydict {sub/ {sub/ {field {another block of text}}}}]
# > clay::tree::print $odict
# sub/ {
#   sub/ {
#     description {a block of text}
#     field {another block of text}
#   }
# }
###
proc ::clay::tree::merge {args} {
  ###
  # The result of a merge is always a dict with branches
  ###
  set dot .
  set one {}
  dict set result $dot $one
  set argument 0
  foreach b $args {
    # Merge b into a, and handle nested dicts appropriately
    if {![dict is_dict $b]} {
      error "Element $b is not a dictionary"
    }
    dict for { k v } $b {
      if {$k eq $dot} {
        dict set result $dot $one
        continue
      }
      set bbranch [is_branch $b $k]
      set field [string trim $k /]
      if { ![dict exists $result $field] } {
        if {$bbranch} {
          dict set result $field [merge $v]
        } else {
          dict set result $field $v
        }
      } else {
        set abranch [dict exists $result $field $dot]
        if {$abranch && $bbranch} {
          dict set result $field [merge [dict get $result $field] $v]
        } else {
          dict set result $field $v
          if {$bbranch} {
            dict set result $field $dot $one
          }
        }
      }
    }
  }
  return $result
}
###
# Returns true if the path specified by args either does not exist,
# if exists and contains an empty string or the value of NULL or null.
# [para]
# This function is added to the global dict ensemble as [fun {dict isnull}]
###
::clay::PROC ::tcl::dict::isnull {dictionary args} {
  if {![exists $dictionary {*}$args]} {return 1}
  return [expr {[get $dictionary {*}$args] in {{} NULL null}}]
} {
  namespace ensemble configure dict -map [dict replace\
      [namespace ensemble configure dict -map] isnull ::tcl::dict::isnull]
}

namespace eval ::dictargs {}
if {[info commands ::dictargs::parse] eq {}} {
  proc ::dictargs::parse {argdef argdict} {
    set result {}
    dict for {field info} $argdef {
      if {![string is alnum [string index $field 0]]} {
        error "$field is not a simple variable name"
      }
      upvar 1 $field _var
      set aliases {}
      if {[dict exists $argdict $field]} {
        set _var [dict get $argdict $field]
        continue
      }
      if {[dict exists $info aliases:]} {
        set found 0
        foreach {name} [dict get $info aliases:] {
          if {[dict exists $argdict $name]} {
            set _var [dict get $argdict $name]
            set found 1
            break
          }
        }
        if {$found} continue
      }
      if {[dict exists $info default:]} {
        set _var [dict get $info default:]
        continue
      }
      set mandatory 1
      if {[dict exists $info mandatory:]} {
        set mandatory [dict get $info mandatory:]
      }
      if {$mandatory} {
        error "$field is required"
      }
    }
  }
}

###
# Named Procedures as new command
###
proc ::dictargs::proc {name argspec body} {
  set result {}
  append result "::dictargs::parse \{$argspec\} \$args" \;
  append result $body
  uplevel 1 [list ::proc $name [list [list args [list dictargs $argspec]]] $result]
}

proc ::dictargs::method {name argspec body} {
  set class [lindex [::info level -1] 1]
  set result {}
  append result "::dictargs::parse \{$argspec\} \$args" \;
  append result $body
  oo::define $class method $name [list [list args [list dictargs $argspec]]] $result
}

::namespace eval ::clay::define {}

proc ::clay::ensemble_methodbody {ensemble einfo} {
  set default standard
  set preamble {}
  set eswitch {}
  if {[dict exists $einfo default]} {
    set emethodinfo [dict get $einfo default]
    set argspec     [dict getnull $emethodinfo argspec]
    set realbody    [dict getnull $emethodinfo body]
    set argstyle    [dict getnull $emethodinfo argstyle]
    if {$argstyle eq "dictargs"} {
      set body "\n      ::dictargs::parse \{$argspec\} \$args"
    } elseif {[llength $argspec]==1 && [lindex $argspec 0] in {{} args arglist}} {
      set body {}
    } else {
      set body "\n      ::clay::dynamic_arguments $ensemble \$method [list $argspec] {*}\$args"
    }
    append body "\n      " [string trim $realbody] "      \n"
    set default $body
    dict unset einfo default
  }
  foreach {msubmethod esubmethodinfo} [lsort -dictionary -stride 2 $einfo] {
    set submethod [string trim $msubmethod :/-]
    if {$submethod eq "_body"} continue
    if {$submethod eq "_preamble"} {
      set preamble [dict getnull $esubmethodinfo body]
      continue
    }
    set argspec     [dict getnull $esubmethodinfo argspec]
    set realbody    [dict getnull $esubmethodinfo body]
    set argstyle    [dict getnull $esubmethodinfo argstyle]
    if {[string length [string trim $realbody]] eq {}} {
      dict set eswitch $submethod {}
    } else {
      if {$argstyle eq "dictargs"} {
        set body "\n      ::dictargs::parse \{$argspec\} \$args"
      } elseif {[llength $argspec]==1 && [lindex $argspec 0] in {{} args arglist}} {
        set body {}
      } else {
        set body "\n      ::clay::dynamic_arguments $ensemble \$method [list $argspec] {*}\$args"
      }
      append body "\n      " [string trim $realbody] "      \n"
      if {$submethod eq "default"} {
        set default $body
      } else {
        foreach alias [dict getnull $esubmethodinfo aliases] {
          dict set eswitch $alias -
        }
        dict set eswitch $submethod $body
      }
    }
  }
  set methodlist [lsort -dictionary [dict keys $eswitch]]
  if {![dict exists $eswitch <list>]} {
    dict set eswitch <list> {return $methodlist}
  }
  if {$default eq "standard"} {
    set default "error \"unknown method $ensemble \$method. Valid: \$methodlist\""
  }
  dict set eswitch default $default
  set mbody {}

  append mbody $preamble \n

  append mbody \n [list set methodlist $methodlist]
  append mbody \n "set code \[catch {switch -- \$method [list $eswitch]} result opts\]"
  append mbody \n {return -options $opts $result}
  return $mbody
}

::proc ::clay::define::Ensemble {rawmethod args} {
  if {[llength $args]==2} {
    lassign $args argspec body
    set argstyle tcl
  } elseif {[llength $args]==3} {
    lassign $args argstyle argspec body
  } else {
    error "Usage: Ensemble name ?argstyle? argspec body"
  }
  set class [current_class]
  #if {$::clay::trace>2} {
  #  puts [list $class Ensemble $rawmethod $argspec $body]
  #}
  set mlist [split $rawmethod "::"]
  set ensemble [string trim [lindex $mlist 0] :/]
  set mensemble ${ensemble}/
  if {[llength $mlist]==1 || [lindex $mlist 1] in "_body"} {
    set method _body
    ###
    # Simple method, needs no parsing, but we do need to record we have one
    ###
    if {$argstyle eq "dictargs"} {
      set argspec [list args $argspec]
    }
    $class clay set method_ensemble/ $mensemble _body [dict create argspec $argspec body $body argstyle $argstyle]
    if {$::clay::trace>2} {
      puts [list $class clay set method_ensemble/ $mensemble _body ...]
    }
    set method $rawmethod
    if {$::clay::trace>2} {
      puts [list $class Ensemble $rawmethod $argspec $body]
      set rawbody $body
      set body {puts [list [self] $class [self method]]}
      append body \n $rawbody
    }
    if {$argstyle eq "dictargs"} {
      set rawbody $body
      set body "::dictargs::parse \{$argspec\} \$args\; "
      append body $rawbody
    }
    ::oo::define $class method $rawmethod $argspec $body
    return
  }
  set method [join [lrange $mlist 2 end] "::"]
  $class clay set method_ensemble/ $mensemble [string trim [lindex $method 0] :/] [dict create argspec $argspec body $body argstyle $argstyle]
  if {$::clay::trace>2} {
    puts [list $class clay set method_ensemble/ $mensemble [string trim $method :/]  ...]
  }
}

::namespace eval ::clay::event {}

###
# Mark an object for destruction on the next cleanup
###
proc ::clay::destroy args {
  if {![info exists ::clay::idle_destroy]} {
    set ::clay::idle_destroy {}
  }
  foreach object $args {
    if {$object in $::clay::idle_destroy} continue
    lappend ::clay::idle_destroy  $object
  }
}

###
# Process the queue of objects to be destroyed
###
proc ::clay::cleanup {} {
  if {![info exists ::clay::idle_destroy]} return
  foreach obj $::clay::idle_destroy {
    if {[info commands $obj] ne {}} {
      catch {$obj destroy}
    }
  }
  set ::clay::idle_destroy {}
}

###
# description: Cancel a scheduled event
###
proc ::clay::event::cancel {self {task *}} {
  variable timer_event
  variable timer_script

  foreach {id event} [array get timer_event $self:$task] {
    ::after cancel $event
    set timer_event($id) {}
    set timer_script($id) {}
  }
}

###
# description:
#    Generate an event
#    Adds a subscription mechanism for objects
#    to see who has recieved this event and prevent
#    spamming or infinite recursion
###
proc ::clay::event::generate {self event args} {
  set wholist [Notification_list $self $event]
  if {$wholist eq {}} return
  set dictargs [::oo::meta::args_to_options {*}$args]
  set info $dictargs
  set strict 0
  set debug 0
  set sender $self
  dict with dictargs {}
  dict set info id     [::clay::event::nextid]
  dict set info origin $self
  dict set info sender $sender
  dict set info rcpt   {}
  foreach who $wholist {
    catch {::clay::event::notify $who $self $event $info}
  }
}

###
# title: Return a unique event handle
###
proc ::clay::event::nextid {} {
  return "event#[format %0.8x [incr ::clay::event_count]]"
}

###
# description:
#    Called recursively to produce a list of
#    who recieves notifications
###
proc ::clay::event::Notification_list {self event {stackvar {}}} {
  set notify_list {}
  foreach {obj patternlist} [array get ::clay::object_subscribe] {
    if {$obj eq $self} continue
    if {$obj in $notify_list} continue
    set match 0
    foreach {objpat eventlist} $patternlist {
      if {![string match $objpat $self]} continue
      foreach eventpat $eventlist {
        if {![string match $eventpat $event]} continue
        set match 1
        break
      }
      if {$match} {
        break
      }
    }
    if {$match} {
      lappend notify_list $obj
    }
  }
  return $notify_list
}

###
# Final delivery to intended recipient object
###
proc ::clay::event::notify {rcpt sender event eventinfo} {
  if {[info commands $rcpt] eq {}} return
  if {$::clay::trace} {
    puts [list event notify rcpt $rcpt sender $sender event $event info $eventinfo]
  }
  $rcpt notify $event $sender $eventinfo
}

###
# Evaluate an event script in the global namespace
###
proc ::clay::event::process {self handle script} {
  variable timer_event
  variable timer_script

  array unset timer_event $self:$handle
  array unset timer_script $self:$handle

  set err [catch {uplevel #0 $script} result errdat]
  if $err {
    puts "BGError: $self $handle $script
ERR: $result
[dict get $errdat -errorinfo]
***"
  }
}

###
# description: Schedule an event to occur later
###
proc ::clay::event::schedule {self handle interval script} {
  variable timer_event
  variable timer_script
  if {$::clay::trace} {
    puts [list $self schedule $handle $interval]
  }
  if {[info exists timer_event($self:$handle)]} {
    if {$script eq $timer_script($self:$handle)} {
      return
    }
    ::after cancel $timer_event($self:$handle)
  }
  set timer_script($self:$handle) $script
  set timer_event($self:$handle) [::after $interval [list ::clay::event::process $self $handle $script]]
}

###
# Subscribe an object to an event pattern
###
proc ::clay::event::subscribe {self who event} {
  upvar #0 ::clay::object_subscribe($self) subscriptions
  if {![info exists subscriptions]} {
    set subscriptions {}
  }
  set match 0
  foreach {objpat eventlist} $subscriptions {
    if {![string match $objpat $who]} continue
    foreach eventpat $eventlist {
      if {[string match $eventpat $event]} {
        # This rule already exists
        return
      }
    }
  }
  dict lappend subscriptions $who $event
}

###
# Unsubscribe an object from an event pattern
###
proc ::clay::event::unsubscribe {self args} {
  upvar #0 ::clay::object_subscribe($self) subscriptions
  if {![info exists subscriptions]} {
    return
  }
  switch [llength $args] {
    1 {
      set event [lindex $args 0]
      if {$event eq "*"} {
        # Shortcut, if the
        set subscriptions {}
      } else {
        set newlist {}
        foreach {objpat eventlist} $subscriptions {
          foreach eventpat $eventlist {
            if {[string match $event $eventpat]} continue
            dict lappend newlist $objpat $eventpat
          }
        }
        set subscriptions $newlist
      }
    }
    2 {
      set who [lindex $args 0]
      set event [lindex $args 1]
      if {$who eq "*" && $event eq "*"} {
        set subscriptions {}
      } else {
        set newlist {}
        foreach {objpat eventlist} $subscriptions {
          if {[string match $who $objpat]} {
            foreach eventpat $eventlist {
              if {[string match $event $eventpat]} continue
              dict lappend newlist $objpat $eventpat
            }
          }
        }
        set subscriptions $newlist
      }
    }
  }
}

[vset CATEGORY oo]
[include ../doctools2base/include/feedback.inc]

###
# Add elements to a list if that are not already present in the list.
# As a side effect, if variable [variable varname] does not exists,
# create it as an empty list.
# arglist:
# varname {positional 1 mandatory 1}
# element {positional 1 mandatory 0 repeating 1}
# example:
# ladd contents foo bar
# puts $contents
# > foo bar
# ladd contents foo bar baz bang
# puts $contents
# > foo bar baz bang
###
::clay::PROC ::clay::ladd {varname args} {
  upvar 1 $varname var
  if ![info exists var] {
      set var {}
  }
  foreach item $args {
    if {$item in $var} continue
    lappend var $item
  }
  return $var
}

###
# Delete all instances of the elements given from a list contained in [variable varname].
# If the variable does exist this is a noop.
# arglist:
# varname {positional 1 mandatory 1}
# element {positional 1 mandatory 0 repeating 1}
# example:
# set contents {foo bar baz bang foo foo foo}
# ldelete contents foo
# puts $contents
# > bar baz bang
###
::clay::PROC ::clay::ldelete {varname args} {
  upvar 1 $varname var
  if ![info exists var] {
      return
  }
  foreach item [lsort -unique $args] {
    while {[set i [lsearch $var $item]]>=0} {
      set var [lreplace $var $i $i]
    }
  }
  return $var
}

###
# Return a random element from [variable list]
###
::clay::PROC ::clay::lrandom list {
  set len [llength $list]
  set idx [expr int(rand()*$len)]
  return [lindex $list $idx]
}

[keywords oo]
[copyright {2018 Sean Woods <[email protected]>}]
[moddesc   {Clay Framework}]
[titledesc {A minimalist framework for large scale OO Projects}]
[category  {Programming tools}]
[keywords TclOO]
[require Tcl 8.6]
[require uuid]
[require oo::dialect]
[description]
Clay introduces a method ensemble to both [class oo::class] and [class oo::object] called
clay. This ensemble handles all of the high level interactions within the framework.
Clay stores structured data. Clan manages method delegation. Clay has facilities to
manage the complex interactions that come about with mixins.
[para]
The central concept is that inside of every object and class
(which are actually objects too) is a dict called clay. What is stored in that dict is
left to the imagination. But because this dict is exposed via a public method, we can
share structured data between object, classes, and mixins.
[para]
[subsection {Structured Data}]
Clay uses a standardized set of method interactions and introspection that TclOO already provides to perform on-the-fly searches. On-the-fly searches mean that the data is never stale, and we avoid many of the sorts of collisions that would arise when objects start mixing in other classes during operation.
[para]
The [method clay] methods for both classes and objects have a get and a set method. For objects, get will search through the local clay dict. If the requested leaf is not found, or the query is for a branch, the system will then begin to poll the clay methods of all of the class that implements the object, all of that classes’ ancestors, as well as all of the classes that have been mixed into this object, and all of their ancestors.
[para]
Intended branches on a tree end with a directory slash (/). Intended leaves are left unadorned. This is a guide for the tool that builds the search
results to know what parts of a dict are intended to be branches and which are intended to be leaves.
For simple cases, branch marking can be ignored:
[example {
::oo::class create ::foo { }
::foo clay set property/ color blue
::foo clay set property/ shape round

set A [::foo new]
$A clay get property/
{color blue shape round}

$A clay set property/ shape square
$A clay get property/
{color blue shape square}
}]
[para]
But when you start storing blocks of text, guessing what field is a dict and what isn’t gets messy:
[example {
::foo clay set description {A generic thing of designated color and shape}

$A clay get description
{A generic thing of designated color and shape}

Without a convention for discerning branches for leaves what should have been a value can be accidentally parsed as a dictionary, and merged with all of the other values that were never intended to be merge. Here is an example of it all going wrong:
::oo::class create ::foo { }
# Add description as a leaf
::foo clay set description \
  {A generic thing of designated color and shape}
# Add description as a branch
::foo clay set description/ \
  {A generic thing of designated color and shape}

::oo::class create ::bar {
  superclass foo
}
# Add description as a leaf
::bar clay set description \
  {A drinking establishment of designated color and shape and size}
# Add description as a branch
::bar clay set description/ \
  {A drinking establishment of designated color and shape and size}

set B [::bar new]
# As a leaf we get the value verbatim from he nearest ancestor
$B clay get description
  {A drinking establishment of designated color and shape and size}
# As a branch we get a recursive merge
$B clay get description/
{A drinking establishment of designated color and size thing of}
}]
[subsection {Clay Dialect}]
Clay is built using the oo::dialect module from Tcllib. oo::dialect allows you to either add keywords directly to clay, or to create your own
metaclass and keyword set using Clay as a foundation. For details on the keywords and what they do, consult the functions in the ::clay::define namespace.
[subsection {Method Delegation}]
Method Delegation
It is sometimes useful to have an external object that can be invoked as if it were a method of the object. Clay provides a delegate ensemble method to perform that delegation, as well as introspect which methods are delegated in that manner. All delegated methods are marked with html-like tag markings (< >) around them.
[example {
::clay::define counter {
  Variable counter 0
  method incr {{howmuch 1}} {
    my variable counter
    incr counter $howmuch
  }
  method value {} {
    my variable counter
    return $counter
  }
  method reset {} {
    my variable counter
    set counter 0
  }
}
::clay::define example {
  variable buffer
  constructor {} {
    # Build a counter object
    set obj [namespace current]::counter
    ::counter create $obj
    # Delegate the counter
    my delegate <counter> $obj
  }
  method line {text} {
    my <counter> incr
    append buffer $text
  }
}

set A [example new]
$A line {Who’s line is it anyway?}
$A <counter> value
1
}]

#-------------------------------------------------------------------------
# TITLE:
#    clay.tcl
#
# PROJECT:
#    clay: TclOO Helper Library
#
# DESCRIPTION:
#    clay(n): Implementation File
#
#-------------------------------------------------------------------------
::clay::dialect::create ::clay


proc ::clay::dynamic_methods class {
  foreach command [info commands [namespace current]::dynamic_methods_*] {
    $command $class
  }
}

proc ::clay::dynamic_methods_class {thisclass} {
  set methods {}
  set mdata [$thisclass clay find class_typemethod]
  foreach {method info} $mdata {
    if {$method eq {.}} continue
    set method [string trimright $method :/-]
    if {$method in $methods} continue
    lappend methods $method
    set arglist [dict getnull $info arglist]
    set body    [dict getnull $info body]
    ::oo::objdefine $thisclass method $method $arglist $body
  }
}

###
# New OO Keywords for clay
###
proc ::clay::define::Array {name {values {}}} {
  set class [current_class]
  set name [string trim $name :/]
  $class clay branch array $name
  dict for {var val} $values {
    $class clay set array/ $name $var $val
  }
}

###
# An annotation that objects of this class interact with delegated
# methods. The annotation is intended to be a dictionary, and the
# only reserved key is [emph {description}], a human readable description.
###
proc ::clay::define::Delegate {name info} {
  set class [current_class]
  foreach {field value} $info {
    $class clay set component/ [string trim $name :/]/ $field $value
  }
}

###
# topic: 2cfc44a49f067124fda228458f77f177
# title: Specify the constructor for a class
###
proc ::clay::define::constructor {arglist rawbody} {
  set body {
my variable DestroyEvent
set DestroyEvent 0
::clay::object_create [self] [info object class [self]]
# Initialize public variables and options
my InitializePublic
  }
  append body $rawbody
  set class [current_class]
  ::oo::define $class constructor $arglist $body
}

###
# Specify the a method for the class object itself, instead of for objects of the class
###
proc ::clay::define::Class_Method {name arglist body} {
  set class [current_class]
  $class clay set class_typemethod/ [string trim $name :/] [dict create arglist $arglist body $body]
}

###
# And alias to the new Class_Method keyword
###
proc ::clay::define::class_method {name arglist body} {
  set class [current_class]
  $class clay set class_typemethod/ [string trim $name :/] [dict create arglist $arglist body $body]
}

proc ::clay::define::clay {args} {
  set class [current_class]
  if {[lindex $args 0] in "cget set branch"} {
    $class clay {*}$args
  } else {
    $class clay set {*}$args
  }
}

###
# topic: 4cb3696bf06d1e372107795de7fe1545
# title: Specify the destructor for a class
###
proc ::clay::define::destructor rawbody {
  set body {
# Run the destructor once and only once
set self [self]
my variable DestroyEvent
if {$DestroyEvent} return
set DestroyEvent 1
::clay::object_destroy $self
}
  append body $rawbody
  ::oo::define [current_class] destructor $body
}

proc ::clay::define::Dict {name {values {}}} {
  set class [current_class]
  set name [string trim $name :/]
  $class clay branch dict $name
  foreach {var val} $values {
    $class clay set dict/ $name/ $var $val
  }
}

###
# Define an option for the class
###
proc ::clay::define::Option {name args} {
  set class [current_class]
  set dictargs {default {}}
  foreach {var val} [::clay::args_to_dict {*}$args] {
    dict set dictargs [string trim $var -:/] $val
  }
  set name [string trimleft $name -]

  ###
  # Option Class handling
  ###
  set optclass [dict getnull $dictargs class]
  if {$optclass ne {}} {
    foreach {f v} [$class clay find option_class $optclass] {
      if {![dict exists $dictargs $f]} {
        dict set dictargs $f $v
      }
    }
    if {$optclass eq "variable"} {
      variable $name [dict getnull $dictargs default]
    }
  }
  foreach {f v} $dictargs {
    $class clay set option $name $f $v
  }
}

proc ::clay::define::Method {name argstyle argspec body} {
  set class [current_class]
  set result {}
  switch $argstyle {
    dictargs {
      append result "::dictargs::parse \{$argspec\} \$args" \;
    }
  }
  append result $body
  oo::define $class method $name [list [list args [list dictargs $argspec]]] $result
}

###
# Define a class of options
# All field / value pairs will be be inherited by an option that
# specify [emph name] as it class field.
###
proc ::clay::define::Option_Class {name args} {
  set class [current_class]
  set dictargs {default {}}
  set name [string trimleft $name -:]
  foreach {f v} [::clay::args_to_dict {*}$args] {
    $class clay set option_class $name [string trim $f -/:] $v
  }
}

###
# topic: 615b7c43b863b0d8d1f9107a8d126b21
# title: Specify a variable which should be initialized in the constructor
# description:
#    This keyword can also be expressed:
#    [example {property variable NAME {default DEFAULT}}]
#    [para]
#    Variables registered in the variable property are also initialized
#    (if missing) when the object changes class via the [emph morph] method.
###
proc ::clay::define::Variable {name {default {}}} {
  set class [current_class]
  set name [string trimright $name :/]
  $class clay set variable/ $name $default
}

proc ::clay::object_create {objname {class {}}} {
  #if {$::clay::trace>0} {
  #  puts [list $objname CREATE]
  #}
}

proc ::clay::object_rename {object newname} {
  if {$::clay::trace>0} {
    puts [list $object RENAME -> $newname]
  }
}

proc ::clay::object_destroy objname {
  if {$::clay::trace>0} {
    puts [list $objname DESTROY]
  }
  #::cron::object_destroy $objname
}

# clay::object
#
# This class is inherited by all classes that have options.
#
::oo::define ::clay::object {

  ###
  # description:
  # The [method clay] method allows an object access
  # to a combination of its own clay data as
  # well as to that of its class
  # ensemble:
  # ancestors {
  #   argspec {}
  #   description {Return the class this object belongs to, all classes mixed into this object, and all ancestors of those classes in search order.}
  # }
  # cget {
  #   argspec {field {mandatory 1 positional 1}}
  #   description {
  # Pull a value from either the object's clay structure or one of its constituent classes that matches the field name.
  # The order of search us:
  # [para] 1. The as a value in local dict variable config
  # [para] 2. The as a value in local dict variable clay
  # [para] 3. As a leaf in any ancestor as a root of the clay tree
  # [para] 4. As a leaf in any ancestor as [const const] [emph field]
  # [para] 5. As a leaf in any ancestor as [const option] [emph field] [const default]
  #   }
  # }
  # delegate {
  #   argspec {stub {mandatory 0 positional 1} object {mandatory 0 positional 1}}
  #   description {
  # Introspect or control method delegation. With no arguments, the method will return a
  # key/value list of stubs and objects. With just the [arg stub] argument, the method will
  # return the object (if any) attached to the stub. With a [arg stub] and an [arg object]
  # this command will forward all calls to the method [arg stub] to the [arg object].
  # }
  # }
  # dump { argspec {} description {Return a complete dump of this object's clay data, as well as the data from all constituent classes recursively blended in.}}
  # ensemble_map {argspec {} description {Return a dictionary describing the method ensembles to be assembled for this object}}
  # eval {argspec {script {mandatory 1 positional 1}} description {Evaluated a script in the namespace of this object}}
  # evolve {argspec {} description {Trigger the [method InitializePublic] private method}}
  # exists {argspec {path {mandatory 1 positional 1 repeating 1}} description {Returns 1 if [emph path] exists in either the object's clay data. Values greater than one indicate the element exists in one of the object's constituent classes. A value of zero indicates the path could not be found.}}
  # flush {argspec {} description {Wipe any caches built by the clay implementation}}
  # forward {argspec {method {positional 1 mandatory 1} object {positional 1 mandatory 1}} description {A convenience wrapper for
  # [example {oo::objdefine [self] forward {*}$args}]
  # }
  # }
  # get {argspec {path {mandatory 1 positional 1 repeating 1}}
  #   description {Pull a chunk of data from the clay system. If the last element of [emph path] is a branch (ends in a slash /),
  #   returns a recursive merge of all data from this object and it's constituent classes of the data in that branch.
  #   If the last element is a leaf, search this object for a matching leaf, or search all  constituent classes for a matching
  #   leaf and return the first value found.
  #   If no value is found, returns an empty string.
  # }
  # }
  # leaf {argspec {path {mandatory 1 positional 1 repeating 1}} description {A modified get which is tailored to pull only leaf elements}}
  # merge {argspec {dict {mandatory 1 positional 1 repeating 1}} description {Recursively merge the dictionaries given into the object's local clay storage.}}
  # mixin {argspec {class {mandatory 1 positional 1 repeating 1}} description {
  # Perform [lb]oo::objdefine [lb]self[rb] mixin[rb] on this object, with a few additional rules:
  #   Prior to the call, for any class was previously mixed in, but not in the new result, execute the script registered to mixin/ unmap-script (if given.)
  #   For all new classes, that were not present prior to this call, after the native TclOO mixin is invoked, execute the script registered to mixin/ map-script (if given.)
  #   Fall all classes that are now present and “mixed in”, execute the script registered to mixin/ react-script (if given.)
  # }}
  # mixinmap {
  #   argspec {stub {mandatory 0 positional 1} classes {mandatory 0 positional 1}}
  #   description {With no arguments returns the map of stubs and classes mixed into the current object. When only stub is given,
  #  returns the classes mixed in on that stub. When stub and classlist given, replace the classes currently on that stub with the given
  #  classes and invoke clay mixin on the new matrix of mixed in classes.
  # }
  # }
  # provenance {argspec {path {mandatory 1 positional 1 repeating 1}} description {Return either [const self] if that path exists in the current object, or return the first class (if any) along the clay search path which contains that element.}}
  # replace {argspec {dictionary {mandatory 1 positional 1}} description {Replace the contents of the internal clay storage with the dictionary given.}}
  # source {argspec {filename {mandatory 1 positional 1}} description {Source the given filename within the object's namespace}}
  # set {argspec {path {mandatory 1 positional 1 repeating 1} value {mandatory 1 postional 1}} description {Merge the conents of [const value] with the object's clay storage at [const path].}}
  ###
  method clay {submethod args} {
    my variable clay claycache clayorder config option_canonical
    if {![info exists clay]} {set clay {}}
    if {![info exists claycache]} {set claycache {}}
    if {![info exists config]} {set config {}}
    if {![info exists clayorder] || [llength $clayorder]==0} {
      set clayorder {}
      if {[dict exists $clay cascade]} {
        dict for {f v} [dict get $clay cascade] {
          if {$f eq "."} continue
          if {[info commands $v] ne {}} {
            lappend clayorder $v
          }
        }
      }
      lappend clayorder {*}[::clay::ancestors [info object class [self]] {*}[lreverse [info object mixins [self]]]]
    }
    switch $submethod {
      ancestors {
        return $clayorder
      }
      branch {
        set path [::clay::tree::storage $args]
        if {![dict exists $clay {*}$path .]} {
          dict set clay {*}$path . {}
        }
      }
      cget {
        # Leaf searches return one data field at a time
        # Search in our local dict
        if {[llength $args]==1} {
          set field [string trim [lindex $args 0] -:/]
          if {[info exists option_canonical($field)]} {
            set field $option_canonical($field)
          }
          if {[dict exists $config $field]} {
            return [dict get $config $field]
          }
        }
        set path [::clay::tree::storage $args]
        if {[dict exists $clay {*}$path]} {
          return [dict get $clay {*}$path]
        }
        # Search in our local cache
        if {[dict exists $claycache {*}$path]} {
          if {[dict exists $claycache {*}$path .]} {
            return [dict remove [dict get $claycache {*}$path] .]
          } else {
            return [dict get $claycache {*}$path]
          }
        }
        # Search in the in our list of classes for an answer
        foreach class $clayorder {
          if {[$class clay exists {*}$path]} {
            set value [$class clay get {*}$path]
            dict set claycache {*}$path $value
            return $value
          }
          if {[$class clay exists const {*}$path]} {
            set value [$class clay get const {*}$path]
            dict set claycache {*}$path $value
            return $value
          }
          if {[$class clay exists option {*}$path default]} {
            set value [$class clay get option {*}$path default]
            dict set claycache {*}$path $value
            return $value
          }
        }
        return {}
      }
      delegate {
        if {![dict exists $clay .delegate <class>]} {
          dict set clay .delegate <class> [info object class [self]]
        }
        if {[llength $args]==0} {
          return [dict get $clay .delegate]
        }
        if {[llength $args]==1} {
          set stub <[string trim [lindex $args 0] <>]>
          if {![dict exists $clay .delegate $stub]} {
            return {}
          }
          return [dict get $clay .delegate $stub]
        }
        if {([llength $args] % 2)} {
          error "Usage: delegate
    OR
    delegate stub
    OR
    delegate stub OBJECT ?stub OBJECT? ..."
        }
        foreach {stub object} $args {
          set stub <[string trim $stub <>]>
          dict set clay .delegate $stub $object
          oo::objdefine [self] forward ${stub} $object
          oo::objdefine [self] export ${stub}
        }
      }
      dump {
        # Do a full dump of clay data
        set result {}
        # Search in the in our list of classes for an answer
        foreach class $clayorder {
          ::clay::tree::dictmerge result [$class clay dump]
        }
        ::clay::tree::dictmerge result $clay
        return $result
      }
      ensemble_map {
        set ensemble [lindex $args 0]
        my variable claycache
        set mensemble [string trim $ensemble :/]
        if {[dict exists $claycache method_ensemble $mensemble]} {
          return [clay::tree::sanitize [dict get $claycache method_ensemble $mensemble]]
        }
        set emap [my clay dget method_ensemble $mensemble]
        dict set claycache method_ensemble $mensemble $emap
        return [clay::tree::sanitize $emap]
      }
      eval {
        set script [lindex $args 0]
        set buffer {}
        set thisline {}
        foreach line [split $script \n] {
          append thisline $line
          if {![info complete $thisline]} {
            append thisline \n
            continue
          }
          set thisline [string trim $thisline]
          if {[string index $thisline 0] eq "#"} continue
          if {[string length $thisline]==0} continue
          if {[lindex $thisline 0] eq "my"} {
            # Line already calls out "my", accept verbatim
            append buffer $thisline \n
          } elseif {[string range $thisline 0 2] eq "::"} {
            # Fully qualified commands accepted verbatim
            append buffer $thisline \n
          } elseif {
            append buffer "my $thisline" \n
          }
          set thisline {}
        }
        eval $buffer
      }
      evolve -
      initialize {
        my InitializePublic
      }
      exists {
        # Leaf searches return one data field at a time
        # Search in our local dict
        set path [::clay::tree::storage $args]
        if {[dict exists $clay {*}$path]} {
          return 1
        }
        # Search in our local cache
        if {[dict exists $claycache {*}$path]} {
          return 2
        }
        set count 2
        # Search in the in our list of classes for an answer
        foreach class $clayorder {
          incr count
          if {[$class clay exists {*}$path]} {
            return $count
          }
        }
        return 0
      }
      flush {
        set claycache {}
        set clayorder [::clay::ancestors [info object class [self]] {*}[lreverse [info object mixins [self]]]]
      }
      forward {
        oo::objdefine [self] forward {*}$args
      }
      dget {
        set path [::clay::tree::storage $args]
        if {[llength $path]==0} {
          # Do a full dump of clay data
          set result {}
          # Search in the in our list of classes for an answer
          foreach class $clayorder {
            ::clay::tree::dictmerge result [$class clay dump]
          }
          ::clay::tree::dictmerge result $clay
          return $result
        }
        # Search in our local cache
        if {[dict exists $claycache {*}$path .]} {
          return [dict get $claycache {*}$path]
        }
        if {[dict exists $claycache {*}$path]} {
          return [dict get $claycache {*}$path]
        }
        if {[dict exists $clay {*}$path] && ![dict exists $clay {*}$path .]} {
          # Path is a leaf
          return [dict get $clay {*}$path]
        }
        set found 0
        set branch [dict exists $clay {*}$path .]
        foreach class $clayorder {
          if {[$class clay exists {*}$path .]} {
            set found 1
            break
          }
          if {!$branch && [$class clay exists {*}$path]} {
            set result [$class clay dget {*}$path]
            dict set claycache {*}$path $result
            return $result
          }
        }
        # Path is a branch
        set result [dict getnull $clay {*}$path]
        foreach class $clayorder {
          if {![$class clay exists {*}$path .]} continue
          ::clay::tree::dictmerge result [$class clay dget {*}$path]
        }
        #if {[dict exists $clay {*}$path .]} {
        #  ::clay::tree::dictmerge result
        #}
        dict set claycache {*}$path $result
        return $result
      }
      getnull -
      get {
        set path [::clay::tree::storage $args]
        if {[llength $path]==0} {
          # Do a full dump of clay data
          set result {}
          # Search in the in our list of classes for an answer
          foreach class $clayorder {
            ::clay::tree::dictmerge result [$class clay dump]
          }
          ::clay::tree::dictmerge result $clay
          return [::clay::tree::sanitize $result]
        }
        # Search in our local cache
        if {[dict exists $claycache {*}$path .]} {
          return [::clay::tree::sanitize [dict get $claycache {*}$path]]
        }
        if {[dict exists $claycache {*}$path]} {
          return [dict get $claycache {*}$path]
        }
        if {[dict exists $clay {*}$path] && ![dict exists $clay {*}$path .]} {
          # Path is a leaf
          return [dict get $clay {*}$path]
        }
        set found 0
        set branch [dict exists $clay {*}$path .]
        foreach class $clayorder {
          if {[$class clay exists {*}$path .]} {
            set found 1
            break
          }
          if {!$branch && [$class clay exists {*}$path]} {
            set result [$class clay dget {*}$path]
            dict set claycache {*}$path $result
            return $result
          }
        }
        # Path is a branch
        set result [dict getnull $clay {*}$path]
        #foreach class [lreverse $clayorder] {
        #  if {![$class clay exists {*}$path .]} continue
        #  ::clay::tree::dictmerge result [$class clay dget {*}$path]
        #}
        foreach class $clayorder {
          if {![$class clay exists {*}$path .]} continue
          ::clay::tree::dictmerge result [$class clay dget {*}$path]
        }
        #if {[dict exists $clay {*}$path .]} {
        #  ::clay::tree::dictmerge result [dict get $clay {*}$path]
        #}
        dict set claycache {*}$path $result
        return [clay::tree::sanitize $result]
      }
      leaf {
        # Leaf searches return one data field at a time
        # Search in our local dict
        set path [::clay::tree::storage $args]
        if {[dict exists $clay {*}$path .]} {
          return [clay::tree::sanitize [dict get $clay {*}$path]]
        }
        if {[dict exists $clay {*}$path]} {
          return [dict get $clay {*}$path]
        }
        # Search in our local cache
        if {[dict exists $claycache {*}$path .]} {
          return [clay::tree::sanitize [dict get $claycache {*}$path]]
        }
        if {[dict exists $claycache {*}$path]} {
          return [dict get $claycache {*}$path]
        }
        # Search in the in our list of classes for an answer
        foreach class $clayorder {
          if {[$class clay exists {*}$path]} {
            set value [$class clay get {*}$path]
            dict set claycache {*}$path $value
            return $value
          }
        }
      }
      merge {
        foreach arg $args {
          ::clay::tree::dictmerge clay {*}$arg
        }
      }
      mixin {
        ###
        # Mix in the class
        ###
        set prior  [info object mixins [self]]
        set newmixin {}
        foreach item $args {
          lappend newmixin ::[string trimleft $item :]
        }
        set newmap $args
        foreach class $prior {
          if {$class ni $newmixin} {
            set script [$class clay search mixin/ unmap-script]
            if {[string length $script]} {
              if {[catch $script err errdat]} {
                puts stderr "[self] MIXIN ERROR POPPING $class:\n[dict get $errdat -errorinfo]"
              }
            }
          }
        }
        ::oo::objdefine [self] mixin {*}$args
        ###
        # Build a compsite map of all ensembles defined by the object's current
        # class as well as all of the classes being mixed in
        ###
        my InitializePublic
        foreach class $newmixin {
          if {$class ni $prior} {
            set script [$class clay search mixin/ map-script]
            if {[string length $script]} {
              if {[catch $script err errdat]} {
                puts stderr "[self] MIXIN ERROR PUSHING $class:\n[dict get $errdat -errorinfo]"
              }
            }
          }
        }
        foreach class $newmixin {
          set script [$class clay search mixin/ react-script]
          if {[string length $script]} {
            if {[catch $script err errdat]} {
              puts stderr "[self] MIXIN ERROR PEEKING $class:\n[dict get $errdat -errorinfo]"
            }
            break
          }
        }
      }
      mixinmap {
        my variable clay
        if {![dict exists $clay .mixin]} {
          dict set clay .mixin {}
        }
        if {[llength $args]==0} {
          return [dict get $clay .mixin]
        } elseif {[llength $args]==1} {
          return [dict getnull $clay .mixin [lindex $args 0]]
        } else {
          dict for {slot classes} $args {
            dict set clay .mixin $slot $classes
          }
          set classlist {}
          dict for {item class} [dict get $clay .mixin] {
            if {$class ne {}} {
              lappend classlist $class
            }
          }
          my clay mixin {*}[lreverse $classlist]
        }
      }
      provenance {
        if {[dict exists $clay {*}$args]} {
          return self
        }
        foreach class $clayorder {
          if {[$class clay exists {*}$args]} {
            return $class
          }
        }
        return {}
      }
      replace {
        set clay [lindex $args 0]
      }
      source {
        source [lindex $args 0]
      }
      set {
        #puts [list [self] clay SET {*}$args]
        set claycache {}
        ::clay::tree::dictset clay {*}$args
      }
      default {
        dict $submethod clay {*}$args
      }
    }
  }

  ###
  # Instantiate variables. Called on object creation and during clay mixin.
  ###
  method InitializePublic {} {
    my variable clayorder clay claycache config option_canonical
    set claycache {}
    set clayorder [::clay::ancestors [info object class [self]] {*}[lreverse [info object mixins [self]]]]
    if {![info exists clay]} {
      set clay {}
    }
    if {![info exists config]} {
      set config {}
    }
    dict for {var value} [my clay get variable] {
      if { $var in {. clay} } continue
      set var [string trim $var :/]
      my variable $var
      if {![info exists $var]} {
        if {$::clay::trace>2} {puts [list initialize variable $var $value]}
        set $var $value
      }
    }
    dict for {var value} [my clay get dict/] {
      if { $var in {. clay} } continue
      set var [string trim $var :/]
      my variable $var
      if {![info exists $var]} {
        set $var {}
      }
      foreach {f v} $value {
        if {$f eq "."} continue
        if {![dict exists ${var} $f]} {
          if {$::clay::trace>2} {puts [list initialize dict $var $f $v]}
          dict set ${var} $f $v
        }
      }
    }
    foreach {var value} [my clay get array/] {
      if { $var in {. clay} } continue
      set var [string trim $var :/]
      if { $var eq {clay} } continue
      my variable $var
      if {![info exists $var]} { array set $var {} }
      foreach {f v} $value {
        if {![array exists ${var}($f)]} {
          if {$f eq "."} continue
          if {$::clay::trace>2} {puts [list initialize array $var\($f\) $v]}
          set ${var}($f) $v
        }
      }
    }
    foreach {field info} [my clay get option/] {
      if { $field in {. clay} } continue
      set field [string trim $field -/:]
      foreach alias [dict getnull $info aliases] {
        set option_canonical($alias) $field
      }
      if {[dict exists $config $field]} continue
      set getcmd [dict getnull $info default-command]
      if {$getcmd ne {}} {
        set value [{*}[string map [list %field% $field %self% [namespace which my]] $getcmd]]
      } else {
        set value [dict getnull $info default]
      }
      dict set config $field $value
      set setcmd [dict getnull $info set-command]
      if {$setcmd ne {}} {
        {*}[string map [list %field% [list $field] %value% [list $value] %self% [namespace which my]] $setcmd]
      }
    }
    my variable clayorder clay claycache
    if {[info exists clay]} {
      set emap [dict getnull $clay method_ensemble]
    } else {
      set emap {}
    }
    foreach class [lreverse $clayorder] {
      ###
      # Build a compsite map of all ensembles defined by the object's current
      # class as well as all of the classes being mixed in
      ###
      dict for {mensemble einfo} [$class clay get method_ensemble] {
        if {$mensemble eq {.}} continue
        set ensemble [string trim $mensemble :/]
        if {$::clay::trace>2} {puts [list Defining $ensemble from $class]}

        dict for {method info} $einfo {
          if {$method eq {.}} continue
          if {![dict is_dict $info]} {
            puts [list WARNING: class: $class method: $method not dict: $info]
            continue
          }
          dict set info source $class
          if {$::clay::trace>2} {puts [list Defining $ensemble -> $method from $class - $info]}
          dict set emap $ensemble $method $info
        }
      }
    }
    foreach {ensemble einfo} $emap {
      #if {[dict exists $einfo _body]} continue
      set body [::clay::ensemble_methodbody $ensemble $einfo]
      if {$::clay::trace>2} {
        set rawbody $body
        set body {puts [list [self] <object> [self method]]}
        append body \n $rawbody
      }
      oo::objdefine [self] method $ensemble {{method default} args} $body
    }
  }
}

::clay::object clay branch array
::clay::object clay branch mixin
::clay::object clay branch option
::clay::object clay branch dict clay
::clay::object clay set variable DestroyEvent 0

namespace eval ::clay {}
set ::clay::trace 0

###
# Because many features in this package may be added as
# commands to future tcl cores, or be provided in binary
# form by packages, I need a declaritive way of saying
# [emph {Create this command if there isn't one already}].
# The [emph ninja] argument is a script to execute if the
# command is created by this mechanism.
###
proc ::clay::PROC {name arglist body {ninja {}}} {
  if {[info commands $name] ne {}} return
  proc $name $arglist $body
  eval $ninja
}
if {[info commands ::PROC] eq {}} {
  namespace eval ::clay { namespace export PROC }
  namespace eval :: { namespace import ::clay::PROC }
}

proc ::clay::_ancestors {resultvar class} {
  upvar 1 $resultvar result
  if {$class in $result} {
    return
  }
  lappend result $class
  foreach aclass [::info class superclasses $class] {
    _ancestors result $aclass
  }
}

proc ::clay::ancestors {args} {
  set result {}
  set queue  {}
  set metaclasses {}

  foreach class $args {
    set ancestors($class) {}
    _ancestors ancestors($class) $class
  }
  foreach class [lreverse $args] {
    foreach aclass $ancestors($class) {
      if {$aclass in $result} continue
      set skip 0
      foreach bclass $args {
        if {$class eq $bclass} continue
        if {$aclass in $ancestors($bclass)} {
          set skip 1
          break
        }
      }
      if {$skip} continue
      lappend result $aclass
    }
  }
  foreach class [lreverse $args] {
    foreach aclass $ancestors($class) {
      if {$aclass in $result} continue
      lappend result $aclass
    }
  }
  ###
  # Screen out classes that do not participate in clay
  # interactions
  ###
  set output {}
  foreach {item} $result {
    if {[catch {$item clay noop} err]} {
      continue
    }
    lappend output $item
  }
  return $output
}

proc ::clay::args_to_dict args {
  if {[llength $args]==1} {
    return [lindex $args 0]
  }
  return $args
}

proc ::clay::args_to_options args {
  set result {}
  foreach {var val} [args_to_dict {*}$args] {
    lappend result [string trim $var -:] $val
  }
  return $result
}

###
# topic: 4969d897a83d91a230a17f166dbcaede
###
proc ::clay::dynamic_arguments {ensemble method arglist args} {
  set idx 0
  set len [llength $args]
  if {$len > [llength $arglist]} {
    ###
    # Catch if the user supplies too many arguments
    ###
    set dargs 0
    if {[lindex $arglist end] ni {args dictargs}} {
      return -code error -level 2 "Usage: $ensemble $method [string trim [dynamic_wrongargs_message $arglist]]"
    }
  }
  foreach argdef $arglist {
    if {$argdef eq "args"} {
      ###
      # Perform args processing in the style of tcl
      ###
      uplevel 1 [list set args [lrange $args $idx end]]
      break
    }
    if {$argdef eq "dictargs"} {
      ###
      # Perform args processing in the style of tcl
      ###
      uplevel 1 [list set args [lrange $args $idx end]]
      ###
      # Perform args processing in the style of clay
      ###
      set dictargs [::clay::args_to_options {*}[lrange $args $idx end]]
      uplevel 1 [list set dictargs $dictargs]
      break
    }
    if {$idx > $len} {
      ###
      # Catch if the user supplies too few arguments
      ###
      if {[llength $argdef]==1} {
        return -code error -level 2 "Usage: $ensemble $method [string trim [dynamic_wrongargs_message $arglist]]"
      } else {
        uplevel 1 [list set [lindex $argdef 0] [lindex $argdef 1]]
      }
    } else {
      uplevel 1 [list set [lindex $argdef 0] [lindex $args $idx]]
    }
    incr idx
  }
}

###
# topic: 53ab28ac5c6ee601fe1fe07b073be88e
###
proc ::clay::dynamic_wrongargs_message {arglist} {
  set result ""
  set dargs 0
  foreach argdef $arglist {
    if {$argdef in {args dictargs}} {
      set dargs 1
      break
    }
    if {[llength $argdef]==1} {
      append result " $argdef"
    } else {
      append result " ?[lindex $argdef 0]?"
    }
  }
  if { $dargs } {
    append result " ?option value?..."
  }
  return $result
}

proc ::clay::is_dict { d } {
  # is it a dict, or can it be treated like one?
  if {[catch {::dict size $d} err]} {
    #::set ::errorInfo {}
    return 0
  }
  return 1
}

proc ::clay::is_null value {
  return [expr {$value in {{} NULL}}]
}

proc ::clay::leaf args {
  set marker [string index [lindex $args end] end]
  set result [path {*}${args}]
  if {$marker eq "/"} {
    return $result
  }
  return [list {*}[lrange $result 0 end-1] [string trim [string trim [lindex $result end]] /]]
}

proc ::clay::K {a b} {set a}
if {[info commands ::K] eq {}} {
  namespace eval ::clay { namespace export K }
  namespace eval :: { namespace import ::clay::K }
}

###
# Perform a noop. Useful in prototyping for commenting out blocks
# of code without actually having to comment them out. It also makes
# a handy default for method delegation if a delegate has not been
# assigned yet.
proc ::clay::noop args {}
if {[info commands ::noop] eq {}} {
  namespace eval ::clay { namespace export noop }
  namespace eval :: { namespace import ::clay::noop }
}

proc ::clay::path args {
  set result {}
  foreach item $args {
    set item [string trim $item :./]
    foreach subitem [split $item /] {
      lappend result [string trim ${subitem}]/
    }
  }
  return $result
}

###
# Append a line of text to a variable. Optionally apply a string mapping.
# arglist:
#   map {mandatory 0 positional 1}
#   text {mandatory 1 positional 1}
###
proc ::clay::putb {buffername args} {
  upvar 1 $buffername buffer
  switch [llength $args] {
    1 {
      append buffer [lindex $args 0] \n
    }
    2 {
      append buffer [string map {*}$args] \n
    }
    default {
      error "usage: putb buffername ?map? string"
    }
  }
}
if {[info command ::putb] eq {}} {
  namespace eval ::clay { namespace export putb }
  namespace eval :: { namespace import ::clay::putb }
}

proc ::clay::script_path {} {
  set path [file dirname [file join [pwd] [info script]]]
  return $path
}

proc ::clay::NSNormalize qualname {
  if {![string match ::* $qualname]} {
    set qualname ::clay::classes::$qualname
  }
  regsub -all {::+} $qualname "::"
}

proc ::clay::uuid_generate args {
  return [uuid generate]
}

namespace eval ::clay {
  variable option_class {}
  variable core_classes {::oo::class ::oo::object}
}

###
# Test script build functions
###

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

putb result {
set ::clay::trace 0
}

###
# UUID test
###
putb result {

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


putb result {
# 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}}}
}


###
# Tests for clay::tree
###

putb result {
###
# Test canonical mapping
###
}
set test 0
  foreach {pattern canonical storage} {
    {foo bar baz}       {foo/ bar/ baz}         {foo bar baz}
    {foo bar baz/}      {foo/ bar/ baz/}        {foo bar baz}
    {foo bar .}         {foo/ bar}              {foo bar .}
    {foo/ bar/ .}       {foo/ bar}              {foo bar .}
    {foo . bar . baz .} {foo/ bar/ baz}         {foo . bar . baz .}
    {foo bar baz bat:}  {foo/ bar/ baz/ bat:}   {foo bar baz bat:}
    {foo:}              {foo:}                  {foo:}
    {foo/bar/baz/bat:}  {foo/ bar/ baz/ bat:}   {foo bar baz bat:}
} {
    dict set map %pattern% $pattern
    dict set map %canonical% $canonical
    dict set map %storage% $storage
    incr test

    dict set map %test% [format "test-storage-%04d" $test]
    putb result $map {
test {%test%} {Test ::clay::tree::storage with %pattern%} {
  clay::tree::storage {%pattern%}
} {%storage%}
}
}

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

set test 0
foreach {path isbranch} {
  foo 1
  {foo bar} 1
  {foo bar baz} 0
  {foo bar bing} 0
  {foo bar bang} 1
  {foo bar bang whoop} 0
} {
  set mpath [lrange $path 0 end-1]
  set item  [lindex $path end]
  set tests [list {} {} $isbranch {} : 0 {} / 1 . {} 0]
  dict set map %mpath% $mpath
  dict set map %item% $item
  foreach {head tail isbranch} $tests {
    dict set map %head% $head
    dict set map %tail% $tail
    dict set map %isbranch% $isbranch
    dict set map %test% [format "test-branch-%04d" [incr test]]
    putb result $map {
test {%test%} {Test that %mpath% %head%%item%%tail% is_branch = %isbranch%} {
  clay::tree::is_branch $r {%mpath% %head%%item%%tail%}
} %isbranch%
}
  }
}

putb result {
# -------------------------------------------------------------------------
# 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}}
}


putb result {
# -------------------------------------------------------------------------
# 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
}

putb result {
###
# 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
} {}

}

putb result {
# -------------------------------------------------------------------------
# clay submodule testing
# -------------------------------------------------------------------------

}
putb result {
# Test canonical path building
set path {const/ foo/ bar/ baz/}
}
set testnum 0
foreach {pattern} {
  {const foo bar baz}
  {const/ foo/ bar/ baz}
  {const/foo/bar/baz}
  {const/foo bar/baz}
  {const/foo/bar baz}
  {const foo/bar/baz}
  {const foo bar/baz}
  {const/foo bar baz}
} {
  putb result [list %pattern% $pattern %testnum% [format %04d [incr testnum]]] {
test oo-clay-path-%testnum% "Test path: %pattern%" {
  ::clay::path %pattern%
} $path
}
}
putb result {set path {const/ foo/ bar/ baz/ bing}}
set testnum 0
foreach {pattern} {
  {const foo bar baz bing}
  {const/ foo/ bar/ baz/ bing}
  {const/foo/bar/baz/bing}
  {const/foo bar/baz/bing:}
  {const/foo/bar baz bing}
  {const/foo/bar baz bing:}
  {const foo/bar/baz/bing}
  {const foo bar/baz/bing}
  {const/foo bar baz bing}
} {
  putb result [list %pattern% $pattern %testnum% [format %04d [incr testnum]]] {
test oo-clay-leaf-%testnum% "Test leaf: %pattern%" {
  ::clay::leaf %pattern%
} $path
}
}

putb result {namespace eval ::foo {}}

set class-a ::foo::classa
set commands-a {
  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}
  }
}
set claydict-a {
  const/ {color blue flavor strawberry sound zoink}
  info/  {
    animal no
    building no
    subelement {pedantic yes}
  }
}

putb result [list %class% ${class-a} %commands% ${commands-a}] {
clay::define %class% {
%commands%
}
}

set testnum 0
foreach {top children} ${claydict-a} {
  foreach {child value} $children {
    set map {}
    dict set map %class% ${class-a}
    dict set map %top% $top
    dict set map %child% $child
    dict set map %value% $value
    dict set map %testnum% [format %04d [incr testnum]]
    putb result $map {
test oo-class-clay-method-%testnum% "Test %class% %top% %child% exists" {
  %class% clay exists %top% %child%
} 1
}
    dict set map %test% [format %04d [incr testnum]]
    putb result $map {
test oo-class-clay-method-%testnum% "Test %class% %top% %child% value" {
  %class% clay get %top% %child%
} {%value%}
}
  }
}


set class-b ::foo::classb
set claydict-b {
  const/ {color black flavor vanilla feeling dread}
  info/  {subelement {spoon yes}}
}
set commands-b {}
foreach {top children} ${claydict-b} {
  foreach {child value} $children {
    putb commands-b "  [list clay set $top $child $value]"
  }
}
putb result [list %class% ${class-b} %commands% ${commands-b}] {
clay::define %class% {
%commands%
}
}

foreach {top children} ${claydict-b} {
  foreach {child value} $children {
    set map {}
    dict set map %class% ${class-b}
    dict set map %top% $top
    dict set map %child% $child
    dict set map %value% $value
    dict set map %testnum% [format %04d [incr testnum]]
    putb result $map {
test oo-class-clay-method-%testnum% "Test %class% %top% %child% exists" {
  %class% clay exists %top% %child%
} 1
}
    dict set map %test% [format %04d [incr testnum]]
    putb result $map {
test oo-class-clay-method-%testnum% "Test %class% %top% %child% value" {
  %class% clay get %top% %child%
} {%value%}
}
  }
}

set commands-c {superclass ::foo::classb ::foo::classa}
set class-c ::foo::class.ab
putb result [list %class% ${class-c} %commands% ${commands-c}] {
clay::define %class% {
%commands%
}
}
set commands-d {superclass ::foo::classa ::foo::classb}
set class-d ::foo::class.ba
putb result [list %class% ${class-d} %commands% ${commands-d}] {
clay::define %class% {
%commands%
}
}

###
# Tests for objects
###

putb result {# -------------------------------------------------------------------------
# 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
}
set matrix ${claydict-a}
set testnum 0
foreach {top children} $matrix {
  foreach {child value} $children {
    set map {}
    dict set map %object1% OBJECTA
    dict set map %object2% MIXINA

    dict set map %top% $top
    dict set map %child% $child
    dict set map %value% $value
    dict set map %testnum% [format %04d [incr testnum]]
    putb result $map {
test oo-object-clay-method-native-%testnum% {Test native object gets the property %top%/%child%} {
  $%object1% clay get %top% %child%
} {%value%}
test oo-object-clay-method-mixin-%testnum% {Test mixin object gets the property %top%/%child%} {
  $%object2% clay get %top% %child%
} {%value%}
}
  }
}

putb result {# -------------------------------------------------------------------------
# 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
}
set matrix ${claydict-b}
#set testnum 0
foreach {top children} $matrix {
  foreach {child value} $children {
    set map {}
    dict set map %object1% OBJECTB
    dict set map %object2% MIXINB

    dict set map %top% $top
    dict set map %child% $child
    dict set map %value% $value
    dict set map %testnum% [format %04d [incr testnum]]
    putb result $map {
test oo-object-clay-method-native-%testnum% {Test native object gets the property %top%/%child%} {
  $%object1% clay get %top% %child%
} {%value%}
test oo-object-clay-method-mixin-%testnum% {Test mixin object gets the property %top%/%child%} {
  $%object2% clay get %top% %child%
} {%value%}
}
  }
}

putb result {# -------------------------------------------------------------------------
# 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
}
set matrix ${claydict-b}
foreach {top children} ${claydict-a} {
  foreach {child value} $children {
    if {![dict exists $matrix $top $child]} {
      dict set matrix $top $child $value
    }
  }
}
#set testnum 0
foreach {top children} $matrix {
  foreach {child value} $children {
    set map {}
    dict set map %object1% OBJECTAB
    dict set map %object2% MIXINAB

    dict set map %top% $top
    dict set map %child% $child
    dict set map %value% $value
    dict set map %testnum% [format %04d [incr testnum]]
    putb result $map {
test oo-object-clay-method-native-%testnum% {Test native object gets the property %top%/%child%} {
  $%object1% clay get %top% %child%
} {%value%}
test oo-object-clay-method-mixin-%testnum% {Test mixin object gets the property %top%/%child%} {
  $%object2% clay get %top% %child%
} {%value%}
}
  }
}

putb result {# -------------------------------------------------------------------------
# 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
}
set matrix ${claydict-a}
foreach {top children} ${claydict-b} {
  foreach {child value} $children {
    if {![dict exists $matrix $top $child]} {
      dict set matrix $top $child $value
    }
  }
}
#set testnum 0
foreach {top children} $matrix {
  foreach {child value} $children {
    set map {}
    dict set map %object1% OBJECTBA
    dict set map %object2% MIXINBA

    dict set map %top% $top
    dict set map %child% $child
    dict set map %value% $value
    dict set map %testnum% [format %04d [incr testnum]]
    putb result $map {
test oo-object-clay-method-native-%testnum% {Test native object gets the property} {
  $%object1% clay get %top% %child%
} {%value%}
test oo-object-clay-method-mixin-%testnum% {Test mixin object gets the property} {
  $%object2% clay get %top% %child%
} {%value%}
}
  }
}

putb resut {
###
# Test local setting if clay data in an object
###
set OBJECT [::foo::classa new]
test oo-object-clay-method-local-0001 {Test native object gets the property} {
  $OBJECT clay get const/ color
} {blue}
test oo-object-clay-method-local-0002 {Test that local settings override the inherited properties} {
  $OBJECT clay set const/ color black
  $OBJECT clay set const/
} {black}

test oo-object-clay-method-local-0003 {Test native object gets an empty property} {
  $OBJECT clay get color
} {}
test oo-object-clay-method-local-0004 {Test that local settings override the empty property} {
  $OBJECT clay set color orange
  $OBJECT clay get color
} {orange}

}

putb result {
###
# 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 color aliases farbe
}

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

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

::clay::define ::TEST::species.cat {
  superclass ::TEST::animal
  clay sound 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
  }
}
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-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
}

set testnum 0

set matrix {
  go {
    OBJA 1
    OBJB 1
  }
  dance {
    OBJA 1
    OBJB 0
  }
}
foreach {action output} $matrix {
  putb result "# Test $action"
  foreach {object value} $output {
    set map [dict create %object% $object %action% $action %value% $value]
    dict set map %testnum% [format %04d [incr testnum]]
    putb result $map {test clay-dynamic-ensemble-%testnum% {Test ensemble with static method} {
  $%object% myensemble %action%
} {%value%}}
  }
}

putb result {

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

###
# Test clay mixinslots
###
putb result {

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
}
set testnum 0
set batnum  0

set obj {$obj}
set template {
test tool-prototype-%battery%-%test% {%comment%} {
  %obj% %method%
} {%answer%}
}
set map {}

dict set map %obj% {$obj}
dict set map %battery% [format %04d [incr batnum]]
dict set map %comment% {Mixin core}

foreach {method answer} {
  {info root} {MixinRoot}
  {info option} {Undefined}
  {info color} {Undefined}
  {info other} {Undefined}
  {info shade} {avacodo}
  {did} {MixinRoot}
  {path} {::MixinRoot ::clay::object}
  {clay get opts} {core root option unset color unset}
  {clay get opts core} root
  {clay get opts option} unset
  {clay get opts color} unset
  {clay ancestors} {::MixinRoot ::clay::object}
} {
  set testid [format %04d [incr testnum]]
  dict set map %test% $testid
  dict set map %method% $method
  dict set map %answer% $answer
  putb result $map $template
}

set testnum 0
putb result {$obj clay mixinmap option ::MixinOption1}
dict set map %battery% [format %04d [incr batnum]]
dict set map %comment% {Mixin option1}
foreach {method answer} {
  {info root} {MixinRoot}
  {info option} {MixinOption1}
  {info color} {Undefined}
  {info other} {MixinOption1}
  {info shade} {avacodo}
  {did} {MixinOption1}
  {path} {::MixinOption1 ::MixinRoot ::clay::object}
  {clay get opts} {option option1 core root color unset}
  {clay get opts core} root
  {clay get opts option} option1
  {clay get opts color} unset
  {clay ancestors} {::MixinOption1 ::MixinRoot ::clay::object}
} {
  set testid [format %04d [incr testnum]]
  dict set map %test% $testid
  dict set map %method% $method
  dict set map %answer% $answer
  putb result $map $template
}

set testnum 0
putb result {
set obj2 [clay::object new]
$obj2 clay mixinmap root ::MixinRoot option ::MixinOption1
}
putb result {$obj clay mixinmap option ::MixinOption1}
dict set map %obj% {$obj2}
dict set map %battery% [format %04d [incr batnum]]
dict set map %comment% {Mixin option1 - clean object}
foreach {method answer} {
  {info root} {MixinRoot}
  {info option} {MixinOption1}
  {info color} {Undefined}
  {info other} {MixinOption1}
  {info shade} {avacodo}
  {did} {MixinOption1}
  {path} {::MixinOption1 ::MixinRoot ::clay::object}
  {clay get opts} {option option1 core root color unset}
  {clay get opts core} root
  {clay get opts option} option1
  {clay get opts color} unset
  {clay ancestors} {::MixinOption1 ::MixinRoot ::clay::object}
} {
  set testid [format %04d [incr testnum]]
  dict set map %test% $testid
  dict set map %method% $method
  dict set map %answer% $answer
  putb result $map $template
}

set testnum 0
putb result {$obj clay mixinmap option ::MixinOption2}
dict set map %battery% [format %04d [incr batnum]]
dict set map %comment% {Mixin option2}
dict set map %obj% {$obj}
foreach {method answer} {
  {info root} {MixinRoot}
  {info option} {MixinOption2}
  {info color} {Undefined}
  {info other} {MixinOption1}
  {info shade} {avacodo}
  {did} {MixinOption2}
  {path} {::MixinOption2 ::MixinOption1 ::MixinRoot ::clay::object}
  {clay get opts} {option option2 core root color unset}
  {clay get opts core} root
  {clay get opts option} option2
  {clay get opts color} unset
  {clay ancestors} {::MixinOption2 ::MixinOption1 ::MixinRoot ::clay::object}
} {
  set testid [format %04d [incr testnum]]
  dict set map %test% $testid
  dict set map %method% $method
  dict set map %answer% $answer
  putb result $map $template
}

set testnum 0
putb result {$obj clay mixinmap color MixinColor1}
dict set map %battery% [format %04d [incr batnum]]
dict set map %comment% {Mixin color1}
foreach {method answer} {
  {info root} {MixinRoot}
  {info option} {MixinOption2}
  {info color} {MixinColor1}
  {info other} {MixinOption1}
  {info shade} {blue}
  {did} {MixinColor1}
  {path} {::MixinColor1 ::MixinOption2 ::MixinOption1 ::MixinRoot ::clay::object}
  {clay get opts} {color blue option option2 core root}
  {clay get opts core} root
  {clay get opts option} option2
  {clay get opts color} blue
  {clay ancestors} {::MixinColor1 ::MixinOption2 ::MixinOption1 ::MixinRoot ::clay::object}
} {
  set testid [format %04d [incr testnum]]
  dict set map %test% $testid
  dict set map %method% $method
  dict set map %answer% $answer
  putb result $map $template
}
set testnum 0
putb result {$obj clay mixinmap color MixinColor2}
dict set map %battery% [format %04d [incr batnum]]
dict set map %comment% {Mixin color2}
foreach {method answer} {
  {info root} {MixinRoot}
  {info option} {MixinOption2}
  {info color} {MixinColor2}
  {info other} {MixinOption1}
  {info shade} {green}
  {clay get opts} {color green option option2 core root}
  {clay get opts core} root
  {clay get opts option} option2
  {clay get opts color} green
  {clay ancestors} {::MixinColor2 ::MixinOption2 ::MixinOption1 ::MixinRoot ::clay::object}
} {
  set testid [format %04d [incr testnum]]
  dict set map %test% $testid
  dict set map %method% $method
  dict set map %answer% $answer
  putb result $map $template
}

set testnum 0
putb result {$obj clay mixinmap option MixinOption1}
dict set map %battery% [format %04d [incr batnum]]
dict set map %comment% {Mixin color2 + Option1}
foreach {method answer} {
  {info root} {MixinRoot}
  {info option} {MixinOption1}
  {info color} {MixinColor2}
  {info other} {MixinOption1}
  {info shade} {green}
  {clay get opts} {color green option option1 core root}
  {clay get opts core} root
  {clay get opts option} option1
  {clay get opts color} green
  {clay ancestors} {::MixinColor2 ::MixinOption1 ::MixinRoot ::clay::object}
} {
  set testid [format %04d [incr testnum]]
  dict set map %test% $testid
  dict set map %method% $method
  dict set map %answer% $answer
  putb result $map $template
}

set testnum 0
putb result {$obj clay mixinmap option {}}
dict set map %battery% [format %04d [incr batnum]]
dict set map %comment% {Mixin color2 + no option}
foreach {method answer} {
  {info root} {MixinRoot}
  {info option} {Undefined}
  {info color} {MixinColor2}
  {info other} {Undefined}
  {info shade} {green}
  {clay get opts} {color green core root option unset}
  {clay get opts core} root
  {clay get opts option} unset
  {clay get opts color} green
  {clay ancestors} {::MixinColor2 ::MixinRoot ::clay::object}
} {
  set testid [format %04d [incr testnum]]
  dict set map %test% $testid
  dict set map %method% $method
  dict set map %answer% $answer
  putb result $map $template
}

set testnum 0
putb result {$obj clay mixinmap color {}}
dict set map %battery% [format %04d [incr batnum]]
dict set map %comment% {Mixin core (return to normal)}
foreach {method answer} {
  {info root} {MixinRoot}
  {info option} {Undefined}
  {info color} {Undefined}
  {info other} {Undefined}
  {info shade} {avacodo}
  {clay get opts} {core root option unset color unset}
  {clay get opts core} root
  {clay get opts option} unset
  {clay get opts color} unset
  {clay ancestors} {::MixinRoot ::clay::object}
} {
  set testid [format %04d [incr testnum]]
  dict set map %test% $testid
  dict set map %method% $method
  dict set map %answer% $answer
  putb result $map $template
}

putb result {
###
# 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} \
  -errorCode NONE -body {
  $obj newitem id 2
} -result {shape is required}

###
# 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} \
  -errorCode NONE -body {
  $obj item new id 2
} -result {shape is required}

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

}

###
# TESTS NEEDED:
# destructor
###

putb result {
testsuiteCleanup

# Local variables:
# mode: tcl
# indent-tabs-mode: nil
# End:
}
return $result

###
# Adapted from tcllib module
#
# uuid.tcl - Copyright (C) 2004 Pat Thoyts <[email protected]>
#
# UUIDs are 128 bit values that attempt to be unique in time and space.
#
# Reference:
#   http://www.opengroup.org/dce/info/draft-leach-uuids-guids-01.txt
#
# uuid: scheme:
# http://www.globecom.net/ietf/draft/draft-kindel-uuid-uri-00.html
#
# Usage: clay::uuid generate
#        clay::uuid equal $idA $idB
namespace eval ::clay::uuid {
    namespace export uuid
}

###
# Optimization
# Caches machine info after the first pass
###

proc ::clay::uuid::generate_tcl_machinfo {} {
  variable machinfo
  if {[info exists machinfo]} {
    return $machinfo
  }
  lappend machinfo [clock seconds]; # timestamp
  lappend machinfo [clock clicks];  # system incrementing counter
  lappend machinfo [info hostname]; # spatial unique id (poor)
  lappend machinfo [pid];           # additional entropy
  lappend machinfo [array get ::tcl_platform]

  ###
  # If we have /dev/urandom just stream 128 bits from that
  ###
  if {[file exists /dev/urandom]} {
    set fin [open /dev/urandom r]
    binary scan [read $fin 128] H* machinfo
    close $fin
  } elseif {[catch {package require nettool}]} {
    # More spatial information -- better than hostname.
    # bug 1150714: opening a server socket may raise a warning messagebox
    #   with WinXP firewall, using ipconfig will return all IP addresses
    #   including ipv6 ones if available. ipconfig is OK on win98+
    if {[string equal $::tcl_platform(platform) "windows"]} {
      catch {exec ipconfig} config
      lappend machinfo $config
    } else {
      catch {
          set s [socket -server void -myaddr [info hostname] 0]
          ::clay::K [fconfigure $s -sockname] [close $s]
      } r
      lappend machinfo $r
    }

    if {[package provide Tk] != {}} {
      lappend machinfo [winfo pointerxy .]
      lappend machinfo [winfo id .]
    }
  } else {
    ###
    # If the nettool package works on this platform
    # use the stream of hardware ids from it
    ###
    lappend machinfo {*}[::nettool::hwid_list]
  }
  return $machinfo
}

# Generates a binary UUID as per the draft spec. We generate a pseudo-random
# type uuid (type 4). See section 3.4
#
if {[info commands irmmd5] ne {}} {
proc ::clay::uuid::generate {{type {}}} {
    variable nextuuid
    set s [irmmd5 "$type [incr nextuuid(type)] [generate_tcl_machinfo]"]
    foreach {a b} {0 7 8 11 12 15 16 19 20 31} {
         append r [string range $s $a $b] -
     }
     return [string tolower [string trimright $r -]]
}
proc ::clay::uuid::short {{type {}}} {
  variable nextuuid
  set r [irmmd5 "$type [incr nextuuid(type)] [generate_tcl_machinfo]"]
  return [string range $r 0 16]
}

} else {
package require md5 2
proc ::clay::uuid::raw {{type {}}} {
    variable nextuuid
    set tok [md5::MD5Init]
    md5::MD5Update $tok "$type [incr nextuuid($type)] [generate_tcl_machinfo]"
    set r [md5::MD5Final $tok]
    return [::clay::uuid::tostring $r]
}
proc ::clay::uuid::generate {{type {}}} {
    return [::clay::uuid::tostring [::clay::uuid::raw  $type]]
}
proc ::clay::uuid::short {{type {}}} {
  set r [::clay::uuid::raw $type]
  binary scan $r H* s
  return [string range $s 0 16]
}
}
proc ::clay::uuid::tostring {uuid} {
    binary scan $uuid H* s
    foreach {a b} {0 7 8 11 12 15 16 19 20 31} {
        append r [string range $s $a $b] -
    }
    return [string tolower [string trimright $r -]]
}
# Convert a string representation of a uuid into its binary format.
#
proc ::clay::uuid::fromstring {uuid} {
    return [binary format H* [string map {- {}} $uuid]]
}

# Compare two uuids for equality.
#
proc ::clay::uuid::equal {left right} {
    set l [fromstring $left]
    set r [fromstring $right]
    return [string equal $l $r]
}

# uuid generate -> string rep of a new uuid
# uuid equal uuid1 uuid2
#
proc ::clay::uuid {cmd args} {
    switch -exact -- $cmd {
        generate {
           return [::clay::uuid::generate {*}$args]
        }
        short {
          set uuid [::clay::uuid::short {*}$args]
        }
        equal {
            tailcall ::clay::uuid::equal {*}$args
        }
        default {
            return -code error "bad option \"$cmd\":\
                must be generate or equal"
        }
    }
}

[comment {-*- tcl -*- doctools manpage}]
[vset PACKAGE_VERSION 0.8]
[manpage_begin clay n [vset PACKAGE_VERSION]]
[keywords oo]
[copyright {2018 Sean Woods <[email protected]>}]
[moddesc   {Clay Framework}]
[titledesc {A minimalist framework for large scale OO Projects}]
[category  {Programming tools}]
[keywords TclOO]
[require Tcl 8.6]
[require uuid]
[require oo::dialect]
[description]
Clay introduces a method ensemble to both [class oo::class] and [class oo::object] called
clay. This ensemble handles all of the high level interactions within the framework.
Clay stores structured data. Clan manages method delegation. Clay has facilities to
manage the complex interactions that come about with mixins.
[para]
The central concept is that inside of every object and class
(which are actually objects too) is a dict called clay. What is stored in that dict is
left to the imagination. But because this dict is exposed via a public method, we can
share structured data between object, classes, and mixins.
[para]
[subsection {Structured Data}]
Clay uses a standardized set of method interactions and introspection that TclOO already provides to perform on-the-fly searches. On-the-fly searches mean that the data is never stale, and we avoid many of the sorts of collisions that would arise when objects start mixing in other classes during operation.
[para]
The [method clay] methods for both classes and objects have a get and a set method. For objects, get will search through the local clay dict. If the requested leaf is not found, or the query is for a branch, the system will then begin to poll the clay methods of all of the class that implements the object, all of that classes’ ancestors, as well as all of the classes that have been mixed into this object, and all of their ancestors.
[para]
Intended branches on a tree end with a directory slash (/). Intended leaves are left unadorned. This is a guide for the tool that builds the search
results to know what parts of a dict are intended to be branches and which are intended to be leaves.
For simple cases, branch marking can be ignored:
[example {
::oo::class create ::foo { }
::foo clay set property/ color blue
::foo clay set property/ shape round

set A [::foo new]
$A clay get property/
{color blue shape round}

$A clay set property/ shape square
$A clay get property/
{color blue shape square}
}]
[para]
But when you start storing blocks of text, guessing what field is a dict and what isn’t gets messy:
[example {
::foo clay set description {A generic thing of designated color and shape}

$A clay get description
{A generic thing of designated color and shape}

Without a convention for discerning branches for leaves what should have been a value can be accidentally parsed as a dictionary, and merged with all of the other values that were never intended to be merge. Here is an example of it all going wrong:
::oo::class create ::foo { }
# Add description as a leaf
::foo clay set description \
  {A generic thing of designated color and shape}
# Add description as a branch
::foo clay set description/ \
  {A generic thing of designated color and shape}

::oo::class create ::bar {
  superclass foo
}
# Add description as a leaf
::bar clay set description \
  {A drinking establishment of designated color and shape and size}
# Add description as a branch
::bar clay set description/ \
  {A drinking establishment of designated color and shape and size}

set B [::bar new]
# As a leaf we get the value verbatim from he nearest ancestor
$B clay get description
  {A drinking establishment of designated color and shape and size}
# As a branch we get a recursive merge
$B clay get description/
{A drinking establishment of designated color and size thing of}
}]
[subsection {Clay Dialect}]
Clay is built using the oo::dialect module from Tcllib. oo::dialect allows you to either add keywords directly to clay, or to create your own
metaclass and keyword set using Clay as a foundation. For details on the keywords and what they do, consult the functions in the ::clay::define namespace.
[subsection {Method Delegation}]
Method Delegation
It is sometimes useful to have an external object that can be invoked as if it were a method of the object. Clay provides a delegate ensemble method to perform that delegation, as well as introspect which methods are delegated in that manner. All delegated methods are marked with html-like tag markings (< >) around them.
[example {
::clay::define counter {
  Variable counter 0
  method incr {{howmuch 1}} {
    my variable counter
    incr counter $howmuch
  }
  method value {} {
    my variable counter
    return $counter
  }
  method reset {} {
    my variable counter
    set counter 0
  }
}
::clay::define example {
  variable buffer
  constructor {} {
    # Build a counter object
    set obj [namespace current]::counter
    ::counter create $obj
    # Delegate the counter
    my delegate <counter> $obj
  }
  method line {text} {
    my <counter> incr
    append buffer $text
  }
}

set A [example new]
$A line {Who’s line is it anyway?}
$A <counter> value
1
}]


[section {Commands}]
[list_begin definitions]
[call proc [cmd clay::PROC] [arg name] [arg arglist] [arg body] [opt "[arg ninja] [const ""]"]]

 Because many features in this package may be added as
 commands to future tcl cores, or be provided in binary
 form by packages, I need a declaritive way of saying
 [emph {Create this command if there isn't one already}].
 The [emph ninja] argument is a script to execute if the
 command is created by this mechanism.




[call proc [cmd clay::_ancestors] [arg resultvar] [arg class]]


[call proc [cmd clay::ancestors] [opt "[arg args]"]]


[call proc [cmd clay::args_to_dict] [opt "[arg args]"]]


[call proc [cmd clay::args_to_options] [opt "[arg args]"]]


[call proc [cmd clay::dynamic_arguments] [arg ensemble] [arg method] [arg arglist] [opt "[arg args]"]]



[call proc [cmd clay::dynamic_wrongargs_message] [arg arglist]]



[call proc [cmd clay::is_dict] [arg d]]


[call proc [cmd clay::is_null] [arg value]]


[call proc [cmd clay::leaf] [opt "[arg args]"]]


[call proc [cmd clay::K] [arg a] [arg b]]


[call proc [cmd clay::noop] [opt "[arg args]"]]

 Perform a noop. Useful in prototyping for commenting out blocks
 of code without actually having to comment them out. It also makes
 a handy default for method delegation if a delegate has not been
 assigned yet.



[call proc [cmd clay::path] [opt "[arg args]"]]


[call proc [cmd clay::putb] [opt "[arg map]"] [arg text]]

 Append a line of text to a variable. Optionally apply a string mapping.


[call proc [cmd clay::script_path]]


[call proc [cmd clay::NSNormalize] [arg qualname]]


[call proc [cmd clay::uuid_generate] [opt "[arg args]"]]


[call proc [cmd clay::uuid::generate_tcl_machinfo]]


[call proc [cmd clay::uuid::tostring] [arg uuid]]


[call proc [cmd clay::uuid::fromstring] [arg uuid]]
 Convert a string representation of a uuid into its binary format.




[call proc [cmd clay::uuid::equal] [arg left] [arg right]]
 Compare two uuids for equality.




[call proc [cmd clay::uuid] [arg cmd] [opt "[arg args]"]]
 uuid generate -> string rep of a new uuid
 uuid equal uuid1 uuid2




[call proc [cmd clay::tree::sanitize] [arg dict]]

 Output a dictionary removing any . entries added by [fun {clay::tree::merge}]




[call proc [cmd clay::tree::_sanitizeb] [arg path] [arg varname] [arg dict]]

 Helper function for ::clay::tree::sanitize
 Formats the string representation for a dictionary element within
 a human readable stream of lines, and determines if it needs to call itself
 with further indentation to express a sub-branch




[call proc [cmd clay::tree::storage] [arg rawpath]]

 Return the path as a storage path for clay::tree
 with all branch terminators removed.
 This command will also break arguments up if they
 contain /.

[para]Example: [example { > clay::tree::storage {foo bar baz bang}
 foo bar baz bang
 > clay::tree::storage {foo bar baz bang/}
 foo bar baz bang
 > clay::tree::storage {foo bar baz bang:}
 foo bar baz bang:
 > clay::tree::storage {foo/bar/baz bang:}
 foo bar baz bang:
 > clay::tree::storage {foo/bar/baz/bang}
 foo bar baz bang


}]

[call proc [cmd clay::tree::dictset] [arg varname] [opt "[arg args]"]]

 Set an element with a recursive dictionary,
 marking all branches on the way down to the
 final element.
 If the value does not exists in the nested dictionary
 it is added as a leaf. If the value already exists as a branch
 the value given is merged if the value is a valid dict. If the
 incoming value is not a valid dict, the value overrides the value
 stored, and the value is treated as a leaf from then on.

[para]Example: [example { > set r {}
 > ::clay::tree::dictset r option color default Green
 . {} option {. {} color {. {} default Green}}
 > ::clay::tree::dictset r option {Something not dictlike}
 . {} option {Something not dictlike}
 # Note that if the value is not a dict, and you try to force it to be
 # an error with be thrown on the merge
 > ::clay::tree::dictset r option color default Blue
 missing value to go with key


}]

[call proc [cmd clay::tree::dictmerge] [arg varname] [opt "[arg args]"]]

 A recursive form of dict merge, intended for modifying variables in place.

[para]Example: [example { > set mydict {sub/ {sub/ {description {a block of text}}}}
 > ::clay::tree::dictmerge mydict {sub/ {sub/ {field {another block of text}}}}]
 > clay::tree::print $mydict
 sub/ {
   sub/ {
     description {a block of text}
     field {another block of text}
   }
 }


}]

[call proc [cmd clay::tree::merge] [opt "[arg args]"]]

 A recursive form of dict merge
 [para]
 A routine to recursively dig through dicts and merge
 adapted from http://stevehavelka.com/tcl-dict-operation-nested-merge/

[para]Example: [example { > set mydict {sub/ {sub/ {description {a block of text}}}}
 > set odict [clay::tree::merge $mydict {sub/ {sub/ {field {another block of text}}}}]
 > clay::tree::print $odict
 sub/ {
   sub/ {
     description {a block of text}
     field {another block of text}
   }
 }


}]

[call proc [cmd dictargs::proc] [arg name] [arg argspec] [arg body]]

 Named Procedures as new command




[call proc [cmd dictargs::method] [arg name] [arg argspec] [arg body]]


[call proc [cmd clay::dialect::Push] [arg class]]


[call proc [cmd clay::dialect::Peek]]


[call proc [cmd clay::dialect::Pop]]


[call proc [cmd clay::dialect::create] [arg name] [opt "[arg parent] [const ""]"]]

 This proc will generate a namespace, a "mother of all classes", and a
 rudimentary set of policies for this dialect.




[call proc [cmd clay::dialect::NSNormalize] [arg namespace] [arg qualname]]
 Support commands; not intended to be called directly.



[call proc [cmd clay::dialect::DefineThunk] [arg target] [opt "[arg args]"]]


[call proc [cmd clay::dialect::Canonical] [arg namespace] [arg NSpace] [arg class]]


[call proc [cmd clay::dialect::Define] [arg namespace] [arg class] [opt "[arg args]"]]

 Implementation of the languages' define command




[call proc [cmd clay::dialect::Aliases] [arg namespace] [opt "[arg args]"]]


[call proc [cmd clay::dialect::SuperClass] [arg namespace] [opt "[arg args]"]]


[call proc [cmd clay::dynamic_methods] [arg class]]


[call proc [cmd clay::dynamic_methods_class] [arg thisclass]]


[call proc [cmd clay::define::Array] [arg name] [opt "[arg values] [const ""]"]]

 New OO Keywords for clay




[call proc [cmd clay::define::Delegate] [arg name] [arg info]]

 An annotation that objects of this class interact with delegated
 methods. The annotation is intended to be a dictionary, and the
 only reserved key is [emph {description}], a human readable description.




[call proc [cmd clay::define::constructor] [arg arglist] [arg rawbody]]



[call proc [cmd clay::define::Class_Method] [arg name] [arg arglist] [arg body]]

 Specify the a method for the class object itself, instead of for objects of the class




[call proc [cmd clay::define::class_method] [arg name] [arg arglist] [arg body]]

 And alias to the new Class_Method keyword




[call proc [cmd clay::define::clay] [opt "[arg args]"]]


[call proc [cmd clay::define::destructor] [arg rawbody]]



[call proc [cmd clay::define::Dict] [arg name] [opt "[arg values] [const ""]"]]


[call proc [cmd clay::define::Option] [arg name] [opt "[arg args]"]]

 Define an option for the class




[call proc [cmd clay::define::Method] [arg name] [arg argstyle] [arg argspec] [arg body]]


[call proc [cmd clay::define::Option_Class] [arg name] [opt "[arg args]"]]

 Define a class of options
 All field / value pairs will be be inherited by an option that
 specify [emph name] as it class field.




[call proc [cmd clay::define::Variable] [arg name] [opt "[arg default] [const ""]"]]

    This keyword can also be expressed:
    [example {property variable NAME {default DEFAULT}}]
    [para]
    Variables registered in the variable property are also initialized
    (if missing) when the object changes class via the [emph morph] method.




[call proc [cmd clay::object_create] [arg objname] [opt "[arg class] [const ""]"]]


[call proc [cmd clay::object_rename] [arg object] [arg newname]]


[call proc [cmd clay::object_destroy] [arg objname]]


[call proc [cmd clay::ensemble_methodbody] [arg ensemble] [arg einfo]]


[call proc [cmd clay::define::Ensemble] [arg rawmethod] [opt "[arg args]"]]


[call proc [cmd clay::destroy] [opt "[arg args]"]]

 Mark an object for destruction on the next cleanup




[call proc [cmd clay::cleanup]]

 Process the queue of objects to be destroyed




[call proc [cmd clay::event::cancel] [arg self] [opt "[arg task] [const "*"]"]]

Cancel a scheduled event




[call proc [cmd clay::event::generate] [arg self] [arg event] [opt "[arg args]"]]

    Generate an event
    Adds a subscription mechanism for objects
    to see who has recieved this event and prevent
    spamming or infinite recursion




[call proc [cmd clay::event::nextid]]



[call proc [cmd clay::event::Notification_list] [arg self] [arg event] [opt "[arg stackvar] [const ""]"]]

    Called recursively to produce a list of
    who recieves notifications




[call proc [cmd clay::event::notify] [arg rcpt] [arg sender] [arg event] [arg eventinfo]]

 Final delivery to intended recipient object




[call proc [cmd clay::event::process] [arg self] [arg handle] [arg script]]

 Evaluate an event script in the global namespace




[call proc [cmd clay::event::schedule] [arg self] [arg handle] [arg interval] [arg script]]

Schedule an event to occur later




[call proc [cmd clay::event::subscribe] [arg self] [arg who] [arg event]]

 Subscribe an object to an event pattern




[call proc [cmd clay::event::unsubscribe] [arg self] [opt "[arg args]"]]

 Unsubscribe an object from an event pattern




[list_end]

[section Classes]
[subsection {Class  clay::class}]

[para]
[class {Methods}]
[list_begin definitions]
[call method [cmd "clay ancestors"]]
Return this class and all ancestors in search order.

[call method [cmd "clay dump"]]
Return a complete dump of this object's clay data, but only this object's clay data.

[call method [cmd "clay find"] [arg path] [opt [option "path..."]]]

     Pull a chunk of data from the clay system. If the last element of [emph path] is a branch,
     returns a recursive merge of all data from this object and it's constituent classes of the data in that branch.
     If the last element is a leaf, search this object for a matching leaf, or search all  constituent classes for a matching
     leaf and return the first value found.
     If no value is found, returns an empty string.
     If a branch is returned the topmost . entry is omitted.
   

[call method [cmd "clay get"] [arg path] [opt [option "path..."]]]

     Pull a chunk of data from the class's clay system.
     If no value is found, returns an empty string.
     If a branch is returned the topmost . entry is omitted.
   

[call method [cmd "clay GET"] [arg path] [opt [option "path..."]]]

     Pull a chunk of data from the class's clay system.
     If no value is found, returns an empty string.
   

[call method [cmd "clay merge"] [arg dict] [opt [option "dict..."]]]
Recursively merge the dictionaries given into the object's local clay storage.

[call method [cmd "clay replace"] [arg dictionary]]
Replace the contents of the internal clay storage with the dictionary given.

[call method [cmd "clay search"] [arg path] [opt [option "path..."]]]
Return the first matching value for the path in either this class's clay data or one of its ancestors

[call method [cmd "clay set"] [arg path] [opt [option "path..."]] [arg value]]
Merge the conents of [const value] with the object's clay storage at [const path].

[list_end]
[para]

[subsection {Class  clay::object}]
 clay::object

 This class is inherited by all classes that have options.



[para]
[class {Methods}]
[list_begin definitions]
[call method [cmd "clay ancestors"]]
Return the class this object belongs to, all classes mixed into this object, and all ancestors of those classes in search order.

[call method [cmd "clay cget"] [arg field]]

 Pull a value from either the object's clay structure or one of its constituent classes that matches the field name.
 The order of search us:
 [para] 1. The as a value in local dict variable config
 [para] 2. The as a value in local dict variable clay
 [para] 3. As a leaf in any ancestor as a root of the clay tree
 [para] 4. As a leaf in any ancestor as [const const] [emph field]
 [para] 5. As a leaf in any ancestor as [const option] [emph field] [const default]
   

[call method [cmd "clay delegate"] [opt "[arg stub]"] [opt "[arg object]"]]

 Introspect or control method delegation. With no arguments, the method will return a
 key/value list of stubs and objects. With just the [arg stub] argument, the method will
 return the object (if any) attached to the stub. With a [arg stub] and an [arg object]
 this command will forward all calls to the method [arg stub] to the [arg object].
 

[call method [cmd "clay dump"]]
Return a complete dump of this object's clay data, as well as the data from all constituent classes recursively blended in.

[call method [cmd "clay ensemble_map"]]
Return a dictionary describing the method ensembles to be assembled for this object

[call method [cmd "clay eval"] [arg script]]
Evaluated a script in the namespace of this object

[call method [cmd "clay evolve"]]
Trigger the [method InitializePublic] private method

[call method [cmd "clay exists"] [arg path] [opt [option "path..."]]]
Returns 1 if [emph path] exists in either the object's clay data. Values greater than one indicate the element exists in one of the object's constituent classes. A value of zero indicates the path could not be found.

[call method [cmd "clay flush"]]
Wipe any caches built by the clay implementation

[call method [cmd "clay forward"] [arg method] [arg object]]
A convenience wrapper for
 [example {oo::objdefine [self] forward {*}$args}]
 

[call method [cmd "clay get"] [arg path] [opt [option "path..."]]]
Pull a chunk of data from the clay system. If the last element of [emph path] is a branch (ends in a slash /),
   returns a recursive merge of all data from this object and it's constituent classes of the data in that branch.
   If the last element is a leaf, search this object for a matching leaf, or search all  constituent classes for a matching
   leaf and return the first value found.
   If no value is found, returns an empty string.
 

[call method [cmd "clay leaf"] [arg path] [opt [option "path..."]]]
A modified get which is tailored to pull only leaf elements

[call method [cmd "clay merge"] [arg dict] [opt [option "dict..."]]]
Recursively merge the dictionaries given into the object's local clay storage.

[call method [cmd "clay mixin"] [arg class] [opt [option "class..."]]]

 Perform [lb]oo::objdefine [lb]self[rb] mixin[rb] on this object, with a few additional rules:
   Prior to the call, for any class was previously mixed in, but not in the new result, execute the script registered to mixin/ unmap-script (if given.)
   For all new classes, that were not present prior to this call, after the native TclOO mixin is invoked, execute the script registered to mixin/ map-script (if given.)
   Fall all classes that are now present and “mixed in”, execute the script registered to mixin/ react-script (if given.)
 

[call method [cmd "clay mixinmap"] [opt "[arg stub]"] [opt "[arg classes]"]]
With no arguments returns the map of stubs and classes mixed into the current object. When only stub is given,
  returns the classes mixed in on that stub. When stub and classlist given, replace the classes currently on that stub with the given
  classes and invoke clay mixin on the new matrix of mixed in classes.
 

[call method [cmd "clay provenance"] [arg path] [opt [option "path..."]]]
Return either [const self] if that path exists in the current object, or return the first class (if any) along the clay search path which contains that element.

[call method [cmd "clay replace"] [arg dictionary]]
Replace the contents of the internal clay storage with the dictionary given.

[call method [cmd "clay source"] [arg filename]]
Source the given filename within the object's namespace

[call method [cmd "clay set"] [arg path] [opt [option "path..."]] [arg value]]
Merge the conents of [const value] with the object's clay storage at [const path].

[call method [cmd "InitializePublic"]]

 Instantiate variables. Called on object creation and during clay mixin.




[list_end]
[para]

[section AUTHORS]
Sean Woods [uri mailto:<[email protected]>][para]
[vset CATEGORY oo]
[include ../doctools2base/include/feedback.inc]

[manpage_end]

###
# clay.tcl
#
# Copyright (c) 2018 Sean Woods
#
# BSD License
###
# @@ Meta Begin
# Package clay 0.8
# Meta platform     tcl
# Meta summary      A minimalist framework for complex TclOO development
# Meta description  This package introduces the method "clay" to both oo::object
# Meta description  and oo::class which facilitate complex interactions between objects
# Meta description  and their ancestor and mixed in classes.
# Meta category     TclOO
# Meta subject      framework
# Meta require      {Tcl 8.6}
# Meta author       Sean Woods
# Meta license      BSD
# @@ Meta End

###
# Amalgamated package for clay
# Do not edit directly, tweak the source in build/ and rerun
# build.tcl
###
package provide clay 0.8
namespace eval ::clay {}

###
# START: procs.tcl
###
namespace eval ::clay {
}
set ::clay::trace 0
proc ::clay::PROC {name arglist body {ninja {}}} {
  if {[info commands $name] ne {}} return
  proc $name $arglist $body
  eval $ninja
}
if {[info commands ::PROC] eq {}} {
  namespace eval ::clay { namespace export PROC }
  namespace eval :: { namespace import ::clay::PROC }
}
proc ::clay::_ancestors {resultvar class} {
  upvar 1 $resultvar result
  if {$class in $result} {
    return
  }
  lappend result $class
  foreach aclass [::info class superclasses $class] {
    _ancestors result $aclass
  }
}
proc ::clay::ancestors {args} {
  set result {}
  set queue  {}
  set metaclasses {}

  foreach class $args {
    set ancestors($class) {}
    _ancestors ancestors($class) $class
  }
  foreach class [lreverse $args] {
    foreach aclass $ancestors($class) {
      if {$aclass in $result} continue
      set skip 0
      foreach bclass $args {
        if {$class eq $bclass} continue
        if {$aclass in $ancestors($bclass)} {
          set skip 1
          break
        }
      }
      if {$skip} continue
      lappend result $aclass
    }
  }
  foreach class [lreverse $args] {
    foreach aclass $ancestors($class) {
      if {$aclass in $result} continue
      lappend result $aclass
    }
  }
  ###
  # Screen out classes that do not participate in clay
  # interactions
  ###
  set output {}
  foreach {item} $result {
    if {[catch {$item clay noop} err]} {
      continue
    }
    lappend output $item
  }
  return $output
}
proc ::clay::args_to_dict args {
  if {[llength $args]==1} {
    return [lindex $args 0]
  }
  return $args
}
proc ::clay::args_to_options args {
  set result {}
  foreach {var val} [args_to_dict {*}$args] {
    lappend result [string trim $var -:] $val
  }
  return $result
}
proc ::clay::dynamic_arguments {ensemble method arglist args} {
  set idx 0
  set len [llength $args]
  if {$len > [llength $arglist]} {
    ###
    # Catch if the user supplies too many arguments
    ###
    set dargs 0
    if {[lindex $arglist end] ni {args dictargs}} {
      return -code error -level 2 "Usage: $ensemble $method [string trim [dynamic_wrongargs_message $arglist]]"
    }
  }
  foreach argdef $arglist {
    if {$argdef eq "args"} {
      ###
      # Perform args processing in the style of tcl
      ###
      uplevel 1 [list set args [lrange $args $idx end]]
      break
    }
    if {$argdef eq "dictargs"} {
      ###
      # Perform args processing in the style of tcl
      ###
      uplevel 1 [list set args [lrange $args $idx end]]
      ###
      # Perform args processing in the style of clay
      ###
      set dictargs [::clay::args_to_options {*}[lrange $args $idx end]]
      uplevel 1 [list set dictargs $dictargs]
      break
    }
    if {$idx > $len} {
      ###
      # Catch if the user supplies too few arguments
      ###
      if {[llength $argdef]==1} {
        return -code error -level 2 "Usage: $ensemble $method [string trim [dynamic_wrongargs_message $arglist]]"
      } else {
        uplevel 1 [list set [lindex $argdef 0] [lindex $argdef 1]]
      }
    } else {
      uplevel 1 [list set [lindex $argdef 0] [lindex $args $idx]]
    }
    incr idx
  }
}
proc ::clay::dynamic_wrongargs_message {arglist} {
  set result ""
  set dargs 0
  foreach argdef $arglist {
    if {$argdef in {args dictargs}} {
      set dargs 1
      break
    }
    if {[llength $argdef]==1} {
      append result " $argdef"
    } else {
      append result " ?[lindex $argdef 0]?"
    }
  }
  if { $dargs } {
    append result " ?option value?..."
  }
  return $result
}
proc ::clay::is_dict { d } {
  # is it a dict, or can it be treated like one?
  if {[catch {::dict size $d} err]} {
    #::set ::errorInfo {}
    return 0
  }
  return 1
}
proc ::clay::is_null value {
  return [expr {$value in {{} NULL}}]
}
proc ::clay::leaf args {
  set marker [string index [lindex $args end] end]
  set result [path {*}${args}]
  if {$marker eq "/"} {
    return $result
  }
  return [list {*}[lrange $result 0 end-1] [string trim [string trim [lindex $result end]] /]]
}
proc ::clay::K {a b} {set a}
if {[info commands ::K] eq {}} {
  namespace eval ::clay { namespace export K }
  namespace eval :: { namespace import ::clay::K }
}
proc ::clay::noop args {}
if {[info commands ::noop] eq {}} {
  namespace eval ::clay { namespace export noop }
  namespace eval :: { namespace import ::clay::noop }
}
proc ::clay::path args {
  set result {}
  foreach item $args {
    set item [string trim $item :./]
    foreach subitem [split $item /] {
      lappend result [string trim ${subitem}]/
    }
  }
  return $result
}
proc ::clay::putb {buffername args} {
  upvar 1 $buffername buffer
  switch [llength $args] {
    1 {
      append buffer [lindex $args 0] \n
    }
    2 {
      append buffer [string map {*}$args] \n
    }
    default {
      error "usage: putb buffername ?map? string"
    }
  }
}
if {[info command ::putb] eq {}} {
  namespace eval ::clay { namespace export putb }
  namespace eval :: { namespace import ::clay::putb }
}
proc ::clay::script_path {} {
  set path [file dirname [file join [pwd] [info script]]]
  return $path
}
proc ::clay::NSNormalize qualname {
  if {![string match ::* $qualname]} {
    set qualname ::clay::classes::$qualname
  }
  regsub -all {::+} $qualname "::"
}
proc ::clay::uuid_generate args {
  return [uuid generate]
}
namespace eval ::clay {
  variable option_class {}
  variable core_classes {::oo::class ::oo::object}
}

###
# END: procs.tcl
###
###
# START: core.tcl
###
package require Tcl 8.6 ;# try in pipeline.tcl. Possibly other things.
if {[info commands irmmd5] eq {}} {
  if {[catch {package require odielibc}]} {
    package require md5 2
  }
}
::namespace eval ::clay {
}
::namespace eval ::clay::classes {
}
::namespace eval ::clay::define {
}
::namespace eval ::clay::tree {
}
::namespace eval ::clay::dict {
}
::namespace eval ::clay::list {
}
::namespace eval ::clay::uuid {
}
if {![info exists ::clay::idle_destroy]} {
  set ::clay::idle_destroy {}
}

###
# END: core.tcl
###
###
# START: uuid.tcl
###
namespace eval ::clay::uuid {
    namespace export uuid
}
proc ::clay::uuid::generate_tcl_machinfo {} {
  variable machinfo
  if {[info exists machinfo]} {
    return $machinfo
  }
  lappend machinfo [clock seconds]; # timestamp
  lappend machinfo [clock clicks];  # system incrementing counter
  lappend machinfo [info hostname]; # spatial unique id (poor)
  lappend machinfo [pid];           # additional entropy
  lappend machinfo [array get ::tcl_platform]

  ###
  # If we have /dev/urandom just stream 128 bits from that
  ###
  if {[file exists /dev/urandom]} {
    set fin [open /dev/urandom r]
    binary scan [read $fin 128] H* machinfo
    close $fin
  } elseif {[catch {package require nettool}]} {
    # More spatial information -- better than hostname.
    # bug 1150714: opening a server socket may raise a warning messagebox
    #   with WinXP firewall, using ipconfig will return all IP addresses
    #   including ipv6 ones if available. ipconfig is OK on win98+
    if {[string equal $::tcl_platform(platform) "windows"]} {
      catch {exec ipconfig} config
      lappend machinfo $config
    } else {
      catch {
          set s [socket -server void -myaddr [info hostname] 0]
          ::clay::K [fconfigure $s -sockname] [close $s]
      } r
      lappend machinfo $r
    }

    if {[package provide Tk] != {}} {
      lappend machinfo [winfo pointerxy .]
      lappend machinfo [winfo id .]
    }
  } else {
    ###
    # If the nettool package works on this platform
    # use the stream of hardware ids from it
    ###
    lappend machinfo {*}[::nettool::hwid_list]
  }
  return $machinfo
}
if {[info commands irmmd5] ne {}} {
proc ::clay::uuid::generate {{type {}}} {
    variable nextuuid
    set s [irmmd5 "$type [incr nextuuid(type)] [generate_tcl_machinfo]"]
    foreach {a b} {0 7 8 11 12 15 16 19 20 31} {
         append r [string range $s $a $b] -
     }
     return [string tolower [string trimright $r -]]
}
proc ::clay::uuid::short {{type {}}} {
  variable nextuuid
  set r [irmmd5 "$type [incr nextuuid(type)] [generate_tcl_machinfo]"]
  return [string range $r 0 16]
}

} else {
package require md5 2
proc ::clay::uuid::raw {{type {}}} {
    variable nextuuid
    set tok [md5::MD5Init]
    md5::MD5Update $tok "$type [incr nextuuid($type)] [generate_tcl_machinfo]"
    set r [md5::MD5Final $tok]
    return [::clay::uuid::tostring $r]
}
proc ::clay::uuid::generate {{type {}}} {
    return [::clay::uuid::tostring [::clay::uuid::raw  $type]]
}
proc ::clay::uuid::short {{type {}}} {
  set r [::clay::uuid::raw $type]
  binary scan $r H* s
  return [string range $s 0 16]
}
}
proc ::clay::uuid::tostring {uuid} {
    binary scan $uuid H* s
    foreach {a b} {0 7 8 11 12 15 16 19 20 31} {
        append r [string range $s $a $b] -
    }
    return [string tolower [string trimright $r -]]
}
proc ::clay::uuid::fromstring {uuid} {
    return [binary format H* [string map {- {}} $uuid]]
}
proc ::clay::uuid::equal {left right} {
    set l [fromstring $left]
    set r [fromstring $right]
    return [string equal $l $r]
}
proc ::clay::uuid {cmd args} {
    switch -exact -- $cmd {
        generate {
           return [::clay::uuid::generate {*}$args]
        }
        short {
          set uuid [::clay::uuid::short {*}$args]
        }
        equal {
            tailcall ::clay::uuid::equal {*}$args
        }
        default {
            return -code error "bad option \"$cmd\":\
                must be generate or equal"
        }
    }
}

###
# END: uuid.tcl
###
###
# START: dict.tcl
###
::clay::PROC ::tcl::dict::getnull {dictionary args} {
  if {[exists $dictionary {*}$args]} {
    get $dictionary {*}$args
  }
} {
  namespace ensemble configure dict -map [dict replace\
      [namespace ensemble configure dict -map] getnull ::tcl::dict::getnull]
}
::clay::PROC ::tcl::dict::is_dict { d } {
  # is it a dict, or can it be treated like one?
  if {[catch {dict size $d} err]} {
    #::set ::errorInfo {}
    return 0
  }
  return 1
} {
  namespace ensemble configure dict -map [dict replace\
      [namespace ensemble configure dict -map] is_dict ::tcl::dict::is_dict]
}
::clay::PROC ::tcl::dict::rmerge {args} {
  ::set result [dict create . {}]
  # Merge b into a, and handle nested dicts appropriately
  ::foreach b $args {
    for { k v } $b {
      ::set field [string trim $k :/]
      if {![::clay::tree::is_branch $b $k]} {
        # Element names that end in ":" are assumed to be literals
        set result $k $v
      } elseif { [exists $result $k] } {
        # key exists in a and b?  let's see if both values are dicts
        # both are dicts, so merge the dicts
        if { [is_dict [get $result $k]] && [is_dict $v] } {
          set result $k [rmerge [get $result $k] $v]
        } else {
          set result $k $v
        }
      } else {
        set result $k $v
      }
    }
  }
  return $result
} {
  namespace ensemble configure dict -map [dict replace\
      [namespace ensemble configure dict -map] rmerge ::tcl::dict::rmerge]
}
::clay::PROC ::clay::tree::is_branch { dict path } {
  set field [lindex $path end]
  if {[string index $field end] eq ":"} {
    return 0
  }
  if {[string index $field 0] eq "."} {
    return 0
  }
  if {[string index $field end] eq "/"} {
    return 1
  }
  return [dict exists $dict {*}$path .]
}
::clay::PROC ::clay::tree::print {dict} {
  ::set result {}
  ::set level -1
  ::clay::tree::_dictputb $level result $dict
  return $result
}
::clay::PROC ::clay::tree::_dictputb {level varname dict} {
  upvar 1 $varname result
  incr level
  dict for {field value} $dict {
    if {$field eq "."} continue
    if {[clay::tree::is_branch $dict $field]} {
      putb result "[string repeat "  " $level]$field \{"
      _dictputb $level result $value
      putb result "[string repeat "  " $level]\}"
    } else {
      putb result "[string repeat "  " $level][list $field $value]"
    }
  }
}
proc ::clay::tree::sanitize {dict} {
  ::set result {}
  ::set level -1
  ::clay::tree::_sanitizeb {} result $dict
  return $result
}
proc ::clay::tree::_sanitizeb {path varname dict} {
  upvar 1 $varname result
  dict for {field value} $dict {
    if {$field eq "."} continue
    if {[clay::tree::is_branch $dict $field]} {
      _sanitizeb [list {*}$path $field] result $value
    } else {
      dict set result {*}$path $field $value
    }
  }
}
proc ::clay::tree::storage {rawpath} {
  set isleafvar 0
  set path {}
  set tail [string index $rawpath end]
  foreach element $rawpath {
    set items [split [string trim $element /] /]
    foreach item $items {
      if {$item eq {}} continue
      lappend path $item
    }
  }
  return $path
}
proc ::clay::tree::dictset {varname args} {
  upvar 1 $varname result
  if {[llength $args] < 2} {
    error "Usage: ?path...? path value"
  } elseif {[llength $args]==2} {
    set rawpath [lindex $args 0]
  } else {
    set rawpath  [lrange $args 0 end-1]
  }
  set value [lindex $args end]
  set path [storage $rawpath]
  set dot .
  set one {}
  dict set result $dot $one
  set dpath {}
  foreach item [lrange $path 0 end-1] {
    set field $item
    lappend dpath [string trim $item /]
    dict set result {*}$dpath $dot $one
  }
  set field [lindex $rawpath end]
  set ext   [string index $field end]
  if {$ext eq {:} || ![dict is_dict $value]} {
    dict set result {*}$path $value
    return
  }
  if {$ext eq {/} && ![dict exists $result {*}$path $dot]} {
    dict set result {*}$path $dot $one
  }
  if {[dict exists $result {*}$path $dot]} {
    dict set result {*}$path [::clay::tree::merge [dict get $result {*}$path] $value]
    return
  }
  dict set result {*}$path $value
}
proc ::clay::tree::dictmerge {varname args} {
  upvar 1 $varname result
  set dot .
  set one {}
  dict set result $dot $one
  foreach dict $args {
    dict for {f v} $dict {
      set field [string trim $f /]
      set bbranch [clay::tree::is_branch $dict $f]
      if {![dict exists $result $field]} {
        dict set result $field $v
        if {$bbranch} {
          dict set result $field [clay::tree::merge $v]
        } else {
          dict set result $field $v
        }
      } elseif {[dict exists $result $field $dot]} {
        if {$bbranch} {
          dict set result $field [clay::tree::merge [dict get $result $field] $v]
        } else {
          dict set result $field $v
        }
      }
    }
  }
  return $result
}
proc ::clay::tree::merge {args} {
  ###
  # The result of a merge is always a dict with branches
  ###
  set dot .
  set one {}
  dict set result $dot $one
  set argument 0
  foreach b $args {
    # Merge b into a, and handle nested dicts appropriately
    if {![dict is_dict $b]} {
      error "Element $b is not a dictionary"
    }
    dict for { k v } $b {
      if {$k eq $dot} {
        dict set result $dot $one
        continue
      }
      set bbranch [is_branch $b $k]
      set field [string trim $k /]
      if { ![dict exists $result $field] } {
        if {$bbranch} {
          dict set result $field [merge $v]
        } else {
          dict set result $field $v
        }
      } else {
        set abranch [dict exists $result $field $dot]
        if {$abranch && $bbranch} {
          dict set result $field [merge [dict get $result $field] $v]
        } else {
          dict set result $field $v
          if {$bbranch} {
            dict set result $field $dot $one
          }
        }
      }
    }
  }
  return $result
}
::clay::PROC ::tcl::dict::isnull {dictionary args} {
  if {![exists $dictionary {*}$args]} {return 1}
  return [expr {[get $dictionary {*}$args] in {{} NULL null}}]
} {
  namespace ensemble configure dict -map [dict replace\
      [namespace ensemble configure dict -map] isnull ::tcl::dict::isnull]
}

###
# END: dict.tcl
###
###
# START: list.tcl
###
::clay::PROC ::clay::ladd {varname args} {
  upvar 1 $varname var
  if ![info exists var] {
      set var {}
  }
  foreach item $args {
    if {$item in $var} continue
    lappend var $item
  }
  return $var
}
::clay::PROC ::clay::ldelete {varname args} {
  upvar 1 $varname var
  if ![info exists var] {
      return
  }
  foreach item [lsort -unique $args] {
    while {[set i [lsearch $var $item]]>=0} {
      set var [lreplace $var $i $i]
    }
  }
  return $var
}
::clay::PROC ::clay::lrandom list {
  set len [llength $list]
  set idx [expr int(rand()*$len)]
  return [lindex $list $idx]
}

###
# END: list.tcl
###
###
# START: dictargs.tcl
###
namespace eval ::dictargs {
}
if {[info commands ::dictargs::parse] eq {}} {
  proc ::dictargs::parse {argdef argdict} {
    set result {}
    dict for {field info} $argdef {
      if {![string is alnum [string index $field 0]]} {
        error "$field is not a simple variable name"
      }
      upvar 1 $field _var
      set aliases {}
      if {[dict exists $argdict $field]} {
        set _var [dict get $argdict $field]
        continue
      }
      if {[dict exists $info aliases:]} {
        set found 0
        foreach {name} [dict get $info aliases:] {
          if {[dict exists $argdict $name]} {
            set _var [dict get $argdict $name]
            set found 1
            break
          }
        }
        if {$found} continue
      }
      if {[dict exists $info default:]} {
        set _var [dict get $info default:]
        continue
      }
      set mandatory 1
      if {[dict exists $info mandatory:]} {
        set mandatory [dict get $info mandatory:]
      }
      if {$mandatory} {
        error "$field is required"
      }
    }
  }
}
proc ::dictargs::proc {name argspec body} {
  set result {}
  append result "::dictargs::parse \{$argspec\} \$args" \;
  append result $body
  uplevel 1 [list ::proc $name [list [list args [list dictargs $argspec]]] $result]
}
proc ::dictargs::method {name argspec body} {
  set class [lindex [::info level -1] 1]
  set result {}
  append result "::dictargs::parse \{$argspec\} \$args" \;
  append result $body
  oo::define $class method $name [list [list args [list dictargs $argspec]]] $result
}

###
# END: dictargs.tcl
###
###
# START: dialect.tcl
###
namespace eval ::clay::dialect {
  namespace export create
  foreach {flag test} {
    tip470 {package vsatisfies [package provide Tcl] 8.7}
  } {
    if {![info exists ::clay::dialect::has($flag)]} {
      set ::clay::dialect::has($flag) [eval $test]
    }
  }
}
proc ::clay::dialect::Push {class} {
  ::variable class_stack
  lappend class_stack $class
}
proc ::clay::dialect::Peek {} {
  ::variable class_stack
  return [lindex $class_stack end]
}
proc ::clay::dialect::Pop {} {
  ::variable class_stack
  set class_stack [lrange $class_stack 0 end-1]
}
if {$::clay::dialect::has(tip470)} {
proc ::clay::dialect::current_class {} {
  return [uplevel 1 self]
}
} else {
proc ::clay::dialect::current_class {} {
  tailcall Peek
}
}
proc ::clay::dialect::create {name {parent ""}} {
  variable has
  set NSPACE [NSNormalize [uplevel 1 {namespace current}] $name]
  ::namespace eval $NSPACE {::namespace eval define {}}
  ###
  # Build the "define" namespace
  ###

  if {$parent eq ""} {
    ###
    # With no "parent" language, begin with all of the keywords in
    # oo::define
    ###
    foreach command [info commands ::oo::define::*] {
      set procname [namespace tail $command]
      interp alias {} ${NSPACE}::define::$procname {} \
        ::clay::dialect::DefineThunk $procname
    }
    # Create an empty dynamic_methods proc
    proc ${NSPACE}::dynamic_methods {class} {}
    namespace eval $NSPACE {
      ::namespace export dynamic_methods
      ::namespace eval define {::namespace export *}
    }
    set ANCESTORS {}
  } else {
    ###
    # If we have a parent language, that language already has the
    # [oo::define] keywords as well as additional keywords and behaviors.
    # We should begin with that
    ###
    set pnspace [NSNormalize [uplevel 1 {namespace current}] $parent]
    apply [list parent {
      ::namespace export dynamic_methods
      ::namespace import -force ${parent}::dynamic_methods
    } $NSPACE] $pnspace

    apply [list parent {
      ::namespace import -force ${parent}::define::*
      ::namespace export *
    } ${NSPACE}::define] $pnspace
      set ANCESTORS [list ${pnspace}::object]
  }
  ###
  # Build our dialect template functions
  ###
  proc ${NSPACE}::define {oclass args} [string map [list %NSPACE% $NSPACE] {
  ###
  # To facilitate library reloading, allow
  # a dialect to create a class from DEFINE
  ###
  set class [::clay::dialect::NSNormalize [uplevel 1 {namespace current}] $oclass]
    if {[info commands $class] eq {}} {
      %NSPACE%::class create $class {*}${args}
    } else {
      ::clay::dialect::Define %NSPACE% $class {*}${args}
    }
}]
  interp alias {} ${NSPACE}::define::current_class {} \
    ::clay::dialect::current_class
  interp alias {} ${NSPACE}::define::aliases {} \
    ::clay::dialect::Aliases $NSPACE
  interp alias {} ${NSPACE}::define::superclass {} \
    ::clay::dialect::SuperClass $NSPACE

  if {[info command ${NSPACE}::class] ne {}} {
    ::rename ${NSPACE}::class {}
  }
  ###
  # Build the metaclass for our language
  ###
  ::oo::class create ${NSPACE}::class {
    superclass ::clay::dialect::MotherOfAllMetaClasses
  }
  # Wire up the create method to add in the extra argument we need; the
  # MotherOfAllMetaClasses will know what to do with it.
  ::oo::objdefine ${NSPACE}::class \
    method create {name {definitionScript ""}} \
      "next \$name [list ${NSPACE}::define] \$definitionScript"

  ###
  # Build the mother of all classes. Note that $ANCESTORS is already
  # guaranteed to be a list in canonical form.
  ###
  uplevel #0 [string map [list %NSPACE% [list $NSPACE] %name% [list $name] %ANCESTORS% $ANCESTORS] {
    %NSPACE%::class create %NSPACE%::object {
     superclass %ANCESTORS%
      # Put MOACish stuff in here
    }
  }]
  if { "${NSPACE}::class" ni $::clay::dialect::core_classes } {
    lappend ::clay::dialect::core_classes "${NSPACE}::class"
  }
  if { "${NSPACE}::object" ni $::clay::dialect::core_classes } {
    lappend ::clay::dialect::core_classes "${NSPACE}::object"
  }
}
proc ::clay::dialect::NSNormalize {namespace qualname} {
  if {![string match ::* $qualname]} {
    set qualname ${namespace}::$qualname
  }
  regsub -all {::+} $qualname "::"
}
proc ::clay::dialect::DefineThunk {target args} {
  tailcall ::oo::define [Peek] $target {*}$args
}
proc ::clay::dialect::Canonical {namespace NSpace class} {
  namespace upvar $namespace cname cname
  #if {[string match ::* $class]} {
  #  return $class
  #}
  if {[info exists cname($class)]} {
    return $cname($class)
  }
  if {[info exists ::clay::dialect::cname($class)]} {
    return $::clay::dialect::cname($class)
  }
  if {[info exists ::clay::dialect::cname(${NSpace}::${class})]} {
    return $::clay::dialect::cname(${NSpace}::${class})
  }
  foreach item [list "${NSpace}::$class" "::$class"] {
    if {[info commands $item] ne {}} {
      return $item
    }
  }
  return ${NSpace}::$class
}
proc ::clay::dialect::Define {namespace class args} {
  Push $class
  try {
  	if {[llength $args]==1} {
      namespace eval ${namespace}::define [lindex $args 0]
    } else {
      ${namespace}::define::[lindex $args 0] {*}[lrange $args 1 end]
    }
  	${namespace}::dynamic_methods $class
  } finally {
    Pop
  }
}
proc ::clay::dialect::Aliases {namespace args} {
  set class [Peek]
  namespace upvar $namespace cname cname
  set NSpace [join [lrange [split $class ::] 1 end-2] ::]
  set cname($class) $class
  foreach name $args {
    set cname($name) $class
    #set alias $name
    set alias [NSNormalize $NSpace $name]
    # Add a local metaclass reference
    if {![info exists ::clay::dialect::cname($alias)]} {
      lappend ::clay::dialect::aliases($class) $alias
      ##
      # Add a global reference, first come, first served
      ##
      set ::clay::dialect::cname($alias) $class
    }
  }
}
proc ::clay::dialect::SuperClass {namespace args} {
  set class [Peek]
  namespace upvar $namespace class_info class_info
  dict set class_info($class) superclass 1
  set ::clay::dialect::cname($class) $class
  set NSpace [join [lrange [split $class ::] 1 end-2] ::]
  set unique {}
  foreach item $args {
    set Item [Canonical $namespace $NSpace $item]
    dict set unique $Item $item
  }
  set root ${namespace}::object
  if {$class ne $root} {
    dict set unique $root $root
  }
  tailcall ::oo::define $class superclass {*}[dict keys $unique]
}
if {[info command ::clay::dialect::MotherOfAllMetaClasses] eq {}} {
::oo::class create ::clay::dialect::MotherOfAllMetaClasses {
  superclass ::oo::class
  constructor {define definitionScript} {
    $define [self] {
      superclass
    }
    $define [self] $definitionScript
  }
  method aliases {} {
    if {[info exists ::clay::dialect::aliases([self])]} {
      return $::clay::dialect::aliases([self])
    }
  }
}
}
namespace eval ::clay::dialect {
  variable core_classes {::oo::class ::oo::object}
}

###
# END: dialect.tcl
###
###
# START: metaclass.tcl
###
::clay::dialect::create ::clay
proc ::clay::dynamic_methods class {
  foreach command [info commands [namespace current]::dynamic_methods_*] {
    $command $class
  }
}
proc ::clay::dynamic_methods_class {thisclass} {
  set methods {}
  set mdata [$thisclass clay find class_typemethod]
  foreach {method info} $mdata {
    if {$method eq {.}} continue
    set method [string trimright $method :/-]
    if {$method in $methods} continue
    lappend methods $method
    set arglist [dict getnull $info arglist]
    set body    [dict getnull $info body]
    ::oo::objdefine $thisclass method $method $arglist $body
  }
}
proc ::clay::define::Array {name {values {}}} {
  set class [current_class]
  set name [string trim $name :/]
  $class clay branch array $name
  dict for {var val} $values {
    $class clay set array/ $name $var $val
  }
}
proc ::clay::define::Delegate {name info} {
  set class [current_class]
  foreach {field value} $info {
    $class clay set component/ [string trim $name :/]/ $field $value
  }
}
proc ::clay::define::constructor {arglist rawbody} {
  set body {
my variable DestroyEvent
set DestroyEvent 0
::clay::object_create [self] [info object class [self]]
# Initialize public variables and options
my InitializePublic
  }
  append body $rawbody
  set class [current_class]
  ::oo::define $class constructor $arglist $body
}
proc ::clay::define::Class_Method {name arglist body} {
  set class [current_class]
  $class clay set class_typemethod/ [string trim $name :/] [dict create arglist $arglist body $body]
}
proc ::clay::define::class_method {name arglist body} {
  set class [current_class]
  $class clay set class_typemethod/ [string trim $name :/] [dict create arglist $arglist body $body]
}
proc ::clay::define::clay {args} {
  set class [current_class]
  if {[lindex $args 0] in "cget set branch"} {
    $class clay {*}$args
  } else {
    $class clay set {*}$args
  }
}
proc ::clay::define::destructor rawbody {
  set body {
# Run the destructor once and only once
set self [self]
my variable DestroyEvent
if {$DestroyEvent} return
set DestroyEvent 1
::clay::object_destroy $self
}
  append body $rawbody
  ::oo::define [current_class] destructor $body
}
proc ::clay::define::Dict {name {values {}}} {
  set class [current_class]
  set name [string trim $name :/]
  $class clay branch dict $name
  foreach {var val} $values {
    $class clay set dict/ $name/ $var $val
  }
}
proc ::clay::define::Option {name args} {
  set class [current_class]
  set dictargs {default {}}
  foreach {var val} [::clay::args_to_dict {*}$args] {
    dict set dictargs [string trim $var -:/] $val
  }
  set name [string trimleft $name -]

  ###
  # Option Class handling
  ###
  set optclass [dict getnull $dictargs class]
  if {$optclass ne {}} {
    foreach {f v} [$class clay find option_class $optclass] {
      if {![dict exists $dictargs $f]} {
        dict set dictargs $f $v
      }
    }
    if {$optclass eq "variable"} {
      variable $name [dict getnull $dictargs default]
    }
  }
  foreach {f v} $dictargs {
    $class clay set option $name $f $v
  }
}
proc ::clay::define::Method {name argstyle argspec body} {
  set class [current_class]
  set result {}
  switch $argstyle {
    dictargs {
      append result "::dictargs::parse \{$argspec\} \$args" \;
    }
  }
  append result $body
  oo::define $class method $name [list [list args [list dictargs $argspec]]] $result
}
proc ::clay::define::Option_Class {name args} {
  set class [current_class]
  set dictargs {default {}}
  set name [string trimleft $name -:]
  foreach {f v} [::clay::args_to_dict {*}$args] {
    $class clay set option_class $name [string trim $f -/:] $v
  }
}
proc ::clay::define::Variable {name {default {}}} {
  set class [current_class]
  set name [string trimright $name :/]
  $class clay set variable/ $name $default
}
proc ::clay::object_create {objname {class {}}} {
  #if {$::clay::trace>0} {
  #  puts [list $objname CREATE]
  #}
}
proc ::clay::object_rename {object newname} {
  if {$::clay::trace>0} {
    puts [list $object RENAME -> $newname]
  }
}
proc ::clay::object_destroy objname {
  if {$::clay::trace>0} {
    puts [list $objname DESTROY]
  }
  #::cron::object_destroy $objname
}

###
# END: metaclass.tcl
###
###
# START: ensemble.tcl
###
::namespace eval ::clay::define {
}
proc ::clay::ensemble_methodbody {ensemble einfo} {
  set default standard
  set preamble {}
  set eswitch {}
  if {[dict exists $einfo default]} {
    set emethodinfo [dict get $einfo default]
    set argspec     [dict getnull $emethodinfo argspec]
    set realbody    [dict getnull $emethodinfo body]
    set argstyle    [dict getnull $emethodinfo argstyle]
    if {$argstyle eq "dictargs"} {
      set body "\n      ::dictargs::parse \{$argspec\} \$args"
    } elseif {[llength $argspec]==1 && [lindex $argspec 0] in {{} args arglist}} {
      set body {}
    } else {
      set body "\n      ::clay::dynamic_arguments $ensemble \$method [list $argspec] {*}\$args"
    }
    append body "\n      " [string trim $realbody] "      \n"
    set default $body
    dict unset einfo default
  }
  foreach {msubmethod esubmethodinfo} [lsort -dictionary -stride 2 $einfo] {
    set submethod [string trim $msubmethod :/-]
    if {$submethod eq "_body"} continue
    if {$submethod eq "_preamble"} {
      set preamble [dict getnull $esubmethodinfo body]
      continue
    }
    set argspec     [dict getnull $esubmethodinfo argspec]
    set realbody    [dict getnull $esubmethodinfo body]
    set argstyle    [dict getnull $esubmethodinfo argstyle]
    if {[string length [string trim $realbody]] eq {}} {
      dict set eswitch $submethod {}
    } else {
      if {$argstyle eq "dictargs"} {
        set body "\n      ::dictargs::parse \{$argspec\} \$args"
      } elseif {[llength $argspec]==1 && [lindex $argspec 0] in {{} args arglist}} {
        set body {}
      } else {
        set body "\n      ::clay::dynamic_arguments $ensemble \$method [list $argspec] {*}\$args"
      }
      append body "\n      " [string trim $realbody] "      \n"
      if {$submethod eq "default"} {
        set default $body
      } else {
        foreach alias [dict getnull $esubmethodinfo aliases] {
          dict set eswitch $alias -
        }
        dict set eswitch $submethod $body
      }
    }
  }
  set methodlist [lsort -dictionary [dict keys $eswitch]]
  if {![dict exists $eswitch <list>]} {
    dict set eswitch <list> {return $methodlist}
  }
  if {$default eq "standard"} {
    set default "error \"unknown method $ensemble \$method. Valid: \$methodlist\""
  }
  dict set eswitch default $default
  set mbody {}

  append mbody $preamble \n

  append mbody \n [list set methodlist $methodlist]
  append mbody \n "set code \[catch {switch -- \$method [list $eswitch]} result opts\]"
  append mbody \n {return -options $opts $result}
  return $mbody
}
::proc ::clay::define::Ensemble {rawmethod args} {
  if {[llength $args]==2} {
    lassign $args argspec body
    set argstyle tcl
  } elseif {[llength $args]==3} {
    lassign $args argstyle argspec body
  } else {
    error "Usage: Ensemble name ?argstyle? argspec body"
  }
  set class [current_class]
  #if {$::clay::trace>2} {
  #  puts [list $class Ensemble $rawmethod $argspec $body]
  #}
  set mlist [split $rawmethod "::"]
  set ensemble [string trim [lindex $mlist 0] :/]
  set mensemble ${ensemble}/
  if {[llength $mlist]==1 || [lindex $mlist 1] in "_body"} {
    set method _body
    ###
    # Simple method, needs no parsing, but we do need to record we have one
    ###
    if {$argstyle eq "dictargs"} {
      set argspec [list args $argspec]
    }
    $class clay set method_ensemble/ $mensemble _body [dict create argspec $argspec body $body argstyle $argstyle]
    if {$::clay::trace>2} {
      puts [list $class clay set method_ensemble/ $mensemble _body ...]
    }
    set method $rawmethod
    if {$::clay::trace>2} {
      puts [list $class Ensemble $rawmethod $argspec $body]
      set rawbody $body
      set body {puts [list [self] $class [self method]]}
      append body \n $rawbody
    }
    if {$argstyle eq "dictargs"} {
      set rawbody $body
      set body "::dictargs::parse \{$argspec\} \$args\; "
      append body $rawbody
    }
    ::oo::define $class method $rawmethod $argspec $body
    return
  }
  set method [join [lrange $mlist 2 end] "::"]
  $class clay set method_ensemble/ $mensemble [string trim [lindex $method 0] :/] [dict create argspec $argspec body $body argstyle $argstyle]
  if {$::clay::trace>2} {
    puts [list $class clay set method_ensemble/ $mensemble [string trim $method :/]  ...]
  }
}

###
# END: ensemble.tcl
###
###
# START: class.tcl
###
::oo::define ::clay::class {
  method clay {submethod args} {
    my variable clay
    if {![info exists clay]} {
      set clay {}
    }
    switch $submethod {
      ancestors {
        tailcall ::clay::ancestors [self]
      }
      branch {
        set path [::clay::tree::storage $args]
        if {![dict exists $clay {*}$path .]} {
          dict set clay {*}$path . {}
        }
      }
      exists {
        if {![info exists clay]} {
          return 0
        }
        set path [::clay::tree::storage $args]
        if {[dict exists $clay {*}$path]} {
          return 1
        }
        if {[dict exists $clay {*}[lrange $path 0 end-1] [lindex $path end]:]} {
          return 1
        }
        return 0
      }
      dump {
        return $clay
      }
      dget {
         if {![info exists clay]} {
          return {}
        }
        set path [::clay::tree::storage $args]
        if {[dict exists $clay {*}$path]} {
          return [dict get $clay {*}$path]
        }
        if {[dict exists $clay {*}[lrange $path 0 end-1] [lindex $path end]:]} {
          return [dict get $clay {*}[lrange $path 0 end-1] [lindex $path end]:]
        }
        return {}
      }
      is_branch {
        set path [::clay::tree::storage $args]
        return [dict exists $clay {*}$path .]
      }
      getnull -
      get {
        if {![info exists clay]} {
          return {}
        }
        set path [::clay::tree::storage $args]
        if {[llength $path]==0} {
          return $clay
        }
        if {[dict exists $clay {*}$path .]} {
          return [::clay::tree::sanitize [dict get $clay {*}$path]]
        }
        if {[dict exists $clay {*}$path]} {
          return [dict get $clay {*}$path]
        }
        if {[dict exists $clay {*}[lrange $path 0 end-1] [lindex $path end]:]} {
          return [dict get $clay {*}[lrange $path 0 end-1] [lindex $path end]:]
        }
        return {}
      }
      find {
        set path [::clay::tree::storage $args]
        if {![info exists clay]} {
          set clay {}
        }
        set clayorder [::clay::ancestors [self]]
        set found 0
        if {[llength $path]==0} {
          set result [dict create . {}]
          foreach class $clayorder {
            ::clay::tree::dictmerge result [$class clay dump]
          }
          return [::clay::tree::sanitize $result]
        }
        foreach class $clayorder {
          if {[$class clay exists {*}$path .]} {
            # Found a branch break
            set found 1
            break
          }
          if {[$class clay exists {*}$path]} {
            # Found a leaf. Return that value immediately
            return [$class clay get {*}$path]
          }
          if {[dict exists $clay {*}[lrange $path 0 end-1] [lindex $path end]:]} {
            return [dict get $clay {*}[lrange $path 0 end-1] [lindex $path end]:]
          }
        }
        if {!$found} {
          return {}
        }
        set result {}
        # Leaf searches return one data field at a time
        # Search in our local dict
        # Search in the in our list of classes for an answer
        foreach class [lreverse $clayorder] {
          ::clay::tree::dictmerge result [$class clay dget {*}$path]
        }
        return [::clay::tree::sanitize $result]
      }
      merge {
        foreach arg $args {
          ::clay::tree::dictmerge clay {*}$arg
        }
      }
      noop {
        # Do nothing. Used as a sign of clay savviness
      }
      search {
        foreach aclass [::clay::ancestors [self]] {
          if {[$aclass clay exists {*}$args]} {
            return [$aclass clay get {*}$args]
          }
        }
      }
      set {
        ::clay::tree::dictset clay {*}$args
      }
      unset {
        dict unset clay {*}$args
      }
      default {
        dict $submethod clay {*}$args
      }
    }
  }
}

###
# END: class.tcl
###
###
# START: object.tcl
###
::oo::define ::clay::object {
  method clay {submethod args} {
    my variable clay claycache clayorder config option_canonical
    if {![info exists clay]} {set clay {}}
    if {![info exists claycache]} {set claycache {}}
    if {![info exists config]} {set config {}}
    if {![info exists clayorder] || [llength $clayorder]==0} {
      set clayorder {}
      if {[dict exists $clay cascade]} {
        dict for {f v} [dict get $clay cascade] {
          if {$f eq "."} continue
          if {[info commands $v] ne {}} {
            lappend clayorder $v
          }
        }
      }
      lappend clayorder {*}[::clay::ancestors [info object class [self]] {*}[lreverse [info object mixins [self]]]]
    }
    switch $submethod {
      ancestors {
        return $clayorder
      }
      branch {
        set path [::clay::tree::storage $args]
        if {![dict exists $clay {*}$path .]} {
          dict set clay {*}$path . {}
        }
      }
      cget {
        # Leaf searches return one data field at a time
        # Search in our local dict
        if {[llength $args]==1} {
          set field [string trim [lindex $args 0] -:/]
          if {[info exists option_canonical($field)]} {
            set field $option_canonical($field)
          }
          if {[dict exists $config $field]} {
            return [dict get $config $field]
          }
        }
        set path [::clay::tree::storage $args]
        if {[dict exists $clay {*}$path]} {
          return [dict get $clay {*}$path]
        }
        # Search in our local cache
        if {[dict exists $claycache {*}$path]} {
          if {[dict exists $claycache {*}$path .]} {
            return [dict remove [dict get $claycache {*}$path] .]
          } else {
            return [dict get $claycache {*}$path]
          }
        }
        # Search in the in our list of classes for an answer
        foreach class $clayorder {
          if {[$class clay exists {*}$path]} {
            set value [$class clay get {*}$path]
            dict set claycache {*}$path $value
            return $value
          }
          if {[$class clay exists const {*}$path]} {
            set value [$class clay get const {*}$path]
            dict set claycache {*}$path $value
            return $value
          }
          if {[$class clay exists option {*}$path default]} {
            set value [$class clay get option {*}$path default]
            dict set claycache {*}$path $value
            return $value
          }
        }
        return {}
      }
      delegate {
        if {![dict exists $clay .delegate <class>]} {
          dict set clay .delegate <class> [info object class [self]]
        }
        if {[llength $args]==0} {
          return [dict get $clay .delegate]
        }
        if {[llength $args]==1} {
          set stub <[string trim [lindex $args 0] <>]>
          if {![dict exists $clay .delegate $stub]} {
            return {}
          }
          return [dict get $clay .delegate $stub]
        }
        if {([llength $args] % 2)} {
          error "Usage: delegate
    OR
    delegate stub
    OR
    delegate stub OBJECT ?stub OBJECT? ..."
        }
        foreach {stub object} $args {
          set stub <[string trim $stub <>]>
          dict set clay .delegate $stub $object
          oo::objdefine [self] forward ${stub} $object
          oo::objdefine [self] export ${stub}
        }
      }
      dump {
        # Do a full dump of clay data
        set result {}
        # Search in the in our list of classes for an answer
        foreach class $clayorder {
          ::clay::tree::dictmerge result [$class clay dump]
        }
        ::clay::tree::dictmerge result $clay
        return $result
      }
      ensemble_map {
        set ensemble [lindex $args 0]
        my variable claycache
        set mensemble [string trim $ensemble :/]
        if {[dict exists $claycache method_ensemble $mensemble]} {
          return [clay::tree::sanitize [dict get $claycache method_ensemble $mensemble]]
        }
        set emap [my clay dget method_ensemble $mensemble]
        dict set claycache method_ensemble $mensemble $emap
        return [clay::tree::sanitize $emap]
      }
      eval {
        set script [lindex $args 0]
        set buffer {}
        set thisline {}
        foreach line [split $script \n] {
          append thisline $line
          if {![info complete $thisline]} {
            append thisline \n
            continue
          }
          set thisline [string trim $thisline]
          if {[string index $thisline 0] eq "#"} continue
          if {[string length $thisline]==0} continue
          if {[lindex $thisline 0] eq "my"} {
            # Line already calls out "my", accept verbatim
            append buffer $thisline \n
          } elseif {[string range $thisline 0 2] eq "::"} {
            # Fully qualified commands accepted verbatim
            append buffer $thisline \n
          } elseif {
            append buffer "my $thisline" \n
          }
          set thisline {}
        }
        eval $buffer
      }
      evolve -
      initialize {
        my InitializePublic
      }
      exists {
        # Leaf searches return one data field at a time
        # Search in our local dict
        set path [::clay::tree::storage $args]
        if {[dict exists $clay {*}$path]} {
          return 1
        }
        # Search in our local cache
        if {[dict exists $claycache {*}$path]} {
          return 2
        }
        set count 2
        # Search in the in our list of classes for an answer
        foreach class $clayorder {
          incr count
          if {[$class clay exists {*}$path]} {
            return $count
          }
        }
        return 0
      }
      flush {
        set claycache {}
        set clayorder [::clay::ancestors [info object class [self]] {*}[lreverse [info object mixins [self]]]]
      }
      forward {
        oo::objdefine [self] forward {*}$args
      }
      dget {
        set path [::clay::tree::storage $args]
        if {[llength $path]==0} {
          # Do a full dump of clay data
          set result {}
          # Search in the in our list of classes for an answer
          foreach class $clayorder {
            ::clay::tree::dictmerge result [$class clay dump]
          }
          ::clay::tree::dictmerge result $clay
          return $result
        }
        # Search in our local cache
        if {[dict exists $claycache {*}$path .]} {
          return [dict get $claycache {*}$path]
        }
        if {[dict exists $claycache {*}$path]} {
          return [dict get $claycache {*}$path]
        }
        if {[dict exists $clay {*}$path] && ![dict exists $clay {*}$path .]} {
          # Path is a leaf
          return [dict get $clay {*}$path]
        }
        set found 0
        set branch [dict exists $clay {*}$path .]
        foreach class $clayorder {
          if {[$class clay exists {*}$path .]} {
            set found 1
            break
          }
          if {!$branch && [$class clay exists {*}$path]} {
            set result [$class clay dget {*}$path]
            dict set claycache {*}$path $result
            return $result
          }
        }
        # Path is a branch
        set result [dict getnull $clay {*}$path]
        foreach class $clayorder {
          if {![$class clay exists {*}$path .]} continue
          ::clay::tree::dictmerge result [$class clay dget {*}$path]
        }
        #if {[dict exists $clay {*}$path .]} {
        #  ::clay::tree::dictmerge result
        #}
        dict set claycache {*}$path $result
        return $result
      }
      getnull -
      get {
        set path [::clay::tree::storage $args]
        if {[llength $path]==0} {
          # Do a full dump of clay data
          set result {}
          # Search in the in our list of classes for an answer
          foreach class $clayorder {
            ::clay::tree::dictmerge result [$class clay dump]
          }
          ::clay::tree::dictmerge result $clay
          return [::clay::tree::sanitize $result]
        }
        # Search in our local cache
        if {[dict exists $claycache {*}$path .]} {
          return [::clay::tree::sanitize [dict get $claycache {*}$path]]
        }
        if {[dict exists $claycache {*}$path]} {
          return [dict get $claycache {*}$path]
        }
        if {[dict exists $clay {*}$path] && ![dict exists $clay {*}$path .]} {
          # Path is a leaf
          return [dict get $clay {*}$path]
        }
        set found 0
        set branch [dict exists $clay {*}$path .]
        foreach class $clayorder {
          if {[$class clay exists {*}$path .]} {
            set found 1
            break
          }
          if {!$branch && [$class clay exists {*}$path]} {
            set result [$class clay dget {*}$path]
            dict set claycache {*}$path $result
            return $result
          }
        }
        # Path is a branch
        set result [dict getnull $clay {*}$path]
        #foreach class [lreverse $clayorder] {
        #  if {![$class clay exists {*}$path .]} continue
        #  ::clay::tree::dictmerge result [$class clay dget {*}$path]
        #}
        foreach class $clayorder {
          if {![$class clay exists {*}$path .]} continue
          ::clay::tree::dictmerge result [$class clay dget {*}$path]
        }
        #if {[dict exists $clay {*}$path .]} {
        #  ::clay::tree::dictmerge result [dict get $clay {*}$path]
        #}
        dict set claycache {*}$path $result
        return [clay::tree::sanitize $result]
      }
      leaf {
        # Leaf searches return one data field at a time
        # Search in our local dict
        set path [::clay::tree::storage $args]
        if {[dict exists $clay {*}$path .]} {
          return [clay::tree::sanitize [dict get $clay {*}$path]]
        }
        if {[dict exists $clay {*}$path]} {
          return [dict get $clay {*}$path]
        }
        # Search in our local cache
        if {[dict exists $claycache {*}$path .]} {
          return [clay::tree::sanitize [dict get $claycache {*}$path]]
        }
        if {[dict exists $claycache {*}$path]} {
          return [dict get $claycache {*}$path]
        }
        # Search in the in our list of classes for an answer
        foreach class $clayorder {
          if {[$class clay exists {*}$path]} {
            set value [$class clay get {*}$path]
            dict set claycache {*}$path $value
            return $value
          }
        }
      }
      merge {
        foreach arg $args {
          ::clay::tree::dictmerge clay {*}$arg
        }
      }
      mixin {
        ###
        # Mix in the class
        ###
        set prior  [info object mixins [self]]
        set newmixin {}
        foreach item $args {
          lappend newmixin ::[string trimleft $item :]
        }
        set newmap $args
        foreach class $prior {
          if {$class ni $newmixin} {
            set script [$class clay search mixin/ unmap-script]
            if {[string length $script]} {
              if {[catch $script err errdat]} {
                puts stderr "[self] MIXIN ERROR POPPING $class:\n[dict get $errdat -errorinfo]"
              }
            }
          }
        }
        ::oo::objdefine [self] mixin {*}$args
        ###
        # Build a compsite map of all ensembles defined by the object's current
        # class as well as all of the classes being mixed in
        ###
        my InitializePublic
        foreach class $newmixin {
          if {$class ni $prior} {
            set script [$class clay search mixin/ map-script]
            if {[string length $script]} {
              if {[catch $script err errdat]} {
                puts stderr "[self] MIXIN ERROR PUSHING $class:\n[dict get $errdat -errorinfo]"
              }
            }
          }
        }
        foreach class $newmixin {
          set script [$class clay search mixin/ react-script]
          if {[string length $script]} {
            if {[catch $script err errdat]} {
              puts stderr "[self] MIXIN ERROR PEEKING $class:\n[dict get $errdat -errorinfo]"
            }
            break
          }
        }
      }
      mixinmap {
        my variable clay
        if {![dict exists $clay .mixin]} {
          dict set clay .mixin {}
        }
        if {[llength $args]==0} {
          return [dict get $clay .mixin]
        } elseif {[llength $args]==1} {
          return [dict getnull $clay .mixin [lindex $args 0]]
        } else {
          dict for {slot classes} $args {
            dict set clay .mixin $slot $classes
          }
          set classlist {}
          dict for {item class} [dict get $clay .mixin] {
            if {$class ne {}} {
              lappend classlist $class
            }
          }
          my clay mixin {*}[lreverse $classlist]
        }
      }
      provenance {
        if {[dict exists $clay {*}$args]} {
          return self
        }
        foreach class $clayorder {
          if {[$class clay exists {*}$args]} {
            return $class
          }
        }
        return {}
      }
      replace {
        set clay [lindex $args 0]
      }
      source {
        source [lindex $args 0]
      }
      set {
        #puts [list [self] clay SET {*}$args]
        set claycache {}
        ::clay::tree::dictset clay {*}$args
      }
      default {
        dict $submethod clay {*}$args
      }
    }
  }
  method InitializePublic {} {
    my variable clayorder clay claycache config option_canonical
    set claycache {}
    set clayorder [::clay::ancestors [info object class [self]] {*}[lreverse [info object mixins [self]]]]
    if {![info exists clay]} {
      set clay {}
    }
    if {![info exists config]} {
      set config {}
    }
    dict for {var value} [my clay get variable] {
      if { $var in {. clay} } continue
      set var [string trim $var :/]
      my variable $var
      if {![info exists $var]} {
        if {$::clay::trace>2} {puts [list initialize variable $var $value]}
        set $var $value
      }
    }
    dict for {var value} [my clay get dict/] {
      if { $var in {. clay} } continue
      set var [string trim $var :/]
      my variable $var
      if {![info exists $var]} {
        set $var {}
      }
      foreach {f v} $value {
        if {$f eq "."} continue
        if {![dict exists ${var} $f]} {
          if {$::clay::trace>2} {puts [list initialize dict $var $f $v]}
          dict set ${var} $f $v
        }
      }
    }
    foreach {var value} [my clay get array/] {
      if { $var in {. clay} } continue
      set var [string trim $var :/]
      if { $var eq {clay} } continue
      my variable $var
      if {![info exists $var]} { array set $var {} }
      foreach {f v} $value {
        if {![array exists ${var}($f)]} {
          if {$f eq "."} continue
          if {$::clay::trace>2} {puts [list initialize array $var\($f\) $v]}
          set ${var}($f) $v
        }
      }
    }
    foreach {field info} [my clay get option/] {
      if { $field in {. clay} } continue
      set field [string trim $field -/:]
      foreach alias [dict getnull $info aliases] {
        set option_canonical($alias) $field
      }
      if {[dict exists $config $field]} continue
      set getcmd [dict getnull $info default-command]
      if {$getcmd ne {}} {
        set value [{*}[string map [list %field% $field %self% [namespace which my]] $getcmd]]
      } else {
        set value [dict getnull $info default]
      }
      dict set config $field $value
      set setcmd [dict getnull $info set-command]
      if {$setcmd ne {}} {
        {*}[string map [list %field% [list $field] %value% [list $value] %self% [namespace which my]] $setcmd]
      }
    }
    my variable clayorder clay claycache
    if {[info exists clay]} {
      set emap [dict getnull $clay method_ensemble]
    } else {
      set emap {}
    }
    foreach class [lreverse $clayorder] {
      ###
      # Build a compsite map of all ensembles defined by the object's current
      # class as well as all of the classes being mixed in
      ###
      dict for {mensemble einfo} [$class clay get method_ensemble] {
        if {$mensemble eq {.}} continue
        set ensemble [string trim $mensemble :/]
        if {$::clay::trace>2} {puts [list Defining $ensemble from $class]}

        dict for {method info} $einfo {
          if {$method eq {.}} continue
          if {![dict is_dict $info]} {
            puts [list WARNING: class: $class method: $method not dict: $info]
            continue
          }
          dict set info source $class
          if {$::clay::trace>2} {puts [list Defining $ensemble -> $method from $class - $info]}
          dict set emap $ensemble $method $info
        }
      }
    }
    foreach {ensemble einfo} $emap {
      #if {[dict exists $einfo _body]} continue
      set body [::clay::ensemble_methodbody $ensemble $einfo]
      if {$::clay::trace>2} {
        set rawbody $body
        set body {puts [list [self] <object> [self method]]}
        append body \n $rawbody
      }
      oo::objdefine [self] method $ensemble {{method default} args} $body
    }
  }
}
::clay::object clay branch array
::clay::object clay branch mixin
::clay::object clay branch option
::clay::object clay branch dict clay
::clay::object clay set variable DestroyEvent 0

###
# END: object.tcl
###
###
# START: event.tcl
###
::namespace eval ::clay::event {
}
proc ::clay::destroy args {
  if {![info exists ::clay::idle_destroy]} {
    set ::clay::idle_destroy {}
  }
  foreach object $args {
    if {$object in $::clay::idle_destroy} continue
    lappend ::clay::idle_destroy  $object
  }
}
proc ::clay::cleanup {} {
  if {![info exists ::clay::idle_destroy]} return
  foreach obj $::clay::idle_destroy {
    if {[info commands $obj] ne {}} {
      catch {$obj destroy}
    }
  }
  set ::clay::idle_destroy {}
}
proc ::clay::event::cancel {self {task *}} {
  variable timer_event
  variable timer_script

  foreach {id event} [array get timer_event $self:$task] {
    ::after cancel $event
    set timer_event($id) {}
    set timer_script($id) {}
  }
}
proc ::clay::event::generate {self event args} {
  set wholist [Notification_list $self $event]
  if {$wholist eq {}} return
  set dictargs [::oo::meta::args_to_options {*}$args]
  set info $dictargs
  set strict 0
  set debug 0
  set sender $self
  dict with dictargs {}
  dict set info id     [::clay::event::nextid]
  dict set info origin $self
  dict set info sender $sender
  dict set info rcpt   {}
  foreach who $wholist {
    catch {::clay::event::notify $who $self $event $info}
  }
}
proc ::clay::event::nextid {} {
  return "event#[format %0.8x [incr ::clay::event_count]]"
}
proc ::clay::event::Notification_list {self event {stackvar {}}} {
  set notify_list {}
  foreach {obj patternlist} [array get ::clay::object_subscribe] {
    if {$obj eq $self} continue
    if {$obj in $notify_list} continue
    set match 0
    foreach {objpat eventlist} $patternlist {
      if {![string match $objpat $self]} continue
      foreach eventpat $eventlist {
        if {![string match $eventpat $event]} continue
        set match 1
        break
      }
      if {$match} {
        break
      }
    }
    if {$match} {
      lappend notify_list $obj
    }
  }
  return $notify_list
}
proc ::clay::event::notify {rcpt sender event eventinfo} {
  if {[info commands $rcpt] eq {}} return
  if {$::clay::trace} {
    puts [list event notify rcpt $rcpt sender $sender event $event info $eventinfo]
  }
  $rcpt notify $event $sender $eventinfo
}
proc ::clay::event::process {self handle script} {
  variable timer_event
  variable timer_script

  array unset timer_event $self:$handle
  array unset timer_script $self:$handle

  set err [catch {uplevel #0 $script} result errdat]
  if $err {
    puts "BGError: $self $handle $script
ERR: $result
[dict get $errdat -errorinfo]
***"
  }
}
proc ::clay::event::schedule {self handle interval script} {
  variable timer_event
  variable timer_script
  if {$::clay::trace} {
    puts [list $self schedule $handle $interval]
  }
  if {[info exists timer_event($self:$handle)]} {
    if {$script eq $timer_script($self:$handle)} {
      return
    }
    ::after cancel $timer_event($self:$handle)
  }
  set timer_script($self:$handle) $script
  set timer_event($self:$handle) [::after $interval [list ::clay::event::process $self $handle $script]]
}
proc ::clay::event::subscribe {self who event} {
  upvar #0 ::clay::object_subscribe($self) subscriptions
  if {![info exists subscriptions]} {
    set subscriptions {}
  }
  set match 0
  foreach {objpat eventlist} $subscriptions {
    if {![string match $objpat $who]} continue
    foreach eventpat $eventlist {
      if {[string match $eventpat $event]} {
        # This rule already exists
        return
      }
    }
  }
  dict lappend subscriptions $who $event
}
proc ::clay::event::unsubscribe {self args} {
  upvar #0 ::clay::object_subscribe($self) subscriptions
  if {![info exists subscriptions]} {
    return
  }
  switch [llength $args] {
    1 {
      set event [lindex $args 0]
      if {$event eq "*"} {
        # Shortcut, if the
        set subscriptions {}
      } else {
        set newlist {}
        foreach {objpat eventlist} $subscriptions {
          foreach eventpat $eventlist {
            if {[string match $event $eventpat]} continue
            dict lappend newlist $objpat $eventpat
          }
        }
        set subscriptions $newlist
      }
    }
    2 {
      set who [lindex $args 0]
      set event [lindex $args 1]
      if {$who eq "*" && $event eq "*"} {
        set subscriptions {}
      } else {
        set newlist {}
        foreach {objpat eventlist} $subscriptions {
          if {[string match $who $objpat]} {
            foreach eventpat $eventlist {
              if {[string match $event $eventpat]} continue
              dict lappend newlist $objpat $eventpat
            }
          }
        }
        set subscriptions $newlist
      }
    }
  }
}

###
# END: event.tcl
###

namespace eval ::clay {
  namespace export *
}