TEA (tclconfig) Source Code

Check-in [8171d2845f]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Updating Practcl from tcllib
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | practcl
Files: files | file ages | folders
SHA3-256: 8171d2845fa2e9c6659ec8af935c2ab697b80a594c93dbeca182276f40f0a083
User & Date: hypnotoad 2018-12-05 15:31:56
Context
2019-07-25
21:48
Updated Practcl from clay Leaf check-in: 9904f168a6 user: hypnotoad tags: practcl
2018-12-05
15:31
Updating Practcl from tcllib check-in: 8171d2845f user: hypnotoad tags: practcl
2018-10-28
06:50
Fixed a typo in practcl. Tweak to ensure inside of the practcl::module class that the make_object dict exists check-in: 64bde17a6d user: hypnotoad tags: practcl
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Changes to practcl.tcl.

     1      1   ###
     2      2   # Amalgamated package for practcl
     3      3   # Do not edit directly, tweak the source in src/ and rerun
     4      4   # build.tcl
     5      5   ###
     6      6   package require Tcl 8.6
     7         -package provide practcl 0.15
            7  +package provide practcl 0.16
     8      8   namespace eval ::practcl {}
     9      9   
    10     10   ###
    11     11   # START: httpwget/wget.tcl
    12     12   ###
    13     13   package provide http::wget 0.1
    14     14   package require http
................................................................................
    53     53   
    54     54   ###
    55     55   # END: httpwget/wget.tcl
    56     56   ###
    57     57   ###
    58     58   # START: clay/clay.tcl
    59     59   ###
    60         -package provide clay 0.6
    61         -namespace eval ::clay {
    62         -}
    63         -package require Tcl 8.5
    64         -namespace eval uuid {
    65         -    variable accel
    66         -    array set accel {critcl 0}
    67         -    namespace export uuid
    68         -    variable uid
    69         -    if {![info exists uid]} {
    70         -        set uid 1
    71         -    }
    72         -    proc K {a b} {set a}
    73         -}
    74         -proc ::uuid::generate_tcl_machinfo {} {
    75         -  variable machinfo
    76         -  if {[info exists machinfo]} {
    77         -    return $machinfo
    78         -  }
    79         -  lappend machinfo [clock seconds]; # timestamp
    80         -  lappend machinfo [clock clicks];  # system incrementing counter
    81         -  lappend machinfo [info hostname]; # spatial unique id (poor)
    82         -  lappend machinfo [pid];           # additional entropy
    83         -  lappend machinfo [array get ::tcl_platform]
    84         -
    85         -  ###
    86         -  # If we have /dev/urandom just stream 128 bits from that
    87         -  ###
    88         -  if {[file exists /dev/urandom]} {
    89         -    set fin [open /dev/urandom r]
    90         -    binary scan [read $fin 128] H* machinfo
    91         -    close $fin
    92         -  } elseif {[catch {package require nettool}]} {
    93         -    # More spatial information -- better than hostname.
    94         -    # bug 1150714: opening a server socket may raise a warning messagebox
    95         -    #   with WinXP firewall, using ipconfig will return all IP addresses
    96         -    #   including ipv6 ones if available. ipconfig is OK on win98+
    97         -    if {[string equal $::tcl_platform(platform) "windows"]} {
    98         -      catch {exec ipconfig} config
    99         -      lappend machinfo $config
   100         -    } else {
   101         -      catch {
   102         -          set s [socket -server void -myaddr [info hostname] 0]
   103         -          K [fconfigure $s -sockname] [close $s]
   104         -      } r
   105         -      lappend machinfo $r
   106         -    }
   107         -
   108         -    if {[package provide Tk] != {}} {
   109         -      lappend machinfo [winfo pointerxy .]
   110         -      lappend machinfo [winfo id .]
   111         -    }
   112         -  } else {
   113         -    ###
   114         -    # If the nettool package works on this platform
   115         -    # use the stream of hardware ids from it
   116         -    ###
   117         -    lappend machinfo {*}[::nettool::hwid_list]
   118         -  }
   119         -  return $machinfo
   120         -}
   121         -proc ::uuid::generate_tcl {} {
   122         -    package require md5 2
   123         -    variable uid
   124         -
   125         -    set tok [md5::MD5Init]
   126         -    md5::MD5Update $tok [incr uid];      # package incrementing counter
   127         -    foreach string [generate_tcl_machinfo] {
   128         -      md5::MD5Update $tok $string
   129         -    }
   130         -    set r [md5::MD5Final $tok]
   131         -    binary scan $r c* r
   132         -
   133         -    # 3.4: set uuid versioning fields
   134         -    lset r 8 [expr {([lindex $r 8] & 0x3F) | 0x80}]
   135         -    lset r 6 [expr {([lindex $r 6] & 0x0F) | 0x40}]
   136         -
   137         -    return [binary format c* $r]
   138         -}
   139         -if {[string equal $tcl_platform(platform) "windows"]
   140         -        && [package provide critcl] != {}} {
   141         -    namespace eval uuid {
   142         -        critcl::ccode {
   143         -            #define WIN32_LEAN_AND_MEAN
   144         -            #define STRICT
   145         -            #include <windows.h>
   146         -            #include <ole2.h>
   147         -            typedef long (__stdcall *LPFNUUIDCREATE)(UUID *);
   148         -            typedef const unsigned char cu_char;
   149         -        }
   150         -        critcl::cproc generate_c {Tcl_Interp* interp} ok {
   151         -            HRESULT hr = S_OK;
   152         -            int r = TCL_OK;
   153         -            UUID uuid = {0};
   154         -            HMODULE hLib;
   155         -            LPFNUUIDCREATE lpfnUuidCreate = NULL;
   156         -            hLib = LoadLibraryA(("rpcrt4.dll"));
   157         -            if (hLib)
   158         -                lpfnUuidCreate = (LPFNUUIDCREATE)
   159         -                    GetProcAddress(hLib, "UuidCreate");
   160         -            if (lpfnUuidCreate) {
   161         -                Tcl_Obj *obj;
   162         -                lpfnUuidCreate(&uuid);
   163         -                obj = Tcl_NewByteArrayObj((cu_char *)&uuid, sizeof(uuid));
   164         -                Tcl_SetObjResult(interp, obj);
   165         -            } else {
   166         -                Tcl_SetResult(interp, "error: failed to create a guid",
   167         -                              TCL_STATIC);
   168         -                r = TCL_ERROR;
   169         -            }
   170         -            return r;
   171         -        }
   172         -    }
   173         -}
   174         -proc ::uuid::tostring {uuid} {
   175         -    binary scan $uuid H* s
   176         -    foreach {a b} {0 7 8 11 12 15 16 19 20 end} {
   177         -        append r [string range $s $a $b] -
   178         -    }
   179         -    return [string tolower [string trimright $r -]]
   180         -}
   181         -proc ::uuid::fromstring {uuid} {
   182         -    return [binary format H* [string map {- {}} $uuid]]
   183         -}
   184         -proc ::uuid::equal {left right} {
   185         -    set l [fromstring $left]
   186         -    set r [fromstring $right]
   187         -    return [string equal $l $r]
   188         -}
   189         -proc ::uuid::generate {} {
   190         -    variable accel
   191         -    if {$accel(critcl)} {
   192         -        return [generate_c]
   193         -    } else {
   194         -        return [generate_tcl]
   195         -    }
   196         -}
   197         -proc uuid::uuid {cmd args} {
   198         -    switch -exact -- $cmd {
   199         -        generate {
   200         -            if {[llength $args] != 0} {
   201         -                return -code error "wrong # args:\
   202         -                    should be \"uuid generate\""
   203         -            }
   204         -            return [tostring [generate]]
   205         -        }
   206         -        equal {
   207         -            if {[llength $args] != 2} {
   208         -                return -code error "wrong \# args:\
   209         -                    should be \"uuid equal uuid1 uuid2\""
   210         -            }
   211         -            return [eval [linsert $args 0 equal]]
   212         -        }
   213         -        default {
   214         -            return -code error "bad option \"$cmd\":\
   215         -                must be generate or equal"
   216         -        }
   217         -    }
   218         -}
   219         -proc ::uuid::LoadAccelerator {name} {
   220         -    variable accel
   221         -    set r 0
   222         -    switch -exact -- $name {
   223         -        critcl {
   224         -            if {![catch {package require tcllibc}]} {
   225         -                set r [expr {[info commands ::uuid::generate_c] != {}}]
   226         -            }
   227         -        }
   228         -        default {
   229         -            return -code error "invalid accelerator package:\
   230         -                must be one of [join [array names accel] {, }]"
   231         -        }
   232         -    }
   233         -    set accel($name) $r
   234         -}
   235         -namespace eval ::uuid {
   236         -    variable e {}
   237         -    foreach e {critcl} {
   238         -        if {[LoadAccelerator $e]} break
   239         -    }
   240         -    unset e
   241         -}
   242         -package provide uuid 1.0.7
   243         -namespace eval ::oo::dialect {
   244         -  namespace export create
   245         -}
   246         -foreach {flag test} {
   247         -  tip470 {package vsatisfies [package provide Tcl] 8.7}
   248         -} {
   249         -  if {![info exists ::oo::dialect::has($flag)]} {
   250         -    set ::oo::dialect::has($flag) [eval $test]
   251         -  }
   252         -}
   253         -proc ::oo::dialect::Push {class} {
   254         -  ::variable class_stack
   255         -  lappend class_stack $class
   256         -}
   257         -proc ::oo::dialect::Peek {} {
   258         -  ::variable class_stack
   259         -  return [lindex $class_stack end]
   260         -}
   261         -proc ::oo::dialect::Pop {} {
   262         -  ::variable class_stack
   263         -  set class_stack [lrange $class_stack 0 end-1]
   264         -}
   265         -if {$::oo::dialect::has(tip470)} {
   266         -proc ::oo::dialect::current_class {} {
   267         -  return [uplevel 1 self]
   268         -}
   269         -} else {
   270         -proc ::oo::dialect::current_class {} {
   271         -  tailcall Peek
   272         -}
   273         -}
   274         -proc ::oo::dialect::create {name {parent ""}} {
   275         -  variable has
   276         -  set NSPACE [NSNormalize [uplevel 1 {namespace current}] $name]
   277         -  ::namespace eval $NSPACE {::namespace eval define {}}
   278         -  ###
   279         -  # Build the "define" namespace
   280         -  ###
   281         -
   282         -  if {$parent eq ""} {
   283         -    ###
   284         -    # With no "parent" language, begin with all of the keywords in
   285         -    # oo::define
   286         -    ###
   287         -    foreach command [info commands ::oo::define::*] {
   288         -      set procname [namespace tail $command]
   289         -      interp alias {} ${NSPACE}::define::$procname {} \
   290         -        ::oo::dialect::DefineThunk $procname
   291         -    }
   292         -    # Create an empty dynamic_methods proc
   293         -    proc ${NSPACE}::dynamic_methods {class} {}
   294         -    namespace eval $NSPACE {
   295         -      ::namespace export dynamic_methods
   296         -      ::namespace eval define {::namespace export *}
   297         -    }
   298         -    set ANCESTORS {}
   299         -  } else {
   300         -    ###
   301         -    # If we have a parent language, that language already has the
   302         -    # [oo::define] keywords as well as additional keywords and behaviors.
   303         -    # We should begin with that
   304         -    ###
   305         -    set pnspace [NSNormalize [uplevel 1 {namespace current}] $parent]
   306         -    apply [list parent {
   307         -      ::namespace export dynamic_methods
   308         -      ::namespace import -force ${parent}::dynamic_methods
   309         -    } $NSPACE] $pnspace
   310         -
   311         -    apply [list parent {
   312         -      ::namespace import -force ${parent}::define::*
   313         -      ::namespace export *
   314         -    } ${NSPACE}::define] $pnspace
   315         -      set ANCESTORS [list ${pnspace}::object]
   316         -  }
   317         -  ###
   318         -  # Build our dialect template functions
   319         -  ###
   320         -  proc ${NSPACE}::define {oclass args} [string map [list %NSPACE% $NSPACE] {
   321         -  ###
   322         -  # To facilitate library reloading, allow
   323         -  # a dialect to create a class from DEFINE
   324         -  ###
   325         -  set class [::oo::dialect::NSNormalize [uplevel 1 {namespace current}] $oclass]
   326         -    if {[info commands $class] eq {}} {
   327         -      %NSPACE%::class create $class {*}${args}
   328         -    } else {
   329         -      ::oo::dialect::Define %NSPACE% $class {*}${args}
   330         -    }
   331         -}]
   332         -  interp alias {} ${NSPACE}::define::current_class {} \
   333         -    ::oo::dialect::current_class
   334         -  interp alias {} ${NSPACE}::define::aliases {} \
   335         -    ::oo::dialect::Aliases $NSPACE
   336         -  interp alias {} ${NSPACE}::define::superclass {} \
   337         -    ::oo::dialect::SuperClass $NSPACE
   338         -
   339         -  if {[info command ${NSPACE}::class] ne {}} {
   340         -    ::rename ${NSPACE}::class {}
   341         -  }
   342         -  ###
   343         -  # Build the metaclass for our language
   344         -  ###
   345         -  ::oo::class create ${NSPACE}::class {
   346         -    superclass ::oo::dialect::MotherOfAllMetaClasses
   347         -  }
   348         -  # Wire up the create method to add in the extra argument we need; the
   349         -  # MotherOfAllMetaClasses will know what to do with it.
   350         -  ::oo::objdefine ${NSPACE}::class \
   351         -    method create {name {definitionScript ""}} \
   352         -      "next \$name [list ${NSPACE}::define] \$definitionScript"
   353         -
   354         -  ###
   355         -  # Build the mother of all classes. Note that $ANCESTORS is already
   356         -  # guaranteed to be a list in canonical form.
   357         -  ###
   358         -  uplevel #0 [string map [list %NSPACE% [list $NSPACE] %name% [list $name] %ANCESTORS% $ANCESTORS] {
   359         -    %NSPACE%::class create %NSPACE%::object {
   360         -     superclass %ANCESTORS%
   361         -      # Put MOACish stuff in here
   362         -    }
   363         -  }]
   364         -  if { "${NSPACE}::class" ni $::oo::dialect::core_classes } {
   365         -    lappend ::oo::dialect::core_classes "${NSPACE}::class"
   366         -  }
   367         -  if { "${NSPACE}::object" ni $::oo::dialect::core_classes } {
   368         -    lappend ::oo::dialect::core_classes "${NSPACE}::object"
   369         -  }
   370         -}
   371         -proc ::oo::dialect::NSNormalize {namespace qualname} {
   372         -  if {![string match ::* $qualname]} {
   373         -    set qualname ${namespace}::$qualname
   374         -  }
   375         -  regsub -all {::+} $qualname "::"
   376         -}
   377         -proc ::oo::dialect::DefineThunk {target args} {
   378         -  tailcall ::oo::define [Peek] $target {*}$args
   379         -}
   380         -proc ::oo::dialect::Canonical {namespace NSpace class} {
   381         -  namespace upvar $namespace cname cname
   382         -  #if {[string match ::* $class]} {
   383         -  #  return $class
   384         -  #}
   385         -  if {[info exists cname($class)]} {
   386         -    return $cname($class)
   387         -  }
   388         -  if {[info exists ::oo::dialect::cname($class)]} {
   389         -    return $::oo::dialect::cname($class)
   390         -  }
   391         -  if {[info exists ::oo::dialect::cname(${NSpace}::${class})]} {
   392         -    return $::oo::dialect::cname(${NSpace}::${class})
   393         -  }
   394         -  foreach item [list "${NSpace}::$class" "::$class"] {
   395         -    if {[info commands $item] ne {}} {
   396         -      return $item
   397         -    }
   398         -  }
   399         -  return ${NSpace}::$class
   400         -}
   401         -proc ::oo::dialect::Define {namespace class args} {
   402         -  Push $class
   403         -  try {
   404         -  	if {[llength $args]==1} {
   405         -      namespace eval ${namespace}::define [lindex $args 0]
   406         -    } else {
   407         -      ${namespace}::define::[lindex $args 0] {*}[lrange $args 1 end]
   408         -    }
   409         -  	${namespace}::dynamic_methods $class
   410         -  } finally {
   411         -    Pop
   412         -  }
   413         -}
   414         -proc ::oo::dialect::Aliases {namespace args} {
   415         -  set class [Peek]
   416         -  namespace upvar $namespace cname cname
   417         -  set NSpace [join [lrange [split $class ::] 1 end-2] ::]
   418         -  set cname($class) $class
   419         -  foreach name $args {
   420         -    set cname($name) $class
   421         -    #set alias $name
   422         -    set alias [NSNormalize $NSpace $name]
   423         -    # Add a local metaclass reference
   424         -    if {![info exists ::oo::dialect::cname($alias)]} {
   425         -      lappend ::oo::dialect::aliases($class) $alias
   426         -      ##
   427         -      # Add a global reference, first come, first served
   428         -      ##
   429         -      set ::oo::dialect::cname($alias) $class
   430         -    }
   431         -  }
   432         -}
   433         -proc ::oo::dialect::SuperClass {namespace args} {
   434         -  set class [Peek]
   435         -  namespace upvar $namespace class_info class_info
   436         -  dict set class_info($class) superclass 1
   437         -  set ::oo::dialect::cname($class) $class
   438         -  set NSpace [join [lrange [split $class ::] 1 end-2] ::]
   439         -  set unique {}
   440         -  foreach item $args {
   441         -    set Item [Canonical $namespace $NSpace $item]
   442         -    dict set unique $Item $item
   443         -  }
   444         -  set root ${namespace}::object
   445         -  if {$class ne $root} {
   446         -    dict set unique $root $root
   447         -  }
   448         -  tailcall ::oo::define $class superclass {*}[dict keys $unique]
   449         -}
   450         -if {[info command ::oo::dialect::MotherOfAllMetaClasses] eq {}} {
   451         -::oo::class create ::oo::dialect::MotherOfAllMetaClasses {
   452         -  superclass ::oo::class
   453         -  constructor {define definitionScript} {
   454         -    $define [self] {
   455         -      superclass
   456         -    }
   457         -    $define [self] $definitionScript
   458         -  }
   459         -  method aliases {} {
   460         -    if {[info exists ::oo::dialect::aliases([self])]} {
   461         -      return $::oo::dialect::aliases([self])
   462         -    }
   463         -  }
   464         -}
   465         -}
   466         -namespace eval ::oo::dialect {
   467         -  variable core_classes {::oo::class ::oo::object}
   468         -}
   469         -package provide oo::dialect 0.4
   470         -package provide dicttool 1.2
   471         -namespace eval ::dicttool {
   472         -}
   473         -namespace eval ::dicttool {
   474         -}
   475         -namespace eval ::tcllib {
   476         -}
   477         -proc ::tcllib::PROC {name arglist body {ninja {}}} {
   478         -  if {[info commands $name] ne {}} return
   479         -  proc $name $arglist $body
   480         -  eval $ninja
   481         -}
   482         -if {[info commands ::PROC] eq {}} {
   483         -  namespace eval ::tcllib { namespace export PROC }
   484         -  namespace eval :: { namespace import ::tcllib::PROC }
   485         -}
   486         -proc ::tcllib::noop args {}
   487         -if {[info commands ::noop] eq {}} {
   488         -  namespace eval ::tcllib { namespace export noop }
   489         -  namespace eval :: { namespace import ::tcllib::noop }
   490         -}
   491         -proc ::tcllib::putb {buffername args} {
   492         -  upvar 1 $buffername buffer
   493         -  switch [llength $args] {
   494         -    1 {
   495         -      append buffer [lindex $args 0] \n
   496         -    }
   497         -    2 {
   498         -      append buffer [string map {*}$args] \n
   499         -    }
   500         -    default {
   501         -      error "usage: putb buffername ?map? string"
   502         -    }
   503         -  }
   504         -}
   505         -if {[info command ::putb] eq {}} {
   506         -  namespace eval ::tcllib { namespace export putb }
   507         -  namespace eval :: { namespace import ::tcllib::putb }
   508         -}
   509         -::tcllib::PROC ::tcl::dict::getnull {dictionary args} {
   510         -  if {[exists $dictionary {*}$args]} {
   511         -    get $dictionary {*}$args
   512         -  }
   513         -} {
   514         -  namespace ensemble configure dict -map [dict replace\
   515         -      [namespace ensemble configure dict -map] getnull ::tcl::dict::getnull]
   516         -}
   517         -::tcllib::PROC ::tcl::dict::is_dict { d } {
   518         -  # is it a dict, or can it be treated like one?
   519         -  if {[catch {dict size $d} err]} {
   520         -    #::set ::errorInfo {}
   521         -    return 0
   522         -  }
   523         -  return 1
   524         -} {
   525         -  namespace ensemble configure dict -map [dict replace\
   526         -      [namespace ensemble configure dict -map] is_dict ::tcl::dict::is_dict]
   527         -}
   528         -::tcllib::PROC ::tcl::dict::rmerge {args} {
   529         -  ::set result [dict create . {}]
   530         -  # Merge b into a, and handle nested dicts appropriately
   531         -  ::foreach b $args {
   532         -    for { k v } $b {
   533         -      ::set field [string trim $k :/]
   534         -      if {![::dicttool::is_branch $b $k]} {
   535         -        # Element names that end in ":" are assumed to be literals
   536         -        set result $k $v
   537         -      } elseif { [exists $result $k] } {
   538         -        # key exists in a and b?  let's see if both values are dicts
   539         -        # both are dicts, so merge the dicts
   540         -        if { [is_dict [get $result $k]] && [is_dict $v] } {
   541         -          set result $k [rmerge [get $result $k] $v]
   542         -        } else {
   543         -          set result $k $v
   544         -        }
   545         -      } else {
   546         -        set result $k $v
   547         -      }
   548         -    }
   549         -  }
   550         -  return $result
   551         -} {
   552         -  namespace ensemble configure dict -map [dict replace\
   553         -      [namespace ensemble configure dict -map] rmerge ::tcl::dict::rmerge]
   554         -}
   555         -::tcllib::PROC ::dicttool::is_branch { dict path } {
   556         -  set field [lindex $path end]
   557         -  if {[string index $field end] eq ":"} {
   558         -    return 0
   559         -  }
   560         -  if {[string index $field 0] eq "."} {
   561         -    return 0
   562         -  }
   563         -  if {[string index $field end] eq "/"} {
   564         -    return 1
   565         -  }
   566         -  return [dict exists $dict {*}$path .]
   567         -}
   568         -::tcllib::PROC ::dicttool::print {dict} {
   569         -  ::set result {}
   570         -  ::set level -1
   571         -  ::dicttool::_dictputb $level result $dict
   572         -  return $result
   573         -}
   574         -::tcllib::PROC ::dicttool::_dictputb {level varname dict} {
   575         -  upvar 1 $varname result
   576         -  incr level
   577         -  dict for {field value} $dict {
   578         -    if {$field eq "."} continue
   579         -    if {[dicttool::is_branch $dict $field]} {
   580         -      putb result "[string repeat "  " $level]$field \{"
   581         -      _dictputb $level result $value
   582         -      putb result "[string repeat "  " $level]\}"
   583         -    } else {
   584         -      putb result "[string repeat "  " $level][list $field $value]"
   585         -    }
   586         -  }
   587         -}
   588         -proc ::dicttool::sanitize {dict} {
   589         -  ::set result {}
   590         -  ::set level -1
   591         -  ::dicttool::_sanitizeb {} result $dict
   592         -  return $result
   593         -}
   594         -proc ::dicttool::_sanitizeb {path varname dict} {
   595         -  upvar 1 $varname result
   596         -  dict for {field value} $dict {
   597         -    if {$field eq "."} continue
   598         -    if {[dicttool::is_branch $dict $field]} {
   599         -      _sanitizeb [list {*}$path $field] result $value
   600         -    } else {
   601         -      dict set result {*}$path $field $value
   602         -    }
   603         -  }
   604         -}
   605         -proc ::dicttool::storage {rawpath} {
   606         -  set isleafvar 0
   607         -  set path {}
   608         -  set tail [string index $rawpath end]
   609         -  foreach element $rawpath {
   610         -    set items [split [string trim $element /] /]
   611         -    foreach item $items {
   612         -      if {$item eq {}} continue
   613         -      lappend path $item
   614         -    }
   615         -  }
   616         -  return $path
   617         -}
   618         -proc ::dicttool::dictset {varname args} {
   619         -  upvar 1 $varname result
   620         -  if {[llength $args] < 2} {
   621         -    error "Usage: ?path...? path value"
   622         -  } elseif {[llength $args]==2} {
   623         -    set rawpath [lindex $args 0]
   624         -  } else {
   625         -    set rawpath  [lrange $args 0 end-1]
   626         -  }
   627         -  set value [lindex $args end]
   628         -  set path [storage $rawpath]
   629         -  set dot .
   630         -  set one {}
   631         -  dict set result $dot $one
   632         -  set dpath {}
   633         -  foreach item [lrange $path 0 end-1] {
   634         -    set field $item
   635         -    lappend dpath [string trim $item /]
   636         -    dict set result {*}$dpath $dot $one
   637         -  }
   638         -  set field [lindex $rawpath end]
   639         -  set ext   [string index $field end]
   640         -  if {$ext eq {:} || ![dict is_dict $value]} {
   641         -    dict set result {*}$path $value
   642         -    return
   643         -  }
   644         -  if {$ext eq {/} && ![dict exists $result {*}$path $dot]} {
   645         -    dict set result {*}$path $dot $one
   646         -  }
   647         -  if {[dict exists $result {*}$path $dot]} {
   648         -    dict set result {*}$path [::dicttool::merge [dict get $result {*}$path] $value]
   649         -    return
   650         -  }
   651         -  dict set result {*}$path $value
   652         -}
   653         -proc ::dicttool::dictmerge {varname args} {
   654         -  upvar 1 $varname result
   655         -  set dot .
   656         -  set one {}
   657         -  dict set result $dot $one
   658         -  foreach dict $args {
   659         -    dict for {f v} $dict {
   660         -      set field [string trim $f /]
   661         -      set bbranch [dicttool::is_branch $dict $f]
   662         -      if {![dict exists $result $field]} {
   663         -        dict set result $field $v
   664         -        if {$bbranch} {
   665         -          dict set result $field [dicttool::merge $v]
   666         -        } else {
   667         -          dict set result $field $v
   668         -        }
   669         -      } elseif {[dict exists $result $field $dot]} {
   670         -        if {$bbranch} {
   671         -          dict set result $field [dicttool::merge [dict get $result $field] $v]
   672         -        } else {
   673         -          dict set result $field $v
   674         -        }
   675         -      }
   676         -    }
   677         -  }
   678         -  return $result
   679         -}
   680         -proc ::dicttool::merge {args} {
   681         -  ###
   682         -  # The result of a merge is always a dict with branches
   683         -  ###
   684         -  set dot .
   685         -  set one {}
   686         -  dict set result $dot $one
   687         -  set argument 0
   688         -  foreach b $args {
   689         -    # Merge b into a, and handle nested dicts appropriately
   690         -    if {![dict is_dict $b]} {
   691         -      error "Element $b is not a dictionary"
   692         -    }
   693         -    dict for { k v } $b {
   694         -      if {$k eq $dot} {
   695         -        dict set result $dot $one
   696         -        continue
   697         -      }
   698         -      set bbranch [is_branch $b $k]
   699         -      set field [string trim $k /]
   700         -      if { ![dict exists $result $field] } {
   701         -        if {$bbranch} {
   702         -          dict set result $field [merge $v]
   703         -        } else {
   704         -          dict set result $field $v
   705         -        }
   706         -      } else {
   707         -        set abranch [dict exists $result $field $dot]
   708         -        if {$abranch && $bbranch} {
   709         -          dict set result $field [merge [dict get $result $field] $v]
   710         -        } else {
   711         -          dict set result $field $v
   712         -          if {$bbranch} {
   713         -            dict set result $field $dot $one
   714         -          }
   715         -        }
   716         -      }
   717         -    }
   718         -  }
   719         -  return $result
   720         -}
   721         -::tcllib::PROC ::tcl::dict::isnull {dictionary args} {
   722         -  if {![exists $dictionary {*}$args]} {return 1}
   723         -  return [expr {[get $dictionary {*}$args] in {{} NULL null}}]
   724         -} {
   725         -  namespace ensemble configure dict -map [dict replace\
   726         -      [namespace ensemble configure dict -map] isnull ::tcl::dict::isnull]
   727         -}
   728         -namespace eval ::dictargs {
   729         -}
   730         -if {[info commands ::dictargs::parse] eq {}} {
   731         -  proc ::dictargs::parse {argdef argdict} {
   732         -    set result {}
   733         -    dict for {field info} $argdef {
   734         -      if {![string is alnum [string index $field 0]]} {
   735         -        error "$field is not a simple variable name"
   736         -      }
   737         -      upvar 1 $field _var
   738         -      set aliases {}
   739         -      if {[dict exists $argdict $field]} {
   740         -        set _var [dict get $argdict $field]
   741         -        continue
   742         -      }
   743         -      if {[dict exists $info aliases:]} {
   744         -        set found 0
   745         -        foreach {name} [dict get $info aliases:] {
   746         -          if {[dict exists $argdict $name]} {
   747         -            set _var [dict get $argdict $name]
   748         -            set found 1
   749         -            break
   750         -          }
   751         -        }
   752         -        if {$found} continue
   753         -      }
   754         -      if {[dict exists $info default:]} {
   755         -        set _var [dict get $info default:] \n
   756         -        continue
   757         -      }
   758         -      set mandatory 1
   759         -      if {[dict exists $info mandatory:]} {
   760         -        set mandatory [dict get $info mandatory:]
   761         -      }
   762         -      if {$mandatory} {
   763         -        error "$field is required"
   764         -      }
   765         -    }
   766         -  }
   767         -}
   768         -proc ::dictargs::proc {name argspec body} {
   769         -  set result {}
   770         -  append result "::dictargs::parse \{$argspec\} \$args" \;
   771         -  append result $body
   772         -  uplevel 1 [list ::proc $name [list [list args [list dictargs $argspec]]] $result]
   773         -}
   774         -proc ::dictargs::method {name argspec body} {
   775         -  set class [lindex [::info level -1] 1]
   776         -  set result {}
   777         -  append result "::dictargs::parse \{$argspec\} \$args" \;
   778         -  append result $body
   779         -  oo::define $class method $name [list [list args [list dictargs $argspec]]] $result
   780         -}
   781         -::tcllib::PROC ::dicttool::ladd {varname args} {
   782         -  upvar 1 $varname var
   783         -  if ![info exists var] {
   784         -      set var {}
   785         -  }
   786         -  foreach item $args {
   787         -    if {$item in $var} continue
   788         -    lappend var $item
   789         -  }
   790         -  return $var
   791         -}
   792         -::tcllib::PROC ::dicttool::ldelete {varname args} {
   793         -  upvar 1 $varname var
   794         -  if ![info exists var] {
   795         -      return
   796         -  }
   797         -  foreach item [lsort -unique $args] {
   798         -    while {[set i [lsearch $var $item]]>=0} {
   799         -      set var [lreplace $var $i $i]
   800         -    }
   801         -  }
   802         -  return $var
   803         -}
   804         -::tcllib::PROC ::dicttool::lrandom list {
   805         -  set len [llength $list]
   806         -  set idx [expr int(rand()*$len)]
   807         -  return [lindex $list $idx]
   808         -}
   809         -namespace eval ::dicttool {
   810         -  namespace export *
   811         -}
   812         -package require Tcl 8.6 ;# try in pipeline.tcl. Possibly other things.
   813         -package require TclOO
   814         -::oo::dialect::create ::clay
   815         -::namespace eval ::clay {
   816         -}
   817         -::namespace eval ::clay::classes {
   818         -}
   819         -::namespace eval ::clay::define {
   820         -}
   821         -namespace eval ::clay {
   822         -}
   823         -set ::clay::trace 0
   824         -proc ::clay::ancestors args {
   825         -  set result {}
   826         -  set queue  [lreverse $args]
   827         -  set result $queue
   828         -  set metaclasses {}
   829         -  while {[llength $queue]} {
   830         -    set tqueue $queue
   831         -    set queue {}
   832         -    foreach qclass $tqueue {
   833         -      foreach aclass [::info class superclasses $qclass] {
   834         -        if { $aclass in $result } continue
   835         -        if { $aclass in $queue } continue
   836         -        lappend queue $aclass
   837         -      }
   838         -    }
   839         -    foreach item $tqueue {
   840         -      if { $item ni $result } {
   841         -        lappend result $item
   842         -      }
   843         -    }
   844         -  }
   845         -  lappend result {*}$metaclasses
   846         -  ###
   847         -  # Screen out classes that do not participate in clay
   848         -  # interactions
   849         -  ###
   850         -  set output {}
   851         -  foreach {item} $result {
   852         -    if {[catch {$item clay noop} err]} {
   853         -      continue
   854         -    }
   855         -    lappend output $item
   856         -  }
   857         -  return $output
   858         -}
   859         -proc ::clay::args_to_dict args {
   860         -  if {[llength $args]==1} {
   861         -    return [lindex $args 0]
   862         -  }
   863         -  return $args
   864         -}
   865         -proc ::clay::args_to_options args {
   866         -  set result {}
   867         -  foreach {var val} [args_to_dict {*}$args] {
   868         -    lappend result [string trim $var -:] $val
   869         -  }
   870         -  return $result
   871         -}
   872         -proc ::clay::dynamic_arguments {ensemble method arglist args} {
   873         -  set idx 0
   874         -  set len [llength $args]
   875         -  if {$len > [llength $arglist]} {
   876         -    ###
   877         -    # Catch if the user supplies too many arguments
   878         -    ###
   879         -    set dargs 0
   880         -    if {[lindex $arglist end] ni {args dictargs}} {
   881         -      return -code error -level 2 "Usage: $ensemble $method [string trim [dynamic_wrongargs_message $arglist]]"
   882         -    }
   883         -  }
   884         -  foreach argdef $arglist {
   885         -    if {$argdef eq "args"} {
   886         -      ###
   887         -      # Perform args processing in the style of tcl
   888         -      ###
   889         -      uplevel 1 [list set args [lrange $args $idx end]]
   890         -      break
   891         -    }
   892         -    if {$argdef eq "dictargs"} {
   893         -      ###
   894         -      # Perform args processing in the style of tcl
   895         -      ###
   896         -      uplevel 1 [list set args [lrange $args $idx end]]
   897         -      ###
   898         -      # Perform args processing in the style of clay
   899         -      ###
   900         -      set dictargs [::clay::args_to_options {*}[lrange $args $idx end]]
   901         -      uplevel 1 [list set dictargs $dictargs]
   902         -      break
   903         -    }
   904         -    if {$idx > $len} {
   905         -      ###
   906         -      # Catch if the user supplies too few arguments
   907         -      ###
   908         -      if {[llength $argdef]==1} {
   909         -        return -code error -level 2 "Usage: $ensemble $method [string trim [dynamic_wrongargs_message $arglist]]"
   910         -      } else {
   911         -        uplevel 1 [list set [lindex $argdef 0] [lindex $argdef 1]]
   912         -      }
   913         -    } else {
   914         -      uplevel 1 [list set [lindex $argdef 0] [lindex $args $idx]]
   915         -    }
   916         -    incr idx
   917         -  }
   918         -}
   919         -proc ::clay::dynamic_wrongargs_message {arglist} {
   920         -  set result ""
   921         -  set dargs 0
   922         -  foreach argdef $arglist {
   923         -    if {$argdef in {args dictargs}} {
   924         -      set dargs 1
   925         -      break
   926         -    }
   927         -    if {[llength $argdef]==1} {
   928         -      append result " $argdef"
   929         -    } else {
   930         -      append result " ?[lindex $argdef 0]?"
   931         -    }
   932         -  }
   933         -  if { $dargs } {
   934         -    append result " ?option value?..."
   935         -  }
   936         -  return $result
   937         -}
   938         -proc ::clay::is_dict { d } {
   939         -  # is it a dict, or can it be treated like one?
   940         -  if {[catch {::dict size $d} err]} {
   941         -    #::set ::errorInfo {}
   942         -    return 0
   943         -  }
   944         -  return 1
   945         -}
   946         -proc ::clay::is_null value {
   947         -  return [expr {$value in {{} NULL}}]
   948         -}
   949         -proc ::clay::leaf args {
   950         -  set marker [string index [lindex $args end] end]
   951         -  set result [path {*}${args}]
   952         -  if {$marker eq "/"} {
   953         -    return $result
   954         -  }
   955         -  return [list {*}[lrange $result 0 end-1] [string trim [string trim [lindex $result end]] /]]
   956         -}
   957         -proc ::clay::path args {
   958         -  set result {}
   959         -  foreach item $args {
   960         -    set item [string trim $item :./]
   961         -    foreach subitem [split $item /] {
   962         -      lappend result [string trim ${subitem}]/
   963         -    }
   964         -  }
   965         -  return $result
   966         -}
   967         -proc ::clay::script_path {} {
   968         -  set path [file dirname [file join [pwd] [info script]]]
   969         -  return $path
   970         -}
   971         -proc ::clay::NSNormalize qualname {
   972         -  if {![string match ::* $qualname]} {
   973         -    set qualname ::clay::classes::$qualname
   974         -  }
   975         -  regsub -all {::+} $qualname "::"
   976         -}
   977         -proc ::clay::uuid_generate args {
   978         -  return [uuid::uuid generate]
   979         -}
   980         -namespace eval ::clay {
   981         -  variable option_class {}
   982         -  variable core_classes {::oo::class ::oo::object}
   983         -}
   984         -proc ::clay::dynamic_methods class {
   985         -  foreach command [info commands [namespace current]::dynamic_methods_*] {
   986         -    $command $class
   987         -  }
   988         -}
   989         -proc ::clay::dynamic_methods_class {thisclass} {
   990         -  set methods {}
   991         -  set mdata [$thisclass clay find class_typemethod]
   992         -  foreach {method info} $mdata {
   993         -    if {$method eq {.}} continue
   994         -    set method [string trimright $method :/-]
   995         -    if {$method in $methods} continue
   996         -    lappend methods $method
   997         -    set arglist [dict getnull $info arglist]
   998         -    set body    [dict getnull $info body]
   999         -    ::oo::objdefine $thisclass method $method $arglist $body
  1000         -  }
  1001         -}
  1002         -proc ::clay::define::Array {name {values {}}} {
  1003         -  set class [current_class]
  1004         -  set name [string trim $name :/]
  1005         -  $class clay branch array $name
  1006         -  dict for {var val} $values {
  1007         -    $class clay set array/ $name $var $val
  1008         -  }
  1009         -}
  1010         -proc ::clay::define::Delegate {name info} {
  1011         -  set class [current_class]
  1012         -  foreach {field value} $info {
  1013         -    $class clay set component/ [string trim $name :/]/ $field $value
  1014         -  }
  1015         -}
  1016         -proc ::clay::define::constructor {arglist rawbody} {
  1017         -  set body {
  1018         -my variable DestroyEvent
  1019         -set DestroyEvent 0
  1020         -::clay::object_create [self] [info object class [self]]
  1021         -# Initialize public variables and options
  1022         -my InitializePublic
  1023         -  }
  1024         -  append body $rawbody
  1025         -  set class [current_class]
  1026         -  ::oo::define $class constructor $arglist $body
  1027         -}
  1028         -proc ::clay::define::class_method {name arglist body} {
  1029         -  set class [current_class]
  1030         -  $class clay set class_typemethod/ [string trim $name :/] [dict create arglist $arglist body $body]
  1031         -}
  1032         -proc ::clay::define::clay {args} {
  1033         -  set class [current_class]
  1034         -  if {[lindex $args 0] in "cget set branch"} {
  1035         -    $class clay {*}$args
  1036         -  } else {
  1037         -    $class clay set {*}$args
  1038         -  }
  1039         -}
  1040         -proc ::clay::define::destructor rawbody {
  1041         -  set body {
  1042         -# Run the destructor once and only once
  1043         -set self [self]
  1044         -my variable DestroyEvent
  1045         -if {$DestroyEvent} return
  1046         -set DestroyEvent 1
  1047         -::clay::object_destroy $self
  1048         -}
  1049         -  append body $rawbody
  1050         -  ::oo::define [current_class] destructor $body
  1051         -}
  1052         -proc ::clay::define::Dict {name {values {}}} {
  1053         -  set class [current_class]
  1054         -  set name [string trim $name :/]
  1055         -  $class clay branch dict $name
  1056         -  foreach {var val} $values {
  1057         -    $class clay set dict/ $name/ $var $val
  1058         -  }
  1059         -}
  1060         -proc ::clay::define::Option {name args} {
  1061         -  set class [current_class]
  1062         -  set dictargs {default {}}
  1063         -  foreach {var val} [::clay::args_to_dict {*}$args] {
  1064         -    dict set dictargs [string trim $var -:/] $val
  1065         -  }
  1066         -  set name [string trimleft $name -]
  1067         -
  1068         -  ###
  1069         -  # Option Class handling
  1070         -  ###
  1071         -  set optclass [dict getnull $dictargs class]
  1072         -  if {$optclass ne {}} {
  1073         -    foreach {f v} [$class clay find option_class $optclass] {
  1074         -      if {![dict exists $dictargs $f]} {
  1075         -        dict set dictargs $f $v
  1076         -      }
  1077         -    }
  1078         -    if {$optclass eq "variable"} {
  1079         -      variable $name [dict getnull $dictargs default]
  1080         -    }
  1081         -  }
  1082         -  foreach {f v} $dictargs {
  1083         -    $class clay set option $name $f $v
  1084         -  }
  1085         -}
  1086         -proc ::clay::define::Option_Class {name args} {
  1087         -  set class [current_class]
  1088         -  set dictargs {default {}}
  1089         -  set name [string trimleft $name -:]
  1090         -  foreach {f v} [::clay::args_to_dict {*}$args] {
  1091         -    $class clay set option_class $name [string trim $f -/:] $v
  1092         -  }
  1093         -}
  1094         -proc ::clay::define::Variable {name {default {}}} {
  1095         -  set class [current_class]
  1096         -  set name [string trimright $name :/]
  1097         -  $class clay set variable/ $name $default
  1098         -}
  1099         -proc ::clay::object_create {objname {class {}}} {
  1100         -  #if {$::clay::trace>0} {
  1101         -  #  puts [list $objname CREATE]
  1102         -  #}
  1103         -}
  1104         -proc ::clay::object_rename {object newname} {
  1105         -  if {$::clay::trace>0} {
  1106         -    puts [list $object RENAME -> $newname]
  1107         -  }
  1108         -}
  1109         -proc ::clay::object_destroy objname {
  1110         -  if {$::clay::trace>0} {
  1111         -    puts [list $objname DESTROY]
  1112         -  }
  1113         -  ::cron::object_destroy $objname
  1114         -}
  1115         -::namespace eval ::clay::define {
  1116         -}
  1117         -proc ::clay::ensemble_methodbody {ensemble einfo} {
  1118         -  set default standard
  1119         -  set preamble {}
  1120         -  set eswitch {}
  1121         -  if {[dict exists $einfo default]} {
  1122         -    set emethodinfo [dict get $einfo default]
  1123         -    set arglist     [dict getnull $emethodinfo arglist]
  1124         -    set realbody    [dict get $emethodinfo body]
  1125         -    if {[llength $arglist]==1 && [lindex $arglist 0] in {{} args arglist}} {
  1126         -      set body {}
  1127         -    } else {
  1128         -      set body "\n      ::clay::dynamic_arguments $ensemble \$method [list $arglist] {*}\$args"
  1129         -    }
  1130         -    append body "\n      " [string trim $realbody] "      \n"
  1131         -    set default $body
  1132         -    dict unset einfo default
  1133         -  }
  1134         -  foreach {msubmethod esubmethodinfo} [lsort -dictionary -stride 2 $einfo] {
  1135         -    set submethod [string trim $msubmethod :/-]
  1136         -    if {$submethod eq "_body"} continue
  1137         -    if {$submethod eq "_preamble"} {
  1138         -      set preamble [dict getnull $esubmethodinfo body]
  1139         -      continue
  1140         -    }
  1141         -    set arglist     [dict getnull $esubmethodinfo arglist]
  1142         -    set realbody    [dict getnull $esubmethodinfo body]
  1143         -    if {[string length [string trim $realbody]] eq {}} {
  1144         -      dict set eswitch $submethod {}
  1145         -    } else {
  1146         -      if {[llength $arglist]==1 && [lindex $arglist 0] in {{} args arglist}} {
  1147         -        set body {}
  1148         -      } else {
  1149         -        set body "\n      ::clay::dynamic_arguments $ensemble \$method [list $arglist] {*}\$args"
  1150         -      }
  1151         -      append body "\n      " [string trim $realbody] "      \n"
  1152         -      if {$submethod eq "default"} {
  1153         -        set default $body
  1154         -      } else {
  1155         -        foreach alias [dict getnull $esubmethodinfo aliases] {
  1156         -          dict set eswitch $alias -
  1157         -        }
  1158         -        dict set eswitch $submethod $body
  1159         -      }
  1160         -    }
  1161         -  }
  1162         -  set methodlist [lsort -dictionary [dict keys $eswitch]]
  1163         -  if {![dict exists $eswitch <list>]} {
  1164         -    dict set eswitch <list> {return $methodlist}
  1165         -  }
  1166         -  if {$default eq "standard"} {
  1167         -    set default "error \"unknown method $ensemble \$method. Valid: \$methodlist\""
  1168         -  }
  1169         -  dict set eswitch default $default
  1170         -  set mbody {}
  1171         -
  1172         -  append mbody $preamble \n
  1173         -
  1174         -  append mbody \n [list set methodlist $methodlist]
  1175         -  append mbody \n "set code \[catch {switch -- \$method [list $eswitch]} result opts\]"
  1176         -  append mbody \n {return -options $opts $result}
  1177         -  return $mbody
  1178         -}
  1179         -::proc ::clay::define::Ensemble {rawmethod arglist body} {
  1180         -  set class [current_class]
  1181         -  #if {$::clay::trace>2} {
  1182         -  #  puts [list $class Ensemble $rawmethod $arglist $body]
  1183         -  #}
  1184         -  set mlist [split $rawmethod "::"]
  1185         -  set ensemble [string trim [lindex $mlist 0] :/]
  1186         -  set mensemble ${ensemble}/
  1187         -  if {[llength $mlist]==1 || [lindex $mlist 1] in "_body"} {
  1188         -    set method _body
  1189         -    ###
  1190         -    # Simple method, needs no parsing, but we do need to record we have one
  1191         -    ###
  1192         -    $class clay set method_ensemble/ $mensemble _body [dict create arglist $arglist body $body]
  1193         -    if {$::clay::trace>2} {
  1194         -      puts [list $class clay set method_ensemble/ $mensemble _body ...]
  1195         -    }
  1196         -    set method $rawmethod
  1197         -    if {$::clay::trace>2} {
  1198         -      puts [list $class Ensemble $rawmethod $arglist $body]
  1199         -      set rawbody $body
  1200         -      set body {puts [list [self] $class [self method]]}
  1201         -      append body \n $rawbody
  1202         -    }
  1203         -    ::oo::define $class method $rawmethod $arglist $body
  1204         -    return
  1205         -  }
  1206         -  set method [join [lrange $mlist 2 end] "::"]
  1207         -  $class clay set method_ensemble/ $mensemble [string trim [lindex $method 0] :/] [dict create arglist $arglist body $body]
  1208         -  if {$::clay::trace>2} {
  1209         -    puts [list $class clay set method_ensemble/ $mensemble [string trim $method :/]  ...]
  1210         -  }
  1211         -}
  1212         -::oo::define ::clay::class {
  1213         -  method clay {submethod args} {
  1214         -    my variable clay
  1215         -    if {![info exists clay]} {
  1216         -      set clay {}
  1217         -    }
  1218         -    switch $submethod {
  1219         -      ancestors {
  1220         -        tailcall ::clay::ancestors [self]
  1221         -      }
  1222         -      branch {
  1223         -        set path [::dicttool::storage $args]
  1224         -        if {![dict exists $clay {*}$path .]} {
  1225         -          dict set clay {*}$path . {}
  1226         -        }
  1227         -      }
  1228         -      exists {
  1229         -        if {![info exists clay]} {
  1230         -          return 0
  1231         -        }
  1232         -        set path [::dicttool::storage $args]
  1233         -        if {[dict exists $clay {*}$path]} {
  1234         -          return 1
  1235         -        }
  1236         -        if {[dict exists $clay {*}[lrange $path 0 end-1] [lindex $path end]:]} {
  1237         -          return 1
  1238         -        }
  1239         -        return 0
  1240         -      }
  1241         -      dump {
  1242         -        return $clay
  1243         -      }
  1244         -      dget {
  1245         -         if {![info exists clay]} {
  1246         -          return {}
  1247         -        }
  1248         -        set path [::dicttool::storage $args]
  1249         -        if {[dict exists $clay {*}$path]} {
  1250         -          return [dict get $clay {*}$path]
  1251         -        }
  1252         -        if {[dict exists $clay {*}[lrange $path 0 end-1] [lindex $path end]:]} {
  1253         -          return [dict get $clay {*}[lrange $path 0 end-1] [lindex $path end]:]
  1254         -        }
  1255         -        return {}
  1256         -      }
  1257         -      is_branch {
  1258         -        set path [::dicttool::storage $args]
  1259         -        return [dict exists $clay {*}$path .]
  1260         -      }
  1261         -      getnull -
  1262         -      get {
  1263         -        if {![info exists clay]} {
  1264         -          return {}
  1265         -        }
  1266         -        set path [::dicttool::storage $args]
  1267         -        if {[llength $path]==0} {
  1268         -          return $clay
  1269         -        }
  1270         -        if {[dict exists $clay {*}$path .]} {
  1271         -          return [::dicttool::sanitize [dict get $clay {*}$path]]
  1272         -        }
  1273         -        if {[dict exists $clay {*}$path]} {
  1274         -          return [dict get $clay {*}$path]
  1275         -        }
  1276         -        if {[dict exists $clay {*}[lrange $path 0 end-1] [lindex $path end]:]} {
  1277         -          return [dict get $clay {*}[lrange $path 0 end-1] [lindex $path end]:]
  1278         -        }
  1279         -        return {}
  1280         -      }
  1281         -      find {
  1282         -        set path [::dicttool::storage $args]
  1283         -        if {![info exists clay]} {
  1284         -          set clay {}
  1285         -        }
  1286         -        set clayorder [::clay::ancestors [self]]
  1287         -        set found 0
  1288         -        if {[llength $path]==0} {
  1289         -          set result [dict create . {}]
  1290         -          foreach class $clayorder {
  1291         -            ::dicttool::dictmerge result [$class clay dump]
  1292         -          }
  1293         -          return [::dicttool::sanitize $result]
  1294         -        }
  1295         -        foreach class $clayorder {
  1296         -          if {[$class clay exists {*}$path .]} {
  1297         -            # Found a branch break
  1298         -            set found 1
  1299         -            break
  1300         -          }
  1301         -          if {[$class clay exists {*}$path]} {
  1302         -            # Found a leaf. Return that value immediately
  1303         -            return [$class clay get {*}$path]
  1304         -          }
  1305         -          if {[dict exists $clay {*}[lrange $path 0 end-1] [lindex $path end]:]} {
  1306         -            return [dict get $clay {*}[lrange $path 0 end-1] [lindex $path end]:]
  1307         -          }
  1308         -        }
  1309         -        if {!$found} {
  1310         -          return {}
  1311         -        }
  1312         -        set result {}
  1313         -        # Leaf searches return one data field at a time
  1314         -        # Search in our local dict
  1315         -        # Search in the in our list of classes for an answer
  1316         -        foreach class [lreverse $clayorder] {
  1317         -          ::dicttool::dictmerge result [$class clay dget {*}$path]
  1318         -        }
  1319         -        return [::dicttool::sanitize $result]
  1320         -      }
  1321         -      merge {
  1322         -        foreach arg $args {
  1323         -          ::dicttool::dictmerge clay {*}$arg
  1324         -        }
  1325         -      }
  1326         -      noop {
  1327         -        # Do nothing. Used as a sign of clay savviness
  1328         -      }
  1329         -      search {
  1330         -        foreach aclass [::clay::ancestors [self]] {
  1331         -          if {[$aclass clay exists {*}$args]} {
  1332         -            return [$aclass clay get {*}$args]
  1333         -          }
  1334         -        }
  1335         -      }
  1336         -      set {
  1337         -        ::dicttool::dictset clay {*}$args
  1338         -      }
  1339         -      unset {
  1340         -        dict unset clay {*}$args
  1341         -      }
  1342         -      default {
  1343         -        dict $submethod clay {*}$args
  1344         -      }
  1345         -    }
  1346         -  }
  1347         -}
  1348         -::oo::define ::clay::object {
  1349         -  method clay {submethod args} {
  1350         -    my variable clay claycache clayorder config option_canonical
  1351         -    if {![info exists clay]} {set clay {}}
  1352         -    if {![info exists claycache]} {set claycache {}}
  1353         -    if {![info exists config]} {set config {}}
  1354         -    if {![info exists clayorder] || [llength $clayorder]==0} {
  1355         -      set clayorder [::clay::ancestors [info object class [self]] {*}[info object mixins [self]]]
  1356         -    }
  1357         -    switch $submethod {
  1358         -      ancestors {
  1359         -        return $clayorder
  1360         -      }
  1361         -      branch {
  1362         -        set path [::dicttool::storage $args]
  1363         -        if {![dict exists $clay {*}$path .]} {
  1364         -          dict set clay {*}$path . {}
  1365         -        }
  1366         -      }
  1367         -      cget {
  1368         -        # Leaf searches return one data field at a time
  1369         -        # Search in our local dict
  1370         -        if {[llength $args]==1} {
  1371         -          set field [string trim [lindex $args 0] -:/]
  1372         -          if {[info exists option_canonical($field)]} {
  1373         -            set field $option_canonical($field)
  1374         -          }
  1375         -          if {[dict exists $config $field]} {
  1376         -            return [dict get $config $field]
  1377         -          }
  1378         -        }
  1379         -        set path [::dicttool::storage $args]
  1380         -        if {[dict exists $clay {*}$path]} {
  1381         -          return [dict get $clay {*}$path]
  1382         -        }
  1383         -        # Search in our local cache
  1384         -        if {[dict exists $claycache {*}$path]} {
  1385         -          if {[dict exists $claycache {*}$path .]} {
  1386         -            return [dict remove [dict get $claycache {*}$path] .]
  1387         -          } else {
  1388         -            return [dict get $claycache {*}$path]
  1389         -          }
  1390         -        }
  1391         -        # Search in the in our list of classes for an answer
  1392         -        foreach class $clayorder {
  1393         -          if {[$class clay exists {*}$path]} {
  1394         -            set value [$class clay get {*}$path]
  1395         -            dict set claycache {*}$path $value
  1396         -            return $value
  1397         -          }
  1398         -          if {[$class clay exists const {*}$path]} {
  1399         -            set value [$class clay get const {*}$path]
  1400         -            dict set claycache {*}$path $value
  1401         -            return $value
  1402         -          }
  1403         -          if {[$class clay exists option {*}$path default]} {
  1404         -            set value [$class clay get option {*}$path default]
  1405         -            dict set claycache {*}$path $value
  1406         -            return $value
  1407         -          }
  1408         -        }
  1409         -        return {}
  1410         -      }
  1411         -      delegate {
  1412         -        if {![dict exists $clay .delegate <class>]} {
  1413         -          dict set clay .delegate <class> [info object class [self]]
  1414         -        }
  1415         -        if {[llength $args]==0} {
  1416         -          return [dict get $clay .delegate]
  1417         -        }
  1418         -        if {[llength $args]==1} {
  1419         -          set stub <[string trim [lindex $args 0] <>]>
  1420         -          if {![dict exists $clay .delegate $stub]} {
  1421         -            return {}
  1422         -          }
  1423         -          return [dict get $clay .delegate $stub]
  1424         -        }
  1425         -        if {([llength $args] % 2)} {
  1426         -          error "Usage: delegate
  1427         -    OR
  1428         -    delegate stub
  1429         -    OR
  1430         -    delegate stub OBJECT ?stub OBJECT? ..."
  1431         -        }
  1432         -        foreach {stub object} $args {
  1433         -          set stub <[string trim $stub <>]>
  1434         -          dict set clay .delegate $stub $object
  1435         -          oo::objdefine [self] forward ${stub} $object
  1436         -          oo::objdefine [self] export ${stub}
  1437         -        }
  1438         -      }
  1439         -      dump {
  1440         -        # Do a full dump of clay data
  1441         -        set result {}
  1442         -        # Search in the in our list of classes for an answer
  1443         -        foreach class $clayorder {
  1444         -          ::dicttool::dictmerge result [$class clay dump]
  1445         -        }
  1446         -        ::dicttool::dictmerge result $clay
  1447         -        return $result
  1448         -      }
  1449         -      ensemble_map {
  1450         -        set ensemble [lindex $args 0]
  1451         -        my variable claycache
  1452         -        set mensemble [string trim $ensemble :/]
  1453         -        if {[dict exists $claycache method_ensemble $mensemble]} {
  1454         -          return [dicttool::sanitize [dict get $claycache method_ensemble $mensemble]]
  1455         -        }
  1456         -        set emap [my clay dget method_ensemble $mensemble]
  1457         -        dict set claycache method_ensemble $mensemble $emap
  1458         -        return [dicttool::sanitize $emap]
  1459         -      }
  1460         -      eval {
  1461         -        set script [lindex $args 0]
  1462         -        set buffer {}
  1463         -        set thisline {}
  1464         -        foreach line [split $script \n] {
  1465         -          append thisline $line
  1466         -          if {![info complete $thisline]} {
  1467         -            append thisline \n
  1468         -            continue
  1469         -          }
  1470         -          set thisline [string trim $thisline]
  1471         -          if {[string index $thisline 0] eq "#"} continue
  1472         -          if {[string length $thisline]==0} continue
  1473         -          if {[lindex $thisline 0] eq "my"} {
  1474         -            # Line already calls out "my", accept verbatim
  1475         -            append buffer $thisline \n
  1476         -          } elseif {[string range $thisline 0 2] eq "::"} {
  1477         -            # Fully qualified commands accepted verbatim
  1478         -            append buffer $thisline \n
  1479         -          } elseif {
  1480         -            append buffer "my $thisline" \n
  1481         -          }
  1482         -          set thisline {}
  1483         -        }
  1484         -        eval $buffer
  1485         -      }
  1486         -      evolve -
  1487         -      initialize {
  1488         -        my InitializePublic
  1489         -      }
  1490         -      exists {
  1491         -        # Leaf searches return one data field at a time
  1492         -        # Search in our local dict
  1493         -        set path [::dicttool::storage $args]
  1494         -        if {[dict exists $clay {*}$path]} {
  1495         -          return 1
  1496         -        }
  1497         -        # Search in our local cache
  1498         -        if {[dict exists $claycache {*}$path]} {
  1499         -          return 2
  1500         -        }
  1501         -        set count 2
  1502         -        # Search in the in our list of classes for an answer
  1503         -        foreach class $clayorder {
  1504         -          incr count
  1505         -          if {[$class clay exists {*}$path]} {
  1506         -            return $count
  1507         -          }
  1508         -        }
  1509         -        return 0
  1510         -      }
  1511         -      flush {
  1512         -        set claycache {}
  1513         -        set clayorder [::clay::ancestors [info object class [self]] {*}[info object mixins [self]]]
  1514         -      }
  1515         -      forward {
  1516         -        oo::objdefine [self] forward {*}$args
  1517         -      }
  1518         -      dget {
  1519         -        # Search in our local cache
  1520         -        set path [::dicttool::storage $args]
  1521         -        if {[llength $path]==0} {
  1522         -          # Do a full dump of clay data
  1523         -          set result {}
  1524         -          # Search in the in our list of classes for an answer
  1525         -          foreach class $clayorder {
  1526         -            ::dicttool::dictmerge result [$class clay dump]
  1527         -          }
  1528         -          ::dicttool::dictmerge result $clay
  1529         -          return $result
  1530         -        }
  1531         -        #if {[dict exists $claycache {*}$path]} {
  1532         -        #  return [dict get $claycache {*}$path]
  1533         -        #}
  1534         -        if {[dict exists $clay {*}$path .]} {
  1535         -          # Path is a branch
  1536         -          set result {}
  1537         -          foreach class [lreverse $clayorder] {
  1538         -            if {[$class clay exists {*}$path .]} {
  1539         -              set value [$class clay dget {*}$path]
  1540         -              ::dicttool::dictmerge result $value
  1541         -            }
  1542         -          }
  1543         -          ::dicttool::dictmerge result [dict get $clay {*}$path]
  1544         -          dict set claycache {*}$path $result
  1545         -          return $result
  1546         -        } elseif {[dict exists $clay {*}$path]} {
  1547         -          # Path is a leaf
  1548         -          return [dict get $clay {*}$path]
  1549         -        }
  1550         -        # Search in the in our list of classes for an answer
  1551         -        set found 0
  1552         -        foreach class $clayorder {
  1553         -          if {[$class clay exists {*}$path .]} {
  1554         -            set found 1
  1555         -            break
  1556         -          }
  1557         -          if {[$class clay exists {*}$path]} {
  1558         -            # Found a leaf.
  1559         -            set result [$class clay get {*}$path]
  1560         -            dict set claycache {*}$path $result
  1561         -            return $result
  1562         -          }
  1563         -        }
  1564         -        set result {}
  1565         -        if {$found} {
  1566         -          # One of our ancestors has this as a branch
  1567         -          # Do a recursive merge across all classes
  1568         -          foreach class [lreverse $clayorder] {
  1569         -            if {[$class clay exists {*}$path .]} {
  1570         -              set value [$class clay dget {*}$path]
  1571         -              ::dicttool::dictmerge result $value
  1572         -            }
  1573         -          }
  1574         -        }
  1575         -        dict set claycache {*}$path $result
  1576         -        return $result
  1577         -      }
  1578         -      getnull -
  1579         -      get {
  1580         -        set path [::dicttool::storage $args]
  1581         -        if {[llength $path]==0} {
  1582         -          # Do a full dump of clay data
  1583         -          set result {}
  1584         -          # Search in the in our list of classes for an answer
  1585         -          foreach class $clayorder {
  1586         -            ::dicttool::dictmerge result [$class clay dump]
  1587         -          }
  1588         -          ::dicttool::dictmerge result $clay
  1589         -          return [::dicttool::sanitize $result]
  1590         -        }
  1591         -        if {[dict exists $claycache {*}$path .]} {
  1592         -          return [::dicttool::sanitize [dict get $claycache {*}$path]]
  1593         -        }
  1594         -        if {[dict exists $claycache {*}$path]} {
  1595         -          return [dict get $claycache {*}$path]
  1596         -        }
  1597         -        if {[dict exists $clay {*}$path] && ![dict exists $clay {*}$path .]} {
  1598         -          # Path is a leaf
  1599         -          return [dict get $clay {*}$path]
  1600         -        }
  1601         -        set found 0
  1602         -        set branch [dict exists $clay {*}$path .]
  1603         -        foreach class $clayorder {
  1604         -          if {[$class clay exists {*}$path .]} {
  1605         -            set found 1
  1606         -            break
  1607         -          }
  1608         -          if {!$branch && [$class clay exists {*}$path]} {
  1609         -            set result [$class clay dget {*}$path]
  1610         -            dict set claycache {*}$path $result
  1611         -            return $result
  1612         -          }
  1613         -        }
  1614         -        # Path is a branch
  1615         -        set result {}
  1616         -        foreach class [lreverse $clayorder] {
  1617         -          if {[$class clay exists {*}$path .]} {
  1618         -            set value [$class clay dget {*}$path]
  1619         -            ::dicttool::dictmerge result $value
  1620         -          }
  1621         -        }
  1622         -        if {[dict exists $clay {*}$path .]} {
  1623         -          ::dicttool::dictmerge result [dict get $clay {*}$path]
  1624         -        }
  1625         -        dict set claycache {*}$path $result
  1626         -        return [dicttool::sanitize $result]
  1627         -      }
  1628         -      leaf {
  1629         -        # Leaf searches return one data field at a time
  1630         -        # Search in our local dict
  1631         -        set path [::dicttool::storage $args]
  1632         -        if {[dict exists $clay {*}$path .]} {
  1633         -          return [dicttool::sanitize [dict get $clay {*}$path]]
  1634         -        }
  1635         -        if {[dict exists $clay {*}$path]} {
  1636         -          return [dict get $clay {*}$path]
  1637         -        }
  1638         -        # Search in our local cache
  1639         -        if {[dict exists $claycache {*}$path .]} {
  1640         -          return [dicttool::sanitize [dict get $claycache {*}$path]]
  1641         -        }
  1642         -        if {[dict exists $claycache {*}$path]} {
  1643         -          return [dict get $claycache {*}$path]
  1644         -        }
  1645         -        # Search in the in our list of classes for an answer
  1646         -        foreach class $clayorder {
  1647         -          if {[$class clay exists {*}$path]} {
  1648         -            set value [$class clay get {*}$path]
  1649         -            dict set claycache {*}$path $value
  1650         -            return $value
  1651         -          }
  1652         -        }
  1653         -      }
  1654         -      merge {
  1655         -        foreach arg $args {
  1656         -          ::dicttool::dictmerge clay {*}$arg
  1657         -        }
  1658         -      }
  1659         -      mixin {
  1660         -        ###
  1661         -        # Mix in the class
  1662         -        ###
  1663         -        set prior  [info object mixins [self]]
  1664         -        set newmixin {}
  1665         -        foreach item $args {
  1666         -          lappend newmixin ::[string trimleft $item :]
  1667         -        }
  1668         -        set newmap $args
  1669         -        foreach class $prior {
  1670         -          if {$class ni $newmixin} {
  1671         -            set script [$class clay search mixin/ unmap-script]
  1672         -            if {[string length $script]} {
  1673         -              if {[catch $script err errdat]} {
  1674         -                puts stderr "[self] MIXIN ERROR POPPING $class:\n[dict get $errdat -errorinfo]"
  1675         -              }
  1676         -            }
  1677         -          }
  1678         -        }
  1679         -        ::oo::objdefine [self] mixin {*}$args
  1680         -        ###
  1681         -        # Build a compsite map of all ensembles defined by the object's current
  1682         -        # class as well as all of the classes being mixed in
  1683         -        ###
  1684         -        my InitializePublic
  1685         -        foreach class $newmixin {
  1686         -          if {$class ni $prior} {
  1687         -            set script [$class clay search mixin/ map-script]
  1688         -            if {[string length $script]} {
  1689         -              if {[catch $script err errdat]} {
  1690         -                puts stderr "[self] MIXIN ERROR PUSHING $class:\n[dict get $errdat -errorinfo]"
  1691         -              }
  1692         -            }
  1693         -          }
  1694         -        }
  1695         -        foreach class $newmixin {
  1696         -          set script [$class clay search mixin/ react-script]
  1697         -          if {[string length $script]} {
  1698         -            if {[catch $script err errdat]} {
  1699         -              puts stderr "[self] MIXIN ERROR PEEKING $class:\n[dict get $errdat -errorinfo]"
  1700         -            }
  1701         -            break
  1702         -          }
  1703         -        }
  1704         -      }
  1705         -      mixinmap {
  1706         -        my variable clay
  1707         -        if {![dict exists $clay .mixin]} {
  1708         -          dict set clay .mixin {}
  1709         -        }
  1710         -        if {[llength $args]==0} {
  1711         -          return [dict get $clay .mixin]
  1712         -        } elseif {[llength $args]==1} {
  1713         -          return [dict getnull $clay .mixin [lindex $args 0]]
  1714         -        } else {
  1715         -          foreach {slot classes} $args {
  1716         -            dict set clay .mixin $slot $classes
  1717         -          }
  1718         -          set claycache {}
  1719         -          set classlist {}
  1720         -          foreach {item class} [dict get $clay .mixin] {
  1721         -            if {$class ne {}} {
  1722         -              lappend classlist $class
  1723         -            }
  1724         -          }
  1725         -          my clay mixin {*}[lreverse $classlist]
  1726         -        }
  1727         -      }
  1728         -      provenance {
  1729         -        if {[dict exists $clay {*}$args]} {
  1730         -          return self
  1731         -        }
  1732         -        foreach class $clayorder {
  1733         -          if {[$class clay exists {*}$args]} {
  1734         -            return $class
  1735         -          }
  1736         -        }
  1737         -        return {}
  1738         -      }
  1739         -      replace {
  1740         -        set clay [lindex $args 0]
  1741         -      }
  1742         -      source {
  1743         -        source [lindex $args 0]
  1744         -      }
  1745         -      set {
  1746         -        #puts [list [self] clay SET {*}$args]
  1747         -        set claycache {}
  1748         -        ::dicttool::dictset clay {*}$args
  1749         -      }
  1750         -      default {
  1751         -        dict $submethod clay {*}$args
  1752         -      }
  1753         -    }
  1754         -  }
  1755         -  method InitializePublic {} {
  1756         -    my variable clayorder clay claycache config option_canonical
  1757         -    set claycache {}
  1758         -    set clayorder [::clay::ancestors [info object class [self]] {*}[info object mixins [self]]]
  1759         -    if {![info exists clay]} {
  1760         -      set clay {}
  1761         -    }
  1762         -    if {![info exists config]} {
  1763         -      set config {}
  1764         -    }
  1765         -    dict for {var value} [my clay get variable] {
  1766         -      if { $var in {. clay} } continue
  1767         -      set var [string trim $var :/]
  1768         -      my variable $var
  1769         -      if {![info exists $var]} {
  1770         -        if {$::clay::trace>2} {puts [list initialize variable $var $value]}
  1771         -        set $var $value
  1772         -      }
  1773         -    }
  1774         -    dict for {var value} [my clay get dict/] {
  1775         -      if { $var in {. clay} } continue
  1776         -      set var [string trim $var :/]
  1777         -      my variable $var
  1778         -      if {![info exists $var]} {
  1779         -        set $var {}
  1780         -      }
  1781         -      foreach {f v} $value {
  1782         -        if {$f eq "."} continue
  1783         -        if {![dict exists ${var} $f]} {
  1784         -          if {$::clay::trace>2} {puts [list initialize dict $var $f $v]}
  1785         -          dict set ${var} $f $v
  1786         -        }
  1787         -      }
  1788         -    }
  1789         -    foreach {var value} [my clay get array/] {
  1790         -      if { $var in {. clay} } continue
  1791         -      set var [string trim $var :/]
  1792         -      if { $var eq {clay} } continue
  1793         -      my variable $var
  1794         -      if {![info exists $var]} { array set $var {} }
  1795         -      foreach {f v} $value {
  1796         -        if {![array exists ${var}($f)]} {
  1797         -          if {$f eq "."} continue
  1798         -          if {$::clay::trace>2} {puts [list initialize array $var\($f\) $v]}
  1799         -          set ${var}($f) $v
  1800         -        }
  1801         -      }
  1802         -    }
  1803         -    foreach {field info} [my clay get option/] {
  1804         -      if { $field in {. clay} } continue
  1805         -      set field [string trim $field -/:]
  1806         -      foreach alias [dict getnull $info aliases] {
  1807         -        set option_canonical($alias) $field
  1808         -      }
  1809         -      if {[dict exists $config $field]} continue
  1810         -      set getcmd [dict getnull $info default-command]
  1811         -      if {$getcmd ne {}} {
  1812         -        set value [{*}[string map [list %field% $field %self% [namespace which my]] $getcmd]]
  1813         -      } else {
  1814         -        set value [dict getnull $info default]
  1815         -      }
  1816         -      dict set config $field $value
  1817         -      set setcmd [dict getnull $info set-command]
  1818         -      if {$setcmd ne {}} {
  1819         -        {*}[string map [list %field% [list $field] %value% [list $value] %self% [namespace which my]] $setcmd]
  1820         -      }
  1821         -    }
  1822         -    my variable clayorder clay claycache
  1823         -    if {[info exists clay]} {
  1824         -      set emap [dict getnull $clay method_ensemble]
  1825         -    } else {
  1826         -      set emap {}
  1827         -    }
  1828         -    foreach class [lreverse $clayorder] {
  1829         -      ###
  1830         -      # Build a compsite map of all ensembles defined by the object's current
  1831         -      # class as well as all of the classes being mixed in
  1832         -      ###
  1833         -      dict for {mensemble einfo} [$class clay get method_ensemble] {
  1834         -        if {$mensemble eq {.}} continue
  1835         -        set ensemble [string trim $mensemble :/]
  1836         -        if {$::clay::trace>2} {puts [list Defining $ensemble from $class]}
  1837         -
  1838         -        dict for {method info} $einfo {
  1839         -          if {$method eq {.}} continue
  1840         -          if {![dict is_dict $info]} {
  1841         -            puts [list WARNING: class: $class method: $method not dict: $info]
  1842         -            continue
  1843         -          }
  1844         -          dict set info source $class
  1845         -          if {$::clay::trace>2} {puts [list Defining $ensemble -> $method from $class - $info]}
  1846         -          dict set emap $ensemble $method $info
  1847         -        }
  1848         -      }
  1849         -    }
  1850         -    foreach {ensemble einfo} $emap {
  1851         -      #if {[dict exists $einfo _body]} continue
  1852         -      set body [::clay::ensemble_methodbody $ensemble $einfo]
  1853         -      if {$::clay::trace>2} {
  1854         -        set rawbody $body
  1855         -        set body {puts [list [self] <object> [self method]]}
  1856         -        append body \n $rawbody
  1857         -      }
  1858         -      oo::objdefine [self] method $ensemble {{method default} args} $body
  1859         -    }
  1860         -  }
  1861         -}
  1862         -::clay::object clay branch array
  1863         -::clay::object clay branch mixin
  1864         -::clay::object clay branch option
  1865         -::clay::object clay branch dict clay
  1866         -::clay::object clay set variable DestroyEvent 0
  1867         -namespace eval ::clay {
  1868         -  namespace export *
  1869         -}
  1870     60   
  1871     61   ###
  1872     62   # END: clay/clay.tcl
  1873     63   ###
  1874     64   ###
  1875     65   # START: setup.tcl
  1876     66   ###
................................................................................
  2076    266           Componant -
  2077    267           Delegate {
  2078    268             my keyword.Annotation info $commentblock delegate [lindex $thisline 1] [lindex $thisline 2]
  2079    269             set commentblock {}
  2080    270           }
  2081    271           method -
  2082    272           Ensemble {
  2083         -          my keyword.class_method info $commentblock  {*}[lrange $thisline 1 end-1]
          273  +          my keyword.Class_Method info $commentblock  {*}[lrange $thisline 1 end-1]
  2084    274             set commentblock {}
  2085    275           }
  2086    276         }
  2087    277         set thisline {}
  2088    278       }
  2089    279       dict set result class $name $info
  2090    280     }
................................................................................
  2131    321             my keyword.Annotation info $commentblock delegate [lindex $thisline 1] [lindex $thisline 2]
  2132    322             set commentblock {}
  2133    323           }
  2134    324           superclass {
  2135    325             dict set info ancestors [lrange $thisline 1 end]
  2136    326             set commentblock {}
  2137    327           }
  2138         -        class_method {
  2139         -          my keyword.class_method info $commentblock  {*}[lrange $thisline 1 end-1]
          328  +        classmethod -
          329  +        class_method -
          330  +        Class_Method {
          331  +          my keyword.Class_Method info $commentblock  {*}[lrange $thisline 1 end-1]
  2140    332             set commentblock {}
  2141    333           }
  2142    334           destructor -
  2143    335           constructor {
  2144    336             my keyword.method info $commentblock {*}[lrange $thisline 0 end-1]
  2145    337             set commentblock {}
  2146    338           }
................................................................................
  2150    342             set commentblock {}
  2151    343           }
  2152    344         }
  2153    345         set thisline {}
  2154    346       }
  2155    347       dict set result class $name $info
  2156    348     }
  2157         -  method keyword.class_method {resultvar commentblock name args} {
          349  +  method keyword.Class_Method {resultvar commentblock name args} {
  2158    350       upvar 1 $resultvar result
  2159    351       set info [my comment $commentblock]
  2160    352       if {[dict exists $info show_body] && [dict get $info show_body]} {
  2161    353         dict set info internals [lindex $args end]
  2162    354       }
  2163    355       if {[dict exists $info ensemble]} {
  2164    356         dict for {method minfo} [dict get $info ensemble] {
  2165         -        dict set result class_method "${name} $method" $minfo
          357  +        dict set result Class_Method "${name} $method" $minfo
  2166    358         }
  2167    359       } else {
  2168    360         switch [llength $args] {
  2169    361           1 {
  2170    362             set arglist [lindex $args 0]
  2171    363           }
  2172    364           0 {
................................................................................
  2174    366             #set body [lindex $args 0]
  2175    367           }
  2176    368           default {error "could not interpret method $name {*}$args"}
  2177    369         }
  2178    370         if {![dict exists $info arglist]} {
  2179    371           dict set info arglist [my arglist $arglist]
  2180    372         }
  2181         -      dict set result class_method [string trim $name :] $info
          373  +      dict set result Class_Method [string trim $name :] $info
  2182    374       }
  2183    375     }
  2184    376     method keyword.method {resultvar commentblock name args} {
  2185    377       upvar 1 $resultvar result
  2186    378       set info [my comment $commentblock]
  2187    379       if {[dict exists $info show_body] && [dict get $info show_body]} {
  2188    380         dict set info internals [lindex $args end]
................................................................................
  2371    563         foreach {c} [dict get $class_info ancestors] {
  2372    564           append line " \[class [string trim $c :]\]"
  2373    565         }
  2374    566         putb result $line
  2375    567         putb result {[para]}
  2376    568       }
  2377    569       dict for {f v} $class_info {
  2378         -      if {$f in {class_method method description ancestors example option variable delegate}} continue
          570  +      if {$f in {Class_Method method description ancestors example option variable delegate}} continue
  2379    571         putb result "\[emph \"$f\"\]: $v"
  2380    572         putb result {[para]}
  2381    573       }
  2382    574       if {[dict exists $class_info example]} {
  2383    575         putb result "\[example \{[list [dict get $class_info example]]\}\]"
  2384    576         putb result {[para]}
  2385    577       }
................................................................................
  2394    586         putb result {[list_begin definitions]}
  2395    587         dict for {item iinfo} [dict get $class_info $f] {
  2396    588           putb result [my section.annotation $f $item $iinfo]
  2397    589         }
  2398    590         putb result {[list_end]}
  2399    591         putb result {[para]}
  2400    592       }
  2401         -    if {[dict exists $class_info class_method]} {
          593  +    if {[dict exists $class_info Class_Method]} {
  2402    594         putb result "\[class \{Class Methods\}\]"
  2403    595         #putb result "Methods on the class object itself."
  2404    596         putb result {[list_begin definitions]}
  2405         -      dict for {method minfo} [dict get $class_info class_method] {
          597  +      dict for {method minfo} [dict get $class_info Class_Method] {
  2406    598           putb result [my section.method classmethod $method $minfo]
  2407    599         }
  2408    600         putb result {[list_end]}
  2409    601         putb result {[para]}
  2410    602       }
  2411    603       if {[dict exists $class_info method]} {
  2412    604         putb result "\[class {Methods}\]"
................................................................................
  4547   2739     }
  4548   2740     foreach item [$PROJECT link list package] {
  4549   2741       if {[string is true [$item define get static]]} {
  4550   2742         lappend PKG_OBJS $item
  4551   2743       }
  4552   2744     }
  4553   2745     array set TCL [$TCLOBJ read_configuration]
  4554         -  set path [file dirname $outfile]
         2746  +  set path [file dirname [file normalize $outfile]]
  4555   2747     cd $path
  4556   2748     ###
  4557   2749     # For a static Tcl shell, we need to build all local sources
  4558   2750     # with the same DEFS flags as the tcl core was compiled with.
  4559   2751     # The DEFS produced by a TEA extension aren't intended to operate
  4560   2752     # with the internals of a staticly linked Tcl
  4561   2753     ###
................................................................................
  4607   2799     append COMPILE " " $defs
  4608   2800     lappend OBJECTS {*}[my build-compile-sources $PROJECT $COMPILE $COMPILE $INCLUDES]
  4609   2801   
  4610   2802     set TCLSRC [file normalize $TCLSRCDIR]
  4611   2803   
  4612   2804     if {[${PROJECT} define get TEACUP_OS] eq "windows"} {
  4613   2805       set windres [$PROJECT define get RC windres]
  4614         -    set RSOBJ [file join $path build tclkit.res.o]
         2806  +    set RSOBJ [file join $path objs tclkit.res.o]
  4615   2807       set RCSRC [${PROJECT} define get kit_resource_file]
  4616   2808       set RCMAN [${PROJECT} define get kit_manifest_file]
         2809  +    set RCICO [${PROJECT} define get kit_icon_file]
  4617   2810   
  4618   2811       set cmd [list $windres -o $RSOBJ -DSTATIC_BUILD --include [::practcl::file_relative $path [file join $TCLSRC generic]]]
  4619   2812       if {[$PROJECT define get static_tk]} {
  4620   2813         if {$RCSRC eq {} || ![file exists $RCSRC]} {
  4621   2814           set RCSRC [file join $TKSRCDIR win rc wish.rc]
  4622   2815         }
  4623   2816         if {$RCMAN eq {} || ![file exists $RCMAN]} {
  4624   2817           set RCMAN [file join [$TKOBJ define get builddir] wish.exe.manifest]
  4625   2818         }
         2819  +      if {$RCICO eq {} || ![file exists $RCICO]} {
         2820  +        set RCICO [file join $TCLSRCDIR win rc wish.ico]
         2821  +      }
  4626   2822         set TKSRC [file normalize $TKSRCDIR]
  4627   2823         lappend cmd --include [::practcl::file_relative $path [file join $TKSRC generic]] \
  4628   2824           --include [::practcl::file_relative $path [file join $TKSRC win]] \
  4629   2825           --include [::practcl::file_relative $path [file join $TKSRC win rc]]
  4630   2826       } else {
  4631   2827         if {$RCSRC eq {} || ![file exists $RCSRC]} {
  4632         -        set RCSRC [file join $TCLSRCDIR tclsh.rc]
         2828  +        set RCSRC [file join $TCLSRCDIR win tclsh.rc]
  4633   2829         }
  4634   2830         if {$RCMAN eq {} || ![file exists $RCMAN]} {
  4635   2831           set RCMAN [file join [$TCLOBJ define get builddir] tclsh.exe.manifest]
  4636   2832         }
         2833  +      if {$RCICO eq {} || ![file exists $RCICO]} {
         2834  +        set RCICO [file join $TCLSRCDIR win tclsh.ico]
         2835  +      }
  4637   2836       }
  4638   2837       foreach item [${PROJECT} define get resource_include] {
  4639   2838         lappend cmd --include [::practcl::file_relative $path [file normalize $item]]
  4640   2839       }
  4641   2840       lappend cmd [file tail $RCSRC]
  4642   2841       if {![file exists [file join $path [file tail $RCSRC]]]} {
  4643   2842         file copy -force $RCSRC [file join $path [file tail $RCSRC]]
  4644   2843       }
  4645   2844       if {![file exists [file join $path [file tail $RCMAN]]]} {
  4646   2845         file copy -force $RCMAN [file join $path [file tail $RCMAN]]
  4647   2846       }
         2847  +    if {![file exists [file join $path [file tail $RCICO]]]} {
         2848  +      file copy -force $RCICO [file join $path [file tail $RCICO]]
         2849  +    }
  4648   2850       ::practcl::doexec {*}$cmd
  4649   2851       lappend OBJECTS $RSOBJ
  4650   2852     }
  4651   2853     puts "***"
  4652   2854     set cmd "$TCL(cc)"
  4653   2855     if {$debug} {
  4654   2856      append cmd " $TCL(cflags_debug)"
................................................................................
  7068   5270   
  7069   5271       set map {}
  7070   5272       foreach var {
  7071   5273         vfsroot mainhook mainfunc vfs_main
  7072   5274       } {
  7073   5275         dict set map %${var}% [set $var]
  7074   5276       }
         5277  +    set thread_init_script {namespace eval ::starkit {}}
         5278  +    append thread_init_script \n [list set ::starkit::topdir $vfsroot]
  7075   5279       set preinitscript {
  7076   5280   set ::odie(boot_vfs) %vfsroot%
  7077   5281   set ::SRCDIR $::odie(boot_vfs)
         5282  +namespace eval ::starkit {}
         5283  +set ::starkit::topdir %vfsroot%
  7078   5284   if {[file exists [file join %vfsroot% tcl_library init.tcl]]} {
  7079   5285     set ::tcl_library [file join %vfsroot% tcl_library]
  7080   5286     set ::auto_path {}
  7081   5287   }
  7082   5288   if {[file exists [file join %vfsroot% tk_library tk.tcl]]} {
  7083   5289     set ::tk_library [file join %vfsroot% tk_library]
  7084   5290   }
................................................................................
  7184   5390           error "$statpkg HAS NO VERSION"
  7185   5391         }
  7186   5392         # We employ a NULL to prevent the package system from thinking the
  7187   5393         # package is actually loaded into the interpreter
  7188   5394         $PROJECT code header "extern Tcl_PackageInitProc $initfunc\;\n"
  7189   5395         set script [list package ifneeded $statpkg [dict get $info version] [list ::load {} $statpkg]]
  7190   5396         append main_init_script \n [list set ::kitpkg(${statpkg}) $script]
         5397  +
  7191   5398         if {[dict get $info autoload]} {
  7192   5399           ::practcl::cputs appinit "  if(${initfunc}(interp)) return TCL_ERROR\;"
  7193   5400           ::practcl::cputs appinit "  Tcl_StaticPackage(interp,\"$statpkg\",$initfunc,NULL)\;"
  7194   5401         } else {
  7195   5402           ::practcl::cputs appinit "\n  Tcl_StaticPackage(NULL,\"$statpkg\",$initfunc,NULL)\;"
  7196   5403           append main_init_script \n $script
  7197   5404         }
  7198   5405       }
  7199   5406       append main_init_script \n {
  7200         -puts [list SRCDIR IS $::SRCDIR]
  7201         -if {[file exists [file join $::SRCDIR pkgIndex.tcl]]} {
         5407  +if {[file exists [file join $::starkit::topdir pkgIndex.tcl]]} {
  7202   5408     #In a wrapped exe, we don't go out to the environment
  7203         -  set dir $::SRCDIR
  7204         -  source [file join $::SRCDIR pkgIndex.tcl]
  7205         -}
         5409  +  set dir $::starkit::topdir
         5410  +  source [file join $::starkit::topdir pkgIndex.tcl]
         5411  +}}
         5412  +    append thread_init_script $main_init_script
         5413  +    append main_init_script \n {
  7206   5414   # Specify a user-specific startup file to invoke if the application
  7207   5415   # is run interactively.  Typically the startup file is "~/.apprc"
  7208   5416   # where "app" is the name of the application.  If this line is deleted
  7209   5417   # then no user-specific startup file will be run under any conditions.
  7210   5418   }
         5419  +    append thread_init_script \n [list set ::starkit::thread_init $thread_init_script]
         5420  +    append main_init_script \n [list set ::starkit::thread_init $thread_init_script]
  7211   5421       append main_init_script \n [list set tcl_rcFileName [$PROJECT define get tcl_rcFileName ~/.tclshrc]]
  7212         -    practcl::cputs appinit "  Tcl_Eval(interp,[::practcl::tcl_to_c  $main_init_script]);"
         5422  +
         5423  +
         5424  +    practcl::cputs appinit "  Tcl_Eval(interp,[::practcl::tcl_to_c  $thread_init_script]);"
  7213   5425       practcl::cputs appinit {  return TCL_OK;}
  7214   5426       $PROJECT c_function [string map $map "int %mainfunc%(Tcl_Interp *interp)"] [string map $map $appinit]
  7215   5427     }
  7216   5428     method Collate_Source CWD {
  7217   5429       next $CWD
  7218   5430       set name [my define get name]
  7219   5431       # Assume a static shell