TEA (tclconfig) Source Code

Check-in [4519879c71]
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:Updated practcl
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | practcl
Files: files | file ages | folders
SHA3-256: 4519879c7147255b19a25434ec8d1cdf6c989bba87ea79763076510b212f9ede
User & Date: hypnotoad 2018-10-25 17:53:46
Context
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
2018-10-25
17:53
Updated practcl check-in: 4519879c71 user: hypnotoad tags: practcl
2018-10-24
02:49
Removing windows line breaks check-in: 3daecc999e 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.13
            7  +package provide practcl 0.15
     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
................................................................................
    51     51       close $tmpchan
    52     52   }
    53     53   
    54     54   ###
    55     55   # END: httpwget/wget.tcl
    56     56   ###
    57     57   ###
    58         -# START: dicttool/build/core.tcl
    59         -###
           58  +# START: clay/clay.tcl
           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  +}
    60    473   namespace eval ::dicttool {
    61    474   }
    62         -proc ::PROC {name arglist body {ninja {}}} {
          475  +namespace eval ::tcllib {
          476  +}
          477  +proc ::tcllib::PROC {name arglist body {ninja {}}} {
    63    478     if {[info commands $name] ne {}} return
    64    479     proc $name $arglist $body
    65    480     eval $ninja
    66    481   }
    67         -PROC ::noop args {}
    68         -PROC ::putb {buffername args} {
          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} {
    69    492     upvar 1 $buffername buffer
    70    493     switch [llength $args] {
    71    494       1 {
    72    495         append buffer [lindex $args 0] \n
    73    496       }
    74    497       2 {
    75    498         append buffer [string map {*}$args] \n
    76    499       }
    77    500       default {
    78    501         error "usage: putb buffername ?map? string"
    79    502       }
    80    503     }
    81    504   }
    82         -
    83         -###
    84         -# END: dicttool/build/core.tcl
    85         -###
    86         -###
    87         -# START: dicttool/build/dict.tcl
    88         -###
    89         -PROC ::tcl::dict::getnull {dictionary args} {
          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} {
    90    510     if {[exists $dictionary {*}$args]} {
    91    511       get $dictionary {*}$args
    92    512     }
    93    513   } {
    94    514     namespace ensemble configure dict -map [dict replace\
    95    515         [namespace ensemble configure dict -map] getnull ::tcl::dict::getnull]
    96    516   }
    97         -PROC ::tcl::dict::is_dict { d } {
          517  +::tcllib::PROC ::tcl::dict::is_dict { d } {
    98    518     # is it a dict, or can it be treated like one?
    99    519     if {[catch {dict size $d} err]} {
   100    520       #::set ::errorInfo {}
   101    521       return 0
   102    522     }
   103    523     return 1
   104    524   } {
   105    525     namespace ensemble configure dict -map [dict replace\
   106    526         [namespace ensemble configure dict -map] is_dict ::tcl::dict::is_dict]
   107    527   }
   108         -PROC ::dicttool::is_branch { dict path } {
          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 } {
   109    556     set field [lindex $path end]
   110    557     if {[string index $field end] eq ":"} {
   111    558       return 0
   112    559     }
   113    560     if {[string index $field 0] eq "."} {
   114    561       return 0
   115    562     }
   116    563     if {[string index $field end] eq "/"} {
   117    564       return 1
   118    565     }
   119    566     return [dict exists $dict {*}$path .]
   120    567   }
   121         -PROC ::dicttool::print {dict} {
          568  +::tcllib::PROC ::dicttool::print {dict} {
   122    569     ::set result {}
   123    570     ::set level -1
   124    571     ::dicttool::_dictputb $level result $dict
   125    572     return $result
   126    573   }
   127         -proc ::dicttool::_dictputb {level varname dict} {
          574  +::tcllib::PROC ::dicttool::_dictputb {level varname dict} {
   128    575     upvar 1 $varname result
   129    576     incr level
   130    577     dict for {field value} $dict {
   131    578       if {$field eq "."} continue
   132    579       if {[dicttool::is_branch $dict $field]} {
   133    580         putb result "[string repeat "  " $level]$field \{"
   134    581         _dictputb $level result $value
   135    582         putb result "[string repeat "  " $level]\}"
   136    583       } else {
   137    584         putb result "[string repeat "  " $level][list $field $value]"
   138    585       }
   139    586     }
   140    587   }
   141         -PROC ::dicttool::sanitize {dict} {
          588  +proc ::dicttool::sanitize {dict} {
   142    589     ::set result {}
   143    590     ::set level -1
   144    591     ::dicttool::_sanitizeb {} result $dict
   145    592     return $result
   146    593   }
   147    594   proc ::dicttool::_sanitizeb {path varname dict} {
   148    595     upvar 1 $varname result
................................................................................
   151    598       if {[dicttool::is_branch $dict $field]} {
   152    599         _sanitizeb [list {*}$path $field] result $value
   153    600       } else {
   154    601         dict set result {*}$path $field $value
   155    602       }
   156    603     }
   157    604   }
   158         -proc ::dicttool::canonical {rawpath} {
   159         -  set path {}
   160         -  set tail [string index $rawpath end]
   161         -  foreach element $rawpath {
   162         -    set items [split [string trim $element /] /]
   163         -    foreach item $items {
   164         -      if {$item eq {}} continue
   165         -      if {$item eq {.}} continue
   166         -      lappend path [string trim ${item} :]/
   167         -    }
   168         -  }
   169         -  if {$tail eq {/}} {
   170         -    return $path
   171         -  } else {
   172         -    return [lreplace $path end end [string trim [lindex $path end] /]]
   173         -  }
   174         -}
   175    605   proc ::dicttool::storage {rawpath} {
   176    606     set isleafvar 0
   177    607     set path {}
   178    608     set tail [string index $rawpath end]
   179    609     foreach element $rawpath {
   180    610       set items [split [string trim $element /] /]
   181    611       foreach item $items {
   182    612         if {$item eq {}} continue
   183         -      lappend path [string trim ${item} :/]
          613  +      lappend path $item
   184    614       }
   185    615     }
   186    616     return $path
   187    617   }
   188    618   proc ::dicttool::dictset {varname args} {
   189    619     upvar 1 $varname result
   190    620     if {[llength $args] < 2} {
................................................................................
   191    621       error "Usage: ?path...? path value"
   192    622     } elseif {[llength $args]==2} {
   193    623       set rawpath [lindex $args 0]
   194    624     } else {
   195    625       set rawpath  [lrange $args 0 end-1]
   196    626     }
   197    627     set value [lindex $args end]
   198         -  set path [canonical $rawpath]
          628  +  set path [storage $rawpath]
   199    629     set dot .
   200         -  set one [string is true 1]
          630  +  set one {}
   201    631     dict set result $dot $one
   202    632     set dpath {}
   203         -  foreach item $path {
          633  +  foreach item [lrange $path 0 end-1] {
   204    634       set field $item
   205    635       lappend dpath [string trim $item /]
   206         -    if {[string index $item end] eq "/"} {
   207         -      dict set result {*}$dpath $dot $one
   208         -    }
          636  +    dict set result {*}$dpath $dot $one
   209    637     }
   210         -  if {[dict is_dict $value] && [dict exists $result {*}$dpath $dot]} {
   211         -    dict set result {*}$dpath [::dicttool::merge [dict get $result {*}$dpath] $value]
   212         -  } else {
   213         -    dict set result {*}$dpath $value
          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
   214    643     }
   215         -  return $result
          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
   216    652   }
   217    653   proc ::dicttool::dictmerge {varname args} {
   218    654     upvar 1 $varname result
   219    655     set dot .
   220         -  set one [string is true 1]
          656  +  set one {}
   221    657     dict set result $dot $one
   222    658     foreach dict $args {
   223    659       dict for {f v} $dict {
   224         -      set field [string trim $f :/]
          660  +      set field [string trim $f /]
   225    661         set bbranch [dicttool::is_branch $dict $f]
   226    662         if {![dict exists $result $field]} {
   227    663           dict set result $field $v
   228    664           if {$bbranch} {
   229    665             dict set result $field [dicttool::merge $v]
   230    666           } else {
   231    667             dict set result $field $v
................................................................................
   237    673             dict set result $field $v
   238    674           }
   239    675         }
   240    676       }
   241    677     }
   242    678     return $result
   243    679   }
   244         -PROC ::dicttool::merge {args} {
          680  +proc ::dicttool::merge {args} {
   245    681     ###
   246    682     # The result of a merge is always a dict with branches
   247    683     ###
   248    684     set dot .
   249         -  set one [string is true 1]
          685  +  set one {}
   250    686     dict set result $dot $one
   251    687     set argument 0
   252    688     foreach b $args {
   253    689       # Merge b into a, and handle nested dicts appropriately
   254    690       if {![dict is_dict $b]} {
   255    691         error "Element $b is not a dictionary"
   256    692       }
   257    693       dict for { k v } $b {
   258    694         if {$k eq $dot} {
   259    695           dict set result $dot $one
   260    696           continue
   261    697         }
   262    698         set bbranch [is_branch $b $k]
   263         -      set field [string trim $k /:]
          699  +      set field [string trim $k /]
   264    700         if { ![dict exists $result $field] } {
   265    701           if {$bbranch} {
   266    702             dict set result $field [merge $v]
   267    703           } else {
   268    704             dict set result $field $v
   269    705           }
   270    706         } else {
................................................................................
   278    714             }
   279    715           }
   280    716         }
   281    717       }
   282    718     }
   283    719     return $result
   284    720   }
   285         -PROC ::tcl::dict::isnull {dictionary args} {
          721  +::tcllib::PROC ::tcl::dict::isnull {dictionary args} {
   286    722     if {![exists $dictionary {*}$args]} {return 1}
   287    723     return [expr {[get $dictionary {*}$args] in {{} NULL null}}]
   288    724   } {
   289    725     namespace ensemble configure dict -map [dict replace\
   290    726         [namespace ensemble configure dict -map] isnull ::tcl::dict::isnull]
   291    727   }
   292         -
   293         -###
   294         -# END: dicttool/build/dict.tcl
   295         -###
   296         -###
   297         -# START: dicttool/build/list.tcl
   298         -###
   299         -PROC ::ladd {varname args} {
          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} {
   300    782     upvar 1 $varname var
   301    783     if ![info exists var] {
   302    784         set var {}
   303    785     }
   304    786     foreach item $args {
   305    787       if {$item in $var} continue
   306    788       lappend var $item
   307    789     }
   308    790     return $var
   309    791   }
   310         -PROC ::ldelete {varname args} {
          792  +::tcllib::PROC ::dicttool::ldelete {varname args} {
   311    793     upvar 1 $varname var
   312    794     if ![info exists var] {
   313    795         return
   314    796     }
   315    797     foreach item [lsort -unique $args] {
   316    798       while {[set i [lsearch $var $item]]>=0} {
   317    799         set var [lreplace $var $i $i]
   318    800       }
   319    801     }
   320    802     return $var
   321    803   }
   322         -PROC ::lrandom list {
          804  +::tcllib::PROC ::dicttool::lrandom list {
   323    805     set len [llength $list]
   324    806     set idx [expr int(rand()*$len)]
   325    807     return [lindex $list $idx]
   326    808   }
   327         -
   328         -###
   329         -# END: dicttool/build/list.tcl
   330         -###
   331         -###
   332         -# START: clay/build/procs.tcl
   333         -###
          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  +}
   334    821   namespace eval ::clay {
   335    822   }
   336    823   set ::clay::trace 0
   337    824   proc ::clay::ancestors args {
   338    825     set result {}
   339         -  set queue {}
   340         -  foreach class [lreverse $args] {
   341         -    lappend queue $class
   342         -  }
   343         -
   344         -  # Rig things such that that the top superclasses
   345         -  # are evaluated first
          826  +  set queue  [lreverse $args]
          827  +  set result $queue
          828  +  set metaclasses {}
   346    829     while {[llength $queue]} {
   347    830       set tqueue $queue
   348    831       set queue {}
   349    832       foreach qclass $tqueue {
   350    833         foreach aclass [::info class superclasses $qclass] {
   351    834           if { $aclass in $result } continue
   352    835           if { $aclass in $queue } continue
................................................................................
   355    838       }
   356    839       foreach item $tqueue {
   357    840         if { $item ni $result } {
   358    841           lappend result $item
   359    842         }
   360    843       }
   361    844     }
   362         -  return $result
          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
   363    858   }
   364    859   proc ::clay::args_to_dict args {
   365    860     if {[llength $args]==1} {
   366    861       return [lindex $args 0]
   367    862     }
   368    863     return $args
   369    864   }
................................................................................
   482    977   proc ::clay::uuid_generate args {
   483    978     return [uuid::uuid generate]
   484    979   }
   485    980   namespace eval ::clay {
   486    981     variable option_class {}
   487    982     variable core_classes {::oo::class ::oo::object}
   488    983   }
   489         -
   490         -###
   491         -# END: clay/build/procs.tcl
   492         -###
   493         -###
   494         -# START: clay/build/class.tcl
   495         -###
   496         -oo::define oo::class {
          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 {
   497   1213     method clay {submethod args} {
   498   1214       my variable clay
   499   1215       if {![info exists clay]} {
   500   1216         set clay {}
   501   1217       }
   502   1218       switch $submethod {
   503   1219         ancestors {
   504   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  +        }
   505   1227         }
   506   1228         exists {
   507   1229           if {![info exists clay]} {
   508   1230             return 0
   509   1231           }
   510         -        return [dict exists $clay {*}[::dicttool::storage $args]]
         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
   511   1240         }
   512   1241         dump {
   513   1242           return $clay
   514   1243         }
   515   1244         dget {
   516   1245            if {![info exists clay]} {
   517   1246             return {}
   518   1247           }
   519   1248           set path [::dicttool::storage $args]
   520         -        if {![dict exists $clay {*}$path]} {
   521         -          return {}
         1249  +        if {[dict exists $clay {*}$path]} {
         1250  +          return [dict get $clay {*}$path]
   522   1251           }
   523         -        return [dict get $clay {*}$path]
         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 .]
   524   1260         }
   525   1261         getnull -
   526   1262         get {
   527   1263           if {![info exists clay]} {
   528   1264             return {}
   529   1265           }
   530   1266           set path [::dicttool::storage $args]
         1267  +        if {[llength $path]==0} {
         1268  +          return $clay
         1269  +        }
   531   1270           if {[dict exists $clay {*}$path .]} {
   532   1271             return [::dicttool::sanitize [dict get $clay {*}$path]]
   533   1272           }
   534   1273           if {[dict exists $clay {*}$path]} {
   535   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]:]
   536   1278           }
   537   1279           return {}
   538   1280         }
   539   1281         find {
   540   1282           set path [::dicttool::storage $args]
   541   1283           if {![info exists clay]} {
   542   1284             set clay {}
   543   1285           }
   544   1286           set clayorder [::clay::ancestors [self]]
   545   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  +        }
   546   1295           foreach class $clayorder {
   547   1296             if {[$class clay exists {*}$path .]} {
   548   1297               # Found a branch break
   549   1298               set found 1
   550   1299               break
   551   1300             }
   552   1301             if {[$class clay exists {*}$path]} {
   553   1302               # Found a leaf. Return that value immediately
   554   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]:]
   555   1307             }
   556   1308           }
   557   1309           if {!$found} {
   558   1310             return {}
   559   1311           }
   560   1312           set result {}
   561   1313           # Leaf searches return one data field at a time
................................................................................
   567   1319           return [::dicttool::sanitize $result]
   568   1320         }
   569   1321         merge {
   570   1322           foreach arg $args {
   571   1323             ::dicttool::dictmerge clay {*}$arg
   572   1324           }
   573   1325         }
         1326  +      noop {
         1327  +        # Do nothing. Used as a sign of clay savviness
         1328  +      }
   574   1329         search {
   575   1330           foreach aclass [::clay::ancestors [self]] {
   576   1331             if {[$aclass clay exists {*}$args]} {
   577   1332               return [$aclass clay get {*}$args]
   578   1333             }
   579   1334           }
   580   1335         }
   581   1336         set {
   582   1337           ::dicttool::dictset clay {*}$args
   583   1338         }
         1339  +      unset {
         1340  +        dict unset clay {*}$args
         1341  +      }
   584   1342         default {
   585   1343           dict $submethod clay {*}$args
   586   1344         }
   587   1345       }
   588   1346     }
   589   1347   }
   590         -
   591         -###
   592         -# END: clay/build/class.tcl
   593         -###
   594         -###
   595         -# START: clay/build/object.tcl
   596         -###
   597         -oo::define oo::object {
         1348  +::oo::define ::clay::object {
   598   1349     method clay {submethod args} {
   599   1350       my variable clay claycache clayorder config option_canonical
   600   1351       if {![info exists clay]} {set clay {}}
   601   1352       if {![info exists claycache]} {set claycache {}}
   602   1353       if {![info exists config]} {set config {}}
   603   1354       if {![info exists clayorder] || [llength $clayorder]==0} {
   604   1355         set clayorder [::clay::ancestors [info object class [self]] {*}[info object mixins [self]]]
   605   1356       }
   606   1357       switch $submethod {
   607   1358         ancestors {
   608   1359           return $clayorder
         1360  +      }
         1361  +      branch {
         1362  +        set path [::dicttool::storage $args]
         1363  +        if {![dict exists $clay {*}$path .]} {
         1364  +          dict set clay {*}$path . {}
         1365  +        }
   609   1366         }
   610   1367         cget {
   611   1368           # Leaf searches return one data field at a time
   612   1369           # Search in our local dict
   613   1370           if {[llength $args]==1} {
   614   1371             set field [string trim [lindex $args 0] -:/]
   615   1372             if {[info exists option_canonical($field)]} {
................................................................................
   757   1514         }
   758   1515         forward {
   759   1516           oo::objdefine [self] forward {*}$args
   760   1517         }
   761   1518         dget {
   762   1519           # Search in our local cache
   763   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  +        }
   764   1531           #if {[dict exists $claycache {*}$path]} {
   765   1532           #  return [dict get $claycache {*}$path]
   766   1533           #}
   767   1534           if {[dict exists $clay {*}$path .]} {
   768   1535             # Path is a branch
   769   1536             set result {}
   770   1537             foreach class [lreverse $clayorder] {
................................................................................
   807   1574           }
   808   1575           dict set claycache {*}$path $result
   809   1576           return $result
   810   1577         }
   811   1578         getnull -
   812   1579         get {
   813   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  +        }
   814   1591           if {[dict exists $claycache {*}$path .]} {
   815   1592             return [::dicttool::sanitize [dict get $claycache {*}$path]]
   816   1593           }
   817   1594           if {[dict exists $claycache {*}$path]} {
   818   1595             return [dict get $claycache {*}$path]
   819   1596           }
   820   1597           if {[dict exists $clay {*}$path] && ![dict exists $clay {*}$path .]} {
................................................................................
   941   1718             set claycache {}
   942   1719             set classlist {}
   943   1720             foreach {item class} [dict get $clay .mixin] {
   944   1721               if {$class ne {}} {
   945   1722                 lappend classlist $class
   946   1723               }
   947   1724             }
   948         -          my clay mixin {*}$classlist
         1725  +          my clay mixin {*}[lreverse $classlist]
   949   1726           }
   950   1727         }
   951   1728         provenance {
   952   1729           if {[dict exists $clay {*}$args]} {
   953   1730             return self
   954   1731           }
   955   1732           foreach class $clayorder {
................................................................................
   998   1775         if { $var in {. clay} } continue
   999   1776         set var [string trim $var :/]
  1000   1777         my variable $var
  1001   1778         if {![info exists $var]} {
  1002   1779           set $var {}
  1003   1780         }
  1004   1781         foreach {f v} $value {
         1782  +        if {$f eq "."} continue
  1005   1783           if {![dict exists ${var} $f]} {
  1006   1784             if {$::clay::trace>2} {puts [list initialize dict $var $f $v]}
  1007   1785             dict set ${var} $f $v
  1008   1786           }
  1009   1787         }
  1010   1788       }
  1011         -    foreach {var value} [my clay get dict/] {
  1012         -      if { $var in {. clay} } continue
  1013         -      set var [string trim $var :/]
  1014         -      foreach {f v} [my clay get $var/] {
  1015         -        if {![dict exists ${var} $f]} {
  1016         -          if {$::clay::trace>2} {puts [list initialize dict (from const) $var $f $v]}
  1017         -          dict set ${var} $f $v
  1018         -        }
  1019         -      }
  1020         -    }
  1021   1789       foreach {var value} [my clay get array/] {
  1022   1790         if { $var in {. clay} } continue
  1023   1791         set var [string trim $var :/]
  1024   1792         if { $var eq {clay} } continue
  1025   1793         my variable $var
  1026   1794         if {![info exists $var]} { array set $var {} }
  1027   1795         foreach {f v} $value {
  1028   1796           if {![array exists ${var}($f)]} {
         1797  +          if {$f eq "."} continue
  1029   1798             if {$::clay::trace>2} {puts [list initialize array $var\($f\) $v]}
  1030   1799             set ${var}($f) $v
  1031   1800           }
  1032   1801         }
  1033   1802       }
  1034         -    foreach {var value} [my clay get array/] {
  1035         -      if { $var in {. clay} } continue
  1036         -      set var [string trim $var :/]
  1037         -      foreach {f v} [my clay get $var/] {
  1038         -        if {![array exists ${var}($f)]} {
  1039         -          if {$::clay::trace>2} {puts [list initialize array (from const) $var\($f\) $v]}
  1040         -          set ${var}($f) $v
  1041         -        }
  1042         -      }
  1043         -    }
  1044   1803       foreach {field info} [my clay get option/] {
  1045   1804         if { $field in {. clay} } continue
  1046   1805         set field [string trim $field -/:]
  1047   1806         foreach alias [dict getnull $info aliases] {
  1048   1807           set option_canonical($alias) $field
  1049   1808         }
  1050   1809         if {[dict exists $config $field]} continue
................................................................................
  1056   1815         }
  1057   1816         dict set config $field $value
  1058   1817         set setcmd [dict getnull $info set-command]
  1059   1818         if {$setcmd ne {}} {
  1060   1819           {*}[string map [list %field% [list $field] %value% [list $value] %self% [namespace which my]] $setcmd]
  1061   1820         }
  1062   1821       }
  1063         -  }
  1064         -}
  1065         -
  1066         -###
  1067         -# END: clay/build/object.tcl
  1068         -###
  1069         -###
  1070         -# START: clay/build/doctool.tcl
  1071         -###
  1072         -
  1073         -###
  1074         -# END: clay/build/doctool.tcl
         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  +
         1871  +###
         1872  +# END: clay/clay.tcl
  1075   1873   ###
  1076   1874   ###
  1077   1875   # START: setup.tcl
  1078   1876   ###
  1079   1877   package require TclOO
  1080   1878   set tcllib_path {}
  1081   1879   foreach path {.. ../.. ../../..} {
................................................................................
  1091   1889   namespace eval ::practcl::OBJECT {
  1092   1890   }
  1093   1891   
  1094   1892   ###
  1095   1893   # END: setup.tcl
  1096   1894   ###
  1097   1895   ###
  1098         -# START: docbuild.tcl
  1099         -###
  1100         -
  1101         -###
  1102         -# END: docbuild.tcl
         1896  +# START: doctool.tcl
         1897  +###
         1898  +namespace eval ::practcl {
         1899  +}
         1900  +proc ::practcl::cat fname {
         1901  +    if {![file exists $fname]} {
         1902  +       return
         1903  +    }
         1904  +    set fin [open $fname r]
         1905  +    set data [read $fin]
         1906  +    close $fin
         1907  +    return $data
         1908  +}
         1909  +proc ::practcl::docstrip text {
         1910  +  set result {}
         1911  +  foreach line [split $text \n] {
         1912  +    append thisline $line \n
         1913  +    if {![info complete $thisline]} continue
         1914  +    set outline $thisline
         1915  +    set thisline {}
         1916  +    if {[string trim $outline] eq {}} {
         1917  +      continue
         1918  +    }
         1919  +    if {[string index [string trim $outline] 0] eq "#"} continue
         1920  +    set cmd [string trim [lindex $outline 0] :]
         1921  +    if {$cmd eq "namespace" && [lindex $outline 1] eq "eval"} {
         1922  +      append result [list {*}[lrange $outline 0 end-1]] " " \{ \n [docstrip [lindex $outline end]]\} \n
         1923  +      continue
         1924  +    }
         1925  +    if {[string match "*::define" $cmd] && [llength $outline]==3} {
         1926  +      append result [list {*}[lrange $outline 0 end-1]] " " \{ \n [docstrip [lindex $outline end]]\} \n
         1927  +      continue
         1928  +    }
         1929  +    if {$cmd eq "oo::class" && [lindex $outline 1] eq "create"} {
         1930  +      append result [list {*}[lrange $outline 0 end-1]] " " \{ \n [docstrip [lindex $outline end]]\} \n
         1931  +      continue
         1932  +    }
         1933  +    append result $outline
         1934  +  }
         1935  +  return $result
         1936  +}
         1937  +proc ::putb {buffername args} {
         1938  +  upvar 1 $buffername buffer
         1939  +  switch [llength $args] {
         1940  +    1 {
         1941  +      append buffer [lindex $args 0] \n
         1942  +    }
         1943  +    2 {
         1944  +      append buffer [string map {*}$args] \n
         1945  +    }
         1946  +    default {
         1947  +      error "usage: putb buffername ?map? string"
         1948  +    }
         1949  +  }
         1950  +}
         1951  +::oo::class create ::practcl::doctool {
         1952  +  constructor {} {
         1953  +    my reset
         1954  +  }
         1955  +  method arglist {arglist} {
         1956  +    set result [dict create]
         1957  +    foreach arg $arglist {
         1958  +      set name [lindex $arg 0]
         1959  +      dict set result $name positional 1
         1960  +      dict set result $name mandatory  1
         1961  +      if {$name in {args dictargs}} {
         1962  +        switch [llength $arg] {
         1963  +          1 {
         1964  +            dict set result $name mandatory 0
         1965  +          }
         1966  +          2 {
         1967  +            dict for {optname optinfo} [lindex $arg 1] {
         1968  +              set optname [string trim $optname -:]
         1969  +              dict set result $optname {positional 1 mandatory 0}
         1970  +              dict for {f v} $optinfo {
         1971  +                dict set result $optname [string trim $f -:] $v
         1972  +              }
         1973  +            }
         1974  +          }
         1975  +          default {
         1976  +            error "Bad argument"
         1977  +          }
         1978  +        }
         1979  +      } else {
         1980  +        switch [llength $arg] {
         1981  +          1 {
         1982  +            dict set result $name mandatory 1
         1983  +          }
         1984  +          2 {
         1985  +            dict set result $name mandatory 0
         1986  +            dict set result $name default   [lindex $arg 1]
         1987  +          }
         1988  +          default {
         1989  +            error "Bad argument"
         1990  +          }
         1991  +        }
         1992  +      }
         1993  +    }
         1994  +    return $result
         1995  +  }
         1996  +  method comment block {
         1997  +    set count 0
         1998  +    set field description
         1999  +    set result [dict create description {}]
         2000  +    foreach line [split $block \n] {
         2001  +      set sline [string trim $line]
         2002  +      set fwidx [string first " " $sline]
         2003  +      if {$fwidx < 0} {
         2004  +        set firstword [string range $sline 0 end]
         2005  +        set restline {}
         2006  +      } else {
         2007  +        set firstword [string range $sline 0 [expr {$fwidx-1}]]
         2008  +        set restline [string range $sline [expr {$fwidx+1}] end]
         2009  +      }
         2010  +      if {[string index $firstword end] eq ":"} {
         2011  +        set field [string tolower [string trim $firstword -:]]
         2012  +        switch $field {
         2013  +          desc {
         2014  +            set field description
         2015  +          }
         2016  +        }
         2017  +        if {[string length $restline]} {
         2018  +          dict append result $field "$restline\n"
         2019  +        }
         2020  +      } else {
         2021  +        dict append result $field "$line\n"
         2022  +      }
         2023  +    }
         2024  +    return $result
         2025  +  }
         2026  +  method keyword.Annotation {resultvar commentblock type name body} {
         2027  +    upvar 1 $resultvar result
         2028  +    set name [string trim $name :]
         2029  +    if {[dict exists $result $type $name]} {
         2030  +      set info [dict get $result $type $name]
         2031  +    } else {
         2032  +      set info [my comment $commentblock]
         2033  +    }
         2034  +    foreach {f v} $body {
         2035  +      dict set info $f $v
         2036  +    }
         2037  +    dict set result $type $name $info
         2038  +  }
         2039  +  method keyword.Class {resultvar commentblock name body} {
         2040  +    upvar 1 $resultvar result
         2041  +    set name [string trim $name :]
         2042  +    if {[dict exists $result class $name]} {
         2043  +      set info [dict get $result class $name]
         2044  +    } else {
         2045  +      set info [my comment $commentblock]
         2046  +    }
         2047  +    set commentblock {}
         2048  +    foreach line [split $body \n] {
         2049  +      append thisline $line \n
         2050  +      if {![info complete $thisline]} continue
         2051  +      set thisline [string trim $thisline]
         2052  +      if {[string index $thisline 0] eq "#"} {
         2053  +        append commentblock [string trimleft $thisline #] \n
         2054  +        set thisline {}
         2055  +        continue
         2056  +      }
         2057  +      set cmd [string trim [lindex $thisline 0] ":"]
         2058  +      switch $cmd {
         2059  +        Option -
         2060  +        option {
         2061  +          my keyword.Annotation info $commentblock option [lindex $thisline 1] [lindex $thisline 2]
         2062  +          set commentblock {}
         2063  +        }
         2064  +        variable -
         2065  +        Variable {
         2066  +          my keyword.Annotation info $commentblock variable [lindex $thisline 1] [list type scaler default [lindex $thisline 2]]
         2067  +          set commentblock {}
         2068  +        }
         2069  +        Dict -
         2070  +        Array {
         2071  +          set iinfo [lindex $thisline 2]
         2072  +          dict set iinfo type [string tolower $cmd]
         2073  +          my keyword.Annotation info $commentblock variable [lindex $thisline 1] $iinfo
         2074  +          set commentblock {}
         2075  +        }
         2076  +        Componant -
         2077  +        Delegate {
         2078  +          my keyword.Annotation info $commentblock delegate [lindex $thisline 1] [lindex $thisline 2]
         2079  +          set commentblock {}
         2080  +        }
         2081  +        method -
         2082  +        Ensemble {
         2083  +          my keyword.class_method info $commentblock  {*}[lrange $thisline 1 end-1]
         2084  +          set commentblock {}
         2085  +        }
         2086  +      }
         2087  +      set thisline {}
         2088  +    }
         2089  +    dict set result class $name $info
         2090  +  }
         2091  +  method keyword.class {resultvar commentblock name body} {
         2092  +    upvar 1 $resultvar result
         2093  +    set name [string trim $name :]
         2094  +    if {[dict exists $result class $name]} {
         2095  +      set info [dict get $result class $name]
         2096  +    } else {
         2097  +      set info [my comment $commentblock]
         2098  +    }
         2099  +    set commentblock {}
         2100  +    foreach line [split $body \n] {
         2101  +      append thisline $line \n
         2102  +      if {![info complete $thisline]} continue
         2103  +      set thisline [string trim $thisline]
         2104  +      if {[string index $thisline 0] eq "#"} {
         2105  +        append commentblock [string trimleft $thisline #] \n
         2106  +        set thisline {}
         2107  +        continue
         2108  +      }
         2109  +      set cmd [string trim [lindex $thisline 0] ":"]
         2110  +      switch $cmd {
         2111  +        Option -
         2112  +        option {
         2113  +          puts [list keyword.Annotation $cmd $thisline]
         2114  +          my keyword.Annotation info $commentblock option [lindex $thisline 1] [lindex $thisline 2]
         2115  +          set commentblock {}
         2116  +        }
         2117  +        variable -
         2118  +        Variable {
         2119  +          my keyword.Annotation info $commentblock variable [lindex $thisline 1] [list default [lindex $thisline 2]]
         2120  +          set commentblock {}
         2121  +        }
         2122  +        Dict -
         2123  +        Array {
         2124  +          set iinfo [lindex $thisline 2]
         2125  +          dict set iinfo type [string tolower $cmd]
         2126  +          my keyword.Annotation info $commentblock variable [lindex $thisline 1] $iinfo
         2127  +          set commentblock {}
         2128  +        }
         2129  +        Componant -
         2130  +        Delegate {
         2131  +          my keyword.Annotation info $commentblock delegate [lindex $thisline 1] [lindex $thisline 2]
         2132  +          set commentblock {}
         2133  +        }
         2134  +        superclass {
         2135  +          dict set info ancestors [lrange $thisline 1 end]
         2136  +          set commentblock {}
         2137  +        }
         2138  +        class_method {
         2139  +          my keyword.class_method info $commentblock  {*}[lrange $thisline 1 end-1]
         2140  +          set commentblock {}
         2141  +        }
         2142  +        destructor -
         2143  +        constructor {
         2144  +          my keyword.method info $commentblock {*}[lrange $thisline 0 end-1]
         2145  +          set commentblock {}
         2146  +        }
         2147  +        method -
         2148  +        Ensemble {
         2149  +          my keyword.method info $commentblock  {*}[lrange $thisline 1 end-1]
         2150  +          set commentblock {}
         2151  +        }
         2152  +      }
         2153  +      set thisline {}
         2154  +    }
         2155  +    dict set result class $name $info
         2156  +  }
         2157  +  method keyword.class_method {resultvar commentblock name args} {
         2158  +    upvar 1 $resultvar result
         2159  +    set info [my comment $commentblock]
         2160  +    if {[dict exists $info show_body] && [dict get $info show_body]} {
         2161  +      dict set info internals [lindex $args end]
         2162  +    }
         2163  +    if {[dict exists $info ensemble]} {
         2164  +      dict for {method minfo} [dict get $info ensemble] {
         2165  +        dict set result class_method "${name} $method" $minfo
         2166  +      }
         2167  +    } else {
         2168  +      switch [llength $args] {
         2169  +        1 {
         2170  +          set arglist [lindex $args 0]
         2171  +        }
         2172  +        0 {
         2173  +          set arglist dictargs
         2174  +          #set body [lindex $args 0]
         2175  +        }
         2176  +        default {error "could not interpret method $name {*}$args"}
         2177  +      }
         2178  +      if {![dict exists $info arglist]} {
         2179  +        dict set info arglist [my arglist $arglist]
         2180  +      }
         2181  +      dict set result class_method [string trim $name :] $info
         2182  +    }
         2183  +  }
         2184  +  method keyword.method {resultvar commentblock name args} {
         2185  +    upvar 1 $resultvar result
         2186  +    set info [my comment $commentblock]
         2187  +    if {[dict exists $info show_body] && [dict get $info show_body]} {
         2188  +      dict set info internals [lindex $args end]
         2189  +    }
         2190  +    if {[dict exists $info ensemble]} {
         2191  +      dict for {method minfo} [dict get $info ensemble] {
         2192  +        dict set result method "\"${name} $method\"" $minfo
         2193  +      }
         2194  +    } else {
         2195  +      switch [llength $args] {
         2196  +        1 {
         2197  +          set arglist [lindex $args 0]
         2198  +        }
         2199  +        0 {
         2200  +          set arglist dictargs
         2201  +          #set body [lindex $args 0]
         2202  +        }
         2203  +        default {error "could not interpret method $name {*}$args"}
         2204  +      }
         2205  +      if {![dict exists $info arglist]} {
         2206  +        dict set info arglist [my arglist $arglist]
         2207  +      }
         2208  +      dict set result method "\"[split [string trim $name :] ::]\"" $info
         2209  +    }
         2210  +  }
         2211  +  method keyword.proc {commentblock name arglist} {
         2212  +    set info [my comment $commentblock]
         2213  +    if {![dict exists $info arglist]} {
         2214  +      dict set info arglist [my arglist $arglist]
         2215  +    }
         2216  +    return $info
         2217  +  }
         2218  +  method reset {} {
         2219  +    my variable coro
         2220  +    set coro [info object namespace [self]]::coro
         2221  +    oo::objdefine [self] forward coro $coro
         2222  +    if {[info command $coro] ne {}} {
         2223  +      rename $coro {}
         2224  +    }
         2225  +    coroutine $coro {*}[namespace code {my Main}]
         2226  +  }
         2227  +  method Main {} {
         2228  +
         2229  +    my variable info
         2230  +    set info [dict create]
         2231  +    yield [info coroutine]
         2232  +    set thisline {}
         2233  +    set commentblock {}
         2234  +    set linec 0
         2235  +    while 1 {
         2236  +      set line [yield]
         2237  +      append thisline $line \n
         2238  +      if {![info complete $thisline]} continue
         2239  +      set thisline [string trim $thisline]
         2240  +      if {[string index $thisline 0] eq "#"} {
         2241  +        append commentblock [string trimleft $thisline #] \n
         2242  +        set thisline {}
         2243  +        continue
         2244  +      }
         2245  +      set cmd [string trim [lindex $thisline 0] ":"]
         2246  +      switch $cmd {
         2247  +        dictargs::proc {
         2248  +          set procinfo [my keyword.proc $commentblock [lindex $thisline 1] [list args [list dictargs [lindex $thisline 2]]]]
         2249  +          if {[dict exists $procinfo show_body] && [dict get $procinfo show_body]} {
         2250  +            dict set procinfo internals [lindex $thisline end]
         2251  +          }
         2252  +          dict set info proc [string trim [lindex $thisline 1] :] $procinfo
         2253  +          set commentblock {}
         2254  +        }
         2255  +        tcllib::PROC -
         2256  +        PROC -
         2257  +        Proc -
         2258  +        proc {
         2259  +          set procinfo [my keyword.proc $commentblock {*}[lrange $thisline 1 2]]
         2260  +          if {[dict exists $procinfo show_body] && [dict get $procinfo show_body]} {
         2261  +            dict set procinfo internals [lindex $thisline end]
         2262  +          }
         2263  +          dict set info proc [string trim [lindex $thisline 1] :] $procinfo
         2264  +          set commentblock {}
         2265  +        }
         2266  +        oo::objdefine {
         2267  +          if {[llength $thisline]==3} {
         2268  +            lassign $thisline tcmd name body
         2269  +            my keyword.Class info $commentblock $name $body
         2270  +          } else {
         2271  +            puts "Warning: bare oo::define in library"
         2272  +          }
         2273  +        }
         2274  +        oo::define {
         2275  +          if {[llength $thisline]==3} {
         2276  +            lassign $thisline tcmd name body
         2277  +            my keyword.class info $commentblock $name $body
         2278  +          } else {
         2279  +            puts "Warning: bare oo::define in library"
         2280  +          }
         2281  +        }
         2282  +        tao::define -
         2283  +        clay::define -
         2284  +        tool::define {
         2285  +          lassign $thisline tcmd name body
         2286  +          my keyword.class info $commentblock $name $body
         2287  +          set commentblock {}
         2288  +        }
         2289  +        oo::class {
         2290  +          lassign $thisline tcmd mthd name body
         2291  +          my keyword.class info $commentblock $name $body
         2292  +          set commentblock {}
         2293  +        }
         2294  +        default {
         2295  +          if {[lindex [split $cmd ::] end] eq "define"} {
         2296  +            lassign $thisline tcmd name body
         2297  +            my keyword.class info $commentblock $name $body
         2298  +            set commentblock {}
         2299  +          }
         2300  +          set commentblock {}
         2301  +        }
         2302  +      }
         2303  +      set thisline {}
         2304  +    }
         2305  +  }
         2306  +  method section.method {keyword method minfo} {
         2307  +    set result {}
         2308  +    set line "\[call $keyword \[cmd $method\]"
         2309  +    if {[dict exists $minfo arglist]} {
         2310  +      dict for {argname arginfo} [dict get $minfo arglist] {
         2311  +        set positional 1
         2312  +        set mandatory  1
         2313  +        set repeating 0
         2314  +        dict with arginfo {}
         2315  +        if {$mandatory==0} {
         2316  +          append line " \[opt \""
         2317  +        } else {
         2318  +          append line " "
         2319  +        }
         2320  +        if {$positional} {
         2321  +          append line "\[arg $argname"
         2322  +        } else {
         2323  +          append line "\[option \"$argname"
         2324  +          if {[dict exists $arginfo type]} {
         2325  +            append line " \[emph [dict get $arginfo type]\]"
         2326  +          } else {
         2327  +            append line " \[emph value\]"
         2328  +          }
         2329  +          append line "\""
         2330  +        }
         2331  +        append line "\]"
         2332  +        if {$mandatory==0} {
         2333  +          if {[dict exists $arginfo default]} {
         2334  +            append line " \[const \"[dict get $arginfo default]\"\]"
         2335  +          }
         2336  +          append line "\"\]"
         2337  +        }
         2338  +        if {$repeating} {
         2339  +          append line " \[opt \[option \"$argname...\"\]\]"
         2340  +        }
         2341  +      }
         2342  +    }
         2343  +    append line \]
         2344  +    putb result $line
         2345  +    if {[dict exists $minfo description]} {
         2346  +      putb result [dict get $minfo description]
         2347  +    }
         2348  +    if {[dict exists $minfo example]} {
         2349  +      putb result "\[para\]Example: \[example [list [dict get $minfo example]]\]"
         2350  +    }
         2351  +    if {[dict exists $minfo internals]} {
         2352  +      putb result "\[para\]Internals: \[example [list [dict get $minfo internals]]\]"
         2353  +    }
         2354  +    return $result
         2355  +  }
         2356  +  method section.annotation {type name iinfo} {
         2357  +    set result "\[call $type \[cmd $name\]\]"
         2358  +    if {[dict exists $iinfo description]} {
         2359  +      putb result [dict get $iinfo description]
         2360  +    }
         2361  +    if {[dict exists $iinfo example]} {
         2362  +      putb result "\[para\]Example: \[example [list [dict get $minfo example]]\]"
         2363  +    }
         2364  +    return $result
         2365  +  }
         2366  +  method section.class {class_name class_info} {
         2367  +    set result {}
         2368  +    putb result "\[subsection \{Class  $class_name\}\]"
         2369  +    if {[dict exists $class_info ancestors]} {
         2370  +      set line "\[emph \"ancestors\"\]:"
         2371  +      foreach {c} [dict get $class_info ancestors] {
         2372  +        append line " \[class [string trim $c :]\]"
         2373  +      }
         2374  +      putb result $line
         2375  +      putb result {[para]}
         2376  +    }
         2377  +    dict for {f v} $class_info {
         2378  +      if {$f in {class_method method description ancestors example option variable delegate}} continue
         2379  +      putb result "\[emph \"$f\"\]: $v"
         2380  +      putb result {[para]}
         2381  +    }
         2382  +    if {[dict exists $class_info example]} {
         2383  +      putb result "\[example \{[list [dict get $class_info example]]\}\]"
         2384  +      putb result {[para]}
         2385  +    }
         2386  +    if {[dict exists $class_info description]} {
         2387  +      putb result [dict get $class_info description]
         2388  +      putb result {[para]}
         2389  +    }
         2390  +    dict for {f v} $class_info {
         2391  +      if {$f ni {option variable delegate}} continue
         2392  +      putb result "\[class \{[string totitle $f]\}\]"
         2393  +      #putb result "Methods on the class object itself."
         2394  +      putb result {[list_begin definitions]}
         2395  +      dict for {item iinfo} [dict get $class_info $f] {
         2396  +        putb result [my section.annotation $f $item $iinfo]
         2397  +      }
         2398  +      putb result {[list_end]}
         2399  +      putb result {[para]}
         2400  +    }
         2401  +    if {[dict exists $class_info class_method]} {
         2402  +      putb result "\[class \{Class Methods\}\]"
         2403  +      #putb result "Methods on the class object itself."
         2404  +      putb result {[list_begin definitions]}
         2405  +      dict for {method minfo} [dict get $class_info class_method] {
         2406  +        putb result [my section.method classmethod $method $minfo]
         2407  +      }
         2408  +      putb result {[list_end]}
         2409  +      putb result {[para]}
         2410  +    }
         2411  +    if {[dict exists $class_info method]} {
         2412  +      putb result "\[class {Methods}\]"
         2413  +      putb result {[list_begin definitions]}
         2414  +      dict for {method minfo} [dict get $class_info method] {
         2415  +        putb result [my section.method method $method $minfo]
         2416  +      }
         2417  +      putb result {[list_end]}
         2418  +      putb result {[para]}
         2419  +    }
         2420  +    return $result
         2421  +  }
         2422  +  method section.command {procinfo} {
         2423  +    set result {}
         2424  +    putb result "\[section \{Commands\}\]"
         2425  +    putb result {[list_begin definitions]}
         2426  +    dict for {method minfo} $procinfo {
         2427  +      putb result [my section.method proc $method $minfo]
         2428  +    }
         2429  +    putb result {[list_end]}
         2430  +    return $result
         2431  +  }
         2432  +  method manpage args {
         2433  +    my variable info
         2434  +    set map {%version% 0.0 %module% {Your_Module_Here}}
         2435  +    set result {}
         2436  +    set header {}
         2437  +    set footer {}
         2438  +    set authors {}
         2439  +    dict with args {}
         2440  +    dict set map %keyword% comment
         2441  +    putb result $map {[%keyword% {-*- tcl -*- doctools manpage}]
         2442  +[vset PACKAGE_VERSION %version%]
         2443  +[manpage_begin %module% n [vset PACKAGE_VERSION]]}
         2444  +    putb result $map $header
         2445  +
         2446  +    dict for {sec_type sec_info} $info {
         2447  +      switch $sec_type {
         2448  +        proc {
         2449  +          putb result [my section.command $sec_info]
         2450  +        }
         2451  +        class {
         2452  +          putb result "\[section Classes\]"
         2453  +          dict for {class_name class_info} $sec_info {
         2454  +            putb result [my section.class $class_name $class_info]
         2455  +          }
         2456  +        }
         2457  +        default {
         2458  +          putb result "\[section [list $sec_type $sec_name]\]"
         2459  +          if {[dict exists $sec_info description]} {
         2460  +            putb result [dict get $sec_info description]
         2461  +          }
         2462  +        }
         2463  +      }
         2464  +    }
         2465  +    if {[llength $authors]} {
         2466  +      putb result {[section AUTHORS]}
         2467  +      foreach {name email} $authors {
         2468  +        putb result "$name \[uri mailto:$email\]\[para\]"
         2469  +      }
         2470  +    }
         2471  +    putb result $footer
         2472  +    putb result {[manpage_end]}
         2473  +    return $result
         2474  +  }
         2475  +  method scan_text {text} {
         2476  +    my variable linecount coro
         2477  +    set linecount 0
         2478  +    foreach line [split $text \n] {
         2479  +      incr linecount
         2480  +      $coro $line
         2481  +    }
         2482  +  }
         2483  +  method scan_file {filename} {
         2484  +    my variable linecount coro
         2485  +    set fin [open $filename r]
         2486  +    set linecount 0
         2487  +    while {[gets $fin line]>=0} {
         2488  +      incr linecount
         2489  +      $coro $line
         2490  +    }
         2491  +    close $fin
         2492  +  }
         2493  +}
         2494  +
         2495  +###
         2496  +# END: doctool.tcl
  1103   2497   ###
  1104   2498   ###
  1105   2499   # START: buildutil.tcl
  1106   2500   ###
  1107   2501   proc Proc {name arglist body} {
  1108   2502     if {[info command $name] ne {}} return
  1109   2503     proc $name $arglist $body
................................................................................
  1731   3125   
  1732   3126   ###
  1733   3127   # END: buildutil.tcl
  1734   3128   ###
  1735   3129   ###
  1736   3130   # START: fileutil.tcl
  1737   3131   ###
  1738         -proc ::practcl::cat fname {
  1739         -    if {![file exists $fname]} {
  1740         -       return
  1741         -    }
  1742         -    set fin [open $fname r]
  1743         -    set data [read $fin]
  1744         -    close $fin
  1745         -    return $data
  1746         -}
  1747   3132   proc ::practcl::grep {pattern {files {}}} {
  1748   3133       set result [list]
  1749   3134       if {[llength $files] == 0} {
  1750         -	      # read from stdin
  1751         -    	  set lnum 0
  1752         -	      while {[gets stdin line] >= 0} {
  1753         -	          incr lnum
  1754         -    	      if {[regexp -- $pattern $line]} {
  1755         -		            lappend result "${lnum}:${line}"
  1756         -	          }
  1757         -    	  }
         3135  +            # read from stdin
         3136  +            set lnum 0
         3137  +            while {[gets stdin line] >= 0} {
         3138  +                incr lnum
         3139  +                if {[regexp -- $pattern $line]} {
         3140  +                        lappend result "${lnum}:${line}"
         3141  +                }
         3142  +            }
  1758   3143       } else {
  1759         -	      foreach filename $files {
         3144  +            foreach filename $files {
  1760   3145               set file [open $filename r]
  1761   3146               set lnum 0
  1762   3147               while {[gets $file line] >= 0} {
  1763   3148                   incr lnum
  1764   3149                   if {[regexp -- $pattern $line]} {
  1765   3150                       lappend result "${filename}:${lnum}:${line}"
  1766   3151                   }
  1767   3152               }
  1768   3153               close $file
  1769         -    	  }
         3154  +            }
  1770   3155       }
  1771   3156       return $result
  1772   3157   }
  1773   3158   proc ::practcl::file_lexnormalize {sp} {
  1774   3159       set spx [file split $sp]
  1775   3160   
  1776   3161       # Resolution of embedded relative modifiers (., and ..).
  1777   3162   
  1778   3163       if {
  1779         -	([lsearch -exact $spx . ] < 0) &&
  1780         -	([lsearch -exact $spx ..] < 0)
         3164  +      ([lsearch -exact $spx . ] < 0) &&
         3165  +      ([lsearch -exact $spx ..] < 0)
  1781   3166       } {
  1782         -	# Quick path out if there are no relative modifiers
  1783         -	return $sp
         3167  +      # Quick path out if there are no relative modifiers
         3168  +      return $sp
  1784   3169       }
  1785   3170   
  1786   3171       set absolute [expr {![string equal [file pathtype $sp] relative]}]
  1787   3172       # A volumerelative path counts as absolute for our purposes.
  1788   3173   
  1789   3174       set sp $spx
  1790   3175       set np {}
  1791   3176       set noskip 1
  1792   3177   
  1793   3178       while {[llength $sp]} {
  1794         -	set ele    [lindex $sp 0]
  1795         -	set sp     [lrange $sp 1 end]
  1796         -	set islast [expr {[llength $sp] == 0}]
  1797         -
  1798         -	if {[string equal $ele ".."]} {
  1799         -	    if {
  1800         -		($absolute  && ([llength $np] >  1)) ||
  1801         -		(!$absolute && ([llength $np] >= 1))
  1802         -	    } {
  1803         -		# .. : Remove the previous element added to the
  1804         -		# new path, if there actually is enough to remove.
  1805         -		set np [lrange $np 0 end-1]
  1806         -	    }
  1807         -	} elseif {[string equal $ele "."]} {
  1808         -	    # Ignore .'s, they stay at the current location
  1809         -	    continue
  1810         -	} else {
  1811         -	    # A regular element.
  1812         -	    lappend np $ele
  1813         -	}
         3179  +      set ele    [lindex $sp 0]
         3180  +      set sp     [lrange $sp 1 end]
         3181  +      set islast [expr {[llength $sp] == 0}]
         3182  +
         3183  +      if {[string equal $ele ".."]} {
         3184  +          if {
         3185  +            ($absolute  && ([llength $np] >  1)) ||
         3186  +            (!$absolute && ([llength $np] >= 1))
         3187  +          } {
         3188  +            # .. : Remove the previous element added to the
         3189  +            # new path, if there actually is enough to remove.
         3190  +            set np [lrange $np 0 end-1]
         3191  +          }
         3192  +      } elseif {[string equal $ele "."]} {
         3193  +          # Ignore .'s, they stay at the current location
         3194  +          continue
         3195  +      } else {
         3196  +          # A regular element.
         3197  +          lappend np $ele
         3198  +      }
  1814   3199       }
  1815   3200       if {[llength $np] > 0} {
  1816         -	return [eval [linsert $np 0 file join]]
  1817         -	# 8.5: return [file join {*}$np]
         3201  +      return [eval [linsert $np 0 file join]]
         3202  +      # 8.5: return [file join {*}$np]
  1818   3203       }
  1819   3204       return {}
  1820   3205   }
  1821   3206   proc ::practcl::file_relative {base dst} {
  1822   3207       # Ensure that the link to directory 'dst' is properly done relative to
  1823   3208       # the directory 'base'.
  1824   3209   
  1825   3210       if {![string equal [file pathtype $base] [file pathtype $dst]]} {
  1826         -	return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $base] vs. [file pathtype $dst], ($base vs. $dst)"
         3211  +      return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $base] vs. [file pathtype $dst], ($base vs. $dst)"
  1827   3212       }
  1828   3213   
  1829   3214       set base [file_lexnormalize [file join [pwd] $base]]
  1830   3215       set dst  [file_lexnormalize [file join [pwd] $dst]]
  1831   3216   
  1832   3217       set save $dst
  1833   3218       set base [file split $base]
  1834   3219       set dst  [file split $dst]
  1835   3220   
  1836   3221       while {[string equal [lindex $dst 0] [lindex $base 0]]} {
  1837         -	set dst  [lrange $dst  1 end]
  1838         -	set base [lrange $base 1 end]
  1839         -	if {![llength $dst]} {break}
         3222  +      set dst  [lrange $dst  1 end]
         3223  +      set base [lrange $base 1 end]
         3224  +      if {![llength $dst]} {break}
  1840   3225       }
  1841   3226   
  1842   3227       set dstlen  [llength $dst]
  1843   3228       set baselen [llength $base]
  1844   3229   
  1845   3230       if {($dstlen == 0) && ($baselen == 0)} {
  1846         -	# Cases:
  1847         -	# (a) base == dst
         3231  +      # Cases:
         3232  +      # (a) base == dst
  1848   3233   
  1849         -	set dst .
         3234  +      set dst .
  1850   3235       } else {
  1851         -	# Cases:
  1852         -	# (b) base is: base/sub = sub
  1853         -	#     dst  is: base     = {}
         3236  +      # Cases:
         3237  +      # (b) base is: base/sub = sub
         3238  +      #     dst  is: base     = {}
  1854   3239   
  1855         -	# (c) base is: base     = {}
  1856         -	#     dst  is: base/sub = sub
         3240  +      # (c) base is: base     = {}
         3241  +      #     dst  is: base/sub = sub
  1857   3242   
  1858         -	while {$baselen > 0} {
  1859         -	    set dst [linsert $dst 0 ..]
  1860         -	    incr baselen -1
  1861         -	}
  1862         -	# 8.5: set dst [file join {*}$dst]
  1863         -	set dst [eval [linsert $dst 0 file join]]
         3243  +      while {$baselen > 0} {
         3244  +          set dst [linsert $dst 0 ..]
         3245  +          incr baselen -1
         3246  +      }
         3247  +      # 8.5: set dst [file join {*}$dst]
         3248  +      set dst [eval [linsert $dst 0 file join]]
  1864   3249       }
  1865   3250   
  1866   3251       return $dst
         3252  +}
         3253  +proc ::practcl::findByPattern {basedir patterns} {
         3254  +    set queue $basedir
         3255  +    set result {}
         3256  +    while {[llength $queue]} {
         3257  +      set item [lindex $queue 0]
         3258  +      set queue [lrange $queue 1 end]
         3259  +      if {[file isdirectory $item]} {
         3260  +        foreach path [glob -nocomplain [file join $item *]] {
         3261  +          lappend queue $path
         3262  +        }
         3263  +        continue
         3264  +      }
         3265  +      foreach pattern $patterns {
         3266  +        set fname [file tail $item]
         3267  +        if {[string match $pattern $fname]} {
         3268  +          lappend result $item
         3269  +          break
         3270  +        }
         3271  +      }
         3272  +    }
         3273  +    return $result
  1867   3274   }
  1868   3275   proc ::practcl::log {fname comment} {
  1869   3276     set fname [file normalize $fname]
  1870   3277     if {[info exists ::practcl::logchan($fname)]} {
  1871   3278       set fout $::practcl::logchan($fname)
  1872   3279       after cancel $::practcl::logevent($fname)
  1873   3280     } else {
................................................................................
  1880   3287   
  1881   3288   ###
  1882   3289   # END: fileutil.tcl
  1883   3290   ###
  1884   3291   ###
  1885   3292   # START: installutil.tcl
  1886   3293   ###
  1887         -proc ::practcl::_isdirectory name {
  1888         -  return [file isdirectory $name]
         3294  +proc ::practcl::_pkgindex_simpleIndex {path} {
         3295  +set buffer {}
         3296  +  set pkgidxfile    [file join $path pkgIndex.tcl]
         3297  +  set modfile       [file join $path [file tail $path].tcl]
         3298  +  set use_pkgindex  [file exists $pkgidxfile]
         3299  +  set tclfiles      {}
         3300  +  set found 0
         3301  +  set mlist [list pkgIndex.tcl index.tcl [file tail $modfile] version_info.tcl]
         3302  +  foreach file [glob -nocomplain [file join $path *.tcl]] {
         3303  +    if {[file tail $file] ni $mlist} {
         3304  +      puts [list NONMODFILE $file]
         3305  +      return {}
         3306  +    }
         3307  +  }
         3308  +  foreach file [glob -nocomplain [file join $path *.tcl]] {
         3309  +    if { [file tail $file] == "version_info.tcl" } continue
         3310  +    set fin [open $file r]
         3311  +    set dat [read $fin]
         3312  +    close $fin
         3313  +    if {![regexp "package provide" $dat]} continue
         3314  +    set fname [file rootname [file tail $file]]
         3315  +    # Look for a package provide statement
         3316  +    foreach line [split $dat \n] {
         3317  +      set line [string trim $line]
         3318  +      if { [string range $line 0 14] != "package provide" } continue
         3319  +      set package [lindex $line 2]
         3320  +      set version [lindex $line 3]
         3321  +      if {[string index $package 0] in "\$ \[ @"} continue
         3322  +      if {[string index $version 0] in "\$ \[ @"} continue
         3323  +      puts "PKGLINE $line"
         3324  +      append buffer "package ifneeded $package $version \[list source \[file join %DIR% [file tail $file]\]\]" \n
         3325  +      break
         3326  +    }
         3327  +  }
         3328  +  return $buffer
  1889   3329   }
  1890   3330   proc ::practcl::_pkgindex_directory {path} {
  1891   3331     set buffer {}
  1892         -  set pkgidxfile [file join $path pkgIndex.tcl]
  1893         -  if {![file exists $pkgidxfile]} {
         3332  +  set pkgidxfile    [file join $path pkgIndex.tcl]
         3333  +  set modfile       [file join $path [file tail $path].tcl]
         3334  +  set use_pkgindex  [file exists $pkgidxfile]
         3335  +  set tclfiles      {}
         3336  +  if {$use_pkgindex && [file exists $modfile]} {
         3337  +    set use_pkgindex 0
         3338  +    set mlist [list pkgIndex.tcl [file tail $modfile]]
         3339  +    foreach file [glob -nocomplain [file join $path *.tcl]] {
         3340  +      lappend tclfiles [file tail $file]
         3341  +      if {[file tail $file] in $mlist} continue
         3342  +      incr use_pkgindex
         3343  +    }
         3344  +  }
         3345  +  if {!$use_pkgindex} {
  1894   3346       # No pkgIndex file, read the source
  1895   3347       foreach file [glob -nocomplain $path/*.tm] {
  1896   3348         set file [file normalize $file]
  1897   3349         set fname [file rootname [file tail $file]]
  1898   3350         ###
  1899   3351         # We used to be able to ... Assume the package is correct in the filename
  1900   3352         # No hunt for a "package provides"
................................................................................
  2041   3493           set path_indexed($path) 0
  2042   3494         }
  2043   3495       } else {
  2044   3496         puts [list WARNING: NO PATHS FOUND IN $base]
  2045   3497       }
  2046   3498       set path_indexed($base) 1
  2047   3499       set path_indexed([file join $base boot tcl]) 1
         3500  +    append buffer \n {# SINGLE FILE MODULES BEGIN} \n {set dir [file dirname $::PKGIDXFILE]} \n
         3501  +    foreach path $paths {
         3502  +      if {$path_indexed($path)} continue
         3503  +      set thisdir [file_relative $base $path]
         3504  +      set simpleIdx [_pkgindex_simpleIndex $path]
         3505  +      if {[string length $simpleIdx]==0} continue
         3506  +      incr path_indexed($path)
         3507  +      if {[string length $simpleIdx]} {
         3508  +        incr path_indexed($path)
         3509  +        append buffer [string map [list %DIR% "\$dir \{$thisdir\}"] [string trimright $simpleIdx]] \n
         3510  +      }
         3511  +    }
         3512  +    append buffer {# SINGLE FILE MODULES END} \n
  2048   3513       foreach path $paths {
  2049   3514         if {$path_indexed($path)} continue
  2050   3515         set thisdir [file_relative $base $path]
  2051   3516         set idxbuf [::practcl::_pkgindex_directory $path]
  2052   3517         if {[string length $idxbuf]} {
  2053   3518           incr path_indexed($path)
  2054   3519           append buffer "set dir \[set PKGDIR \[file join \[lindex \$::PATHSTACK end\] $thisdir\]\]" \n
................................................................................
  2113   3578           } else {
  2114   3579             file attributes [file join $d2 $ftail] -readonly 1
  2115   3580           }
  2116   3581         }
  2117   3582       }
  2118   3583     }
  2119   3584   }
         3585  +proc ::practcl::buildModule {modpath} {
         3586  +  set buildscript [file join $modpath build build.tcl]
         3587  +  if {![file exists $buildscript]} return
         3588  +  set pkgIndexFile [file join $modpath pkgIndex.tcl]
         3589  +  if {[file exists $pkgIndexFile]} {
         3590  +    set latest 0
         3591  +    foreach file [::practcl::findByPattern [file dirname $buildscript] *.tcl] {
         3592  +      set mtime [file mtime $file]
         3593  +      if {$mtime>$latest} {
         3594  +        set latest $mtime
         3595  +      }
         3596  +    }
         3597  +    set IdxTime [file mtime $pkgIndexFile]
         3598  +    if {$latest<$IdxTime} return
         3599  +  }
         3600  +  ::practcl::dotclexec $buildscript
         3601  +}
         3602  +proc ::practcl::installModule {modpath DEST} {
         3603  +  puts [list installModule $modpath $DEST]
         3604  +  set dpath  [file join $DEST modules [file tail $modpath]]
         3605  +  if {[file exists [file join $modpath build build.tcl]]} {
         3606  +    buildModule $modpath
         3607  +  } elseif {![file exists [file join $modpath pkgIndex.tcl]]} {
         3608  +    puts [list Reindex $modpath]
         3609  +    pkg_mkIndex $modpath
         3610  +  }
         3611  +  file delete -force $dpath
         3612  +  file mkdir $dpath
         3613  +  foreach file [glob  [file join $modpath *.tcl]] {
         3614  +    file copy $file $dpath
         3615  +  }
         3616  +  if {[file exists [file join $modpath htdocs]]} {
         3617  +    ::practcl::copyDir [file join $modpath htdocs] [file join $dpath htdocs]
         3618  +  }
         3619  +}
  2120   3620   
  2121   3621   ###
  2122   3622   # END: installutil.tcl
  2123   3623   ###
  2124   3624   ###
  2125   3625   # START: makeutil.tcl
  2126   3626   ###
................................................................................
  2144   3644   
  2145   3645   ###
  2146   3646   # END: makeutil.tcl
  2147   3647   ###
  2148   3648   ###
  2149   3649   # START: class metaclass.tcl
  2150   3650   ###
  2151         -::oo::class create ::practcl::metaclass {
  2152         -  superclass ::oo::object
         3651  +::clay::define ::practcl::metaclass {
  2153   3652     method _MorphPatterns {} {
  2154   3653       return {{@[email protected]} {::practcl::@[email protected]} {::practcl::*@[email protected]} {::practcl::*@[email protected]*}}
  2155   3654     }
  2156   3655     method define {submethod args} {
  2157   3656       my variable define
  2158   3657       switch $submethod {
  2159   3658         dump {
................................................................................
  2292   3791         } {
  2293   3792           if {[string match $pattern $class]} {
  2294   3793              set mixinslot $slot
  2295   3794              break
  2296   3795           }
  2297   3796         }
  2298   3797         if {$mixinslot ne {}} {
  2299         -        my mixin $mixinslot $class
         3798  +        my clay mixinmap $mixinslot $class
  2300   3799         } elseif {[info command $class] ne {}} {
  2301   3800           if {[info object class [self]] ne $class} {
  2302   3801             ::oo::objdefine [self] class $class
  2303   3802             ::practcl::debug [self] morph $class
  2304   3803              my define set class $class
  2305   3804           }
  2306   3805         } else {
................................................................................
  2308   3807         }
  2309   3808       }
  2310   3809       if {[::info exists define(oodefine)]} {
  2311   3810         ::oo::objdefine [self] $define(oodefine)
  2312   3811         #unset define(oodefine)
  2313   3812       }
  2314   3813     }
  2315         -  method mixin {slot classname} {
  2316         -    my variable mixinslot
  2317         -    set class {}
  2318         -    set map [list @[email protected] $slot @[email protected] $classname]
  2319         -    foreach pattern [split [string map $map {
  2320         -      @[email protected]
  2321         -      @[email protected]@[email protected]
  2322         -      ::practcl::@[email protected]
  2323         -      ::practcl::@[email protected]@[email protected]
  2324         -      ::practcl::@[email protected]*@[email protected]
  2325         -      ::practcl::*@[email protected]*
  2326         -    }] \n] {
  2327         -      set pattern [string trim $pattern]
  2328         -      set matches [info commands $pattern]
  2329         -      if {![llength $matches]} continue
  2330         -      set class [lindex $matches 0]
  2331         -      break
  2332         -    }
  2333         -    ::practcl::debug [self] mixin $slot $class
  2334         -    dict set mixinslot $slot $class
  2335         -    set mixins {}
  2336         -    foreach {s c} $mixinslot {
  2337         -      if {$c eq {}} continue
  2338         -      lappend mixins $c
  2339         -    }
  2340         -    oo::objdefine [self] mixin {*}$mixins
  2341         -  }
  2342         -  method organ args {
  2343         -    return [my clay delegate {*}$args]
  2344         -  }
  2345   3814     method script script {
  2346   3815       eval $script
  2347   3816     }
  2348   3817     method select {} {
  2349   3818       my variable define
  2350   3819       if {[info exists define(class)]} {
  2351   3820         my morph $define(class)
................................................................................
  2363   3832   
  2364   3833   ###
  2365   3834   # END: class metaclass.tcl
  2366   3835   ###
  2367   3836   ###
  2368   3837   # START: class toolset baseclass.tcl
  2369   3838   ###
  2370         -oo::class create ::practcl::toolset {
         3839  +::clay::define ::practcl::toolset {
  2371   3840     method config.sh {} {
  2372   3841       return [my read_configuration]
  2373   3842     }
  2374   3843     method BuildDir {PWD} {
  2375   3844       set name [my define get name]
  2376   3845       set debug [my define get debug 0]
  2377   3846       if {[my <project> define get LOCAL 0]} {
................................................................................
  2430   3899         }
  2431   3900         set conf_result $result
  2432   3901         return $result
  2433   3902       }
  2434   3903       ###
  2435   3904       # Oh man... we have to guess
  2436   3905       ###
         3906  +    if {![file exists [file join $builddir Makefile]]} {
         3907  +      my Configure
         3908  +    }
  2437   3909       set filename [file join $builddir Makefile]
  2438   3910       if {![file exists $filename]} {
  2439   3911         error "Could not locate any configuration data in $srcdir"
  2440   3912       }
  2441   3913       foreach {field dat} [::practcl::read_Makefile $filename] {
  2442   3914         dict set result $field $dat
  2443   3915       }
................................................................................
  2481   3953       }
  2482   3954       set srcdir [my SourceRoot]
  2483   3955       set PWD [pwd]
  2484   3956       cd $srcdir
  2485   3957       ::practcl::dotclexec $critcl {*}$args
  2486   3958       cd $PWD
  2487   3959     }
  2488         -  method make-autodetect {} {}
  2489   3960   }
  2490   3961   oo::objdefine ::practcl::toolset {
  2491         -
  2492         -
         3962  +  # Perform the selection for the toolset mixin
  2493   3963     method select object {
  2494   3964       ###
  2495   3965       # Select the toolset to use for this project
  2496   3966       ###
  2497   3967       if {[$object define exists toolset]} {
  2498   3968         return [$object define get toolset]
  2499   3969       }
  2500   3970       set class [$object define get toolset]
  2501   3971       if {$class ne {}} {
  2502         -      $object mixin toolset $class
         3972  +      $object clay mixinmap toolset $class
  2503   3973       } else {
  2504   3974         if {[info exists ::env(VisualStudioVersion)]} {
  2505         -        $object mixin toolset ::practcl::toolset.msvc
         3975  +        $object clay mixinmap toolset ::practcl::toolset.msvc
  2506   3976         } else {
  2507         -        $object mixin toolset ::practcl::toolset.gcc
         3977  +        $object clay mixinmap toolset ::practcl::toolset.gcc
  2508   3978         }
  2509   3979       }
  2510   3980     }
  2511   3981   }
  2512   3982   
  2513   3983   ###
  2514   3984   # END: class toolset baseclass.tcl
  2515   3985   ###
  2516   3986   ###
  2517   3987   # START: class toolset gcc.tcl
  2518   3988   ###
  2519         -::oo::class create ::practcl::toolset.gcc {
         3989  +::clay::define ::practcl::toolset.gcc {
  2520   3990     superclass ::practcl::toolset
  2521   3991     method Autoconf {} {
  2522   3992       ###
  2523   3993       # Re-run autoconf for this project
  2524   3994       # Not a good idea in practice... but in the right hands it can be useful
  2525   3995       ###
  2526   3996       set pwd [pwd]
................................................................................
  2565   4035         }
  2566   4036       }
  2567   4037       if {[my <project> define get CONFIG_SITE] != {}} {
  2568   4038         lappend opts --host=[my <project> define get HOST]
  2569   4039       }
  2570   4040       set inside_msys [string is true -strict [my <project> define get MSYS_ENV 0]]
  2571   4041       lappend opts --with-tclsh=[info nameofexecutable]
  2572         -    if {![my <project> define get LOCAL 0]} {
  2573         -      set obj [my <project> tclcore]
  2574         -      if {$obj ne {}} {
  2575         -        if {$inside_msys} {
  2576         -          lappend opts --with-tcl=[::practcl::file_relative [file normalize $builddir] [$obj define get builddir]]
  2577         -        } else {
  2578         -          lappend opts --with-tcl=[file normalize [$obj define get builddir]]
         4042  +
         4043  +    if {[my define get tk 0]} {
         4044  +      if {![my <project> define get LOCAL 0]} {
         4045  +        set obj [my <project> tclcore]
         4046  +        if {$obj ne {}} {
         4047  +          if {$inside_msys} {
         4048  +            lappend opts --with-tcl=[::practcl::file_relative [file normalize $builddir] [$obj define get builddir]]
         4049  +          } else {
         4050  +            lappend opts --with-tcl=[file normalize [$obj define get builddir]]
         4051  +          }
  2579   4052           }
  2580         -      }
  2581         -      if {[my define get tk 0]} {
  2582   4053           set obj [my <project> tkcore]
  2583   4054           if {$obj ne {}} {
  2584   4055             if {$inside_msys} {
  2585   4056               lappend opts --with-tk=[::practcl::file_relative [file normalize $builddir] [$obj define get builddir]]
  2586   4057             } else {
  2587   4058               lappend opts --with-tk=[file normalize [$obj define get builddir]]
  2588   4059             }
  2589   4060           }
  2590         -      }
  2591         -    } else {
  2592         -      lappend opts --with-tcl=[file join $PREFIX lib]
  2593         -      if {[my define get tk 0]} {
         4061  +      } else {
         4062  +        lappend opts --with-tcl=[file join $PREFIX lib]
  2594   4063           lappend opts --with-tk=[file join $PREFIX lib]
  2595   4064         }
         4065  +    } else {
         4066  +      if {![my <project> define get LOCAL 0]} {
         4067  +        set obj [my <project> tclcore]
         4068  +        if {$obj ne {}} {
         4069  +          if {$inside_msys} {
         4070  +            lappend opts --with-tcl=[::practcl::file_relative [file normalize $builddir] [$obj define get builddir]]
         4071  +          } else {
         4072  +            lappend opts --with-tcl=[file normalize [$obj define get builddir]]
         4073  +          }
         4074  +        }
         4075  +      } else {
         4076  +        lappend opts --with-tcl=[file join $PREFIX lib]
         4077  +      }
  2596   4078       }
  2597   4079   
  2598   4080       lappend opts {*}[my define get config_opts]
  2599   4081       if {![regexp -- "--prefix" $opts]} {
  2600   4082         lappend opts --prefix=$PREFIX --exec-prefix=$PREFIX
  2601   4083       }
  2602   4084       if {[my define get debug 0]} {
................................................................................
  2642   4124           } elseif {[file exists [file join $srcdir unix Makefile.in]]} {
  2643   4125             set localsrcdir [file join $srcdir unix]
  2644   4126           }
  2645   4127         }
  2646   4128       }
  2647   4129       return $localsrcdir
  2648   4130     }
  2649         -  method make-autodetect {} {
         4131  +  Ensemble make::autodetect {} {
  2650   4132       set srcdir [my define get srcdir]
  2651   4133       set localsrcdir [my define get localsrcdir]
         4134  +    if {$localsrcdir eq {}} {
         4135  +      set localsrcdir $srcdir
         4136  +    }
  2652   4137       if {$srcdir eq $localsrcdir} {
  2653   4138         if {![file exists [file join $srcdir tclconfig install-sh]]} {
  2654   4139           # ensure we have tclconfig with all of the trimmings
  2655   4140           set teapath {}
  2656   4141           if {[file exists [file join $srcdir .. tclconfig install-sh]]} {
  2657   4142             set teapath [file join $srcdir .. tclconfig]
  2658   4143           } else {
................................................................................
  2685   4170       cd $builddir
  2686   4171       if {[my <project> define get CONFIG_SITE] ne {}} {
  2687   4172         set ::env(CONFIG_SITE) [my <project> define get CONFIG_SITE]
  2688   4173       }
  2689   4174       catch {exec sh [file join $localsrcdir configure] {*}$opts >>& [file join $builddir autoconf.log]}
  2690   4175       cd $::CWD
  2691   4176     }
  2692         -  method make-clean {} {
         4177  +  Ensemble make::clean {} {
  2693   4178       set builddir [file normalize [my define get builddir]]
  2694   4179       catch {::practcl::domake $builddir clean}
  2695   4180     }
  2696         -  method make-compile {} {
         4181  +  Ensemble make::compile {} {
  2697   4182       set name [my define get name]
  2698   4183       set srcdir [my define get srcdir]
  2699   4184       if {[my define get static 1]} {
  2700   4185         puts "BUILDING Static $name $srcdir"
  2701   4186       } else {
  2702   4187         puts "BUILDING Dynamic $name $srcdir"
  2703   4188       }
................................................................................
  2713   4198         } else {
  2714   4199           ::practcl::domake.tcl $builddir all
  2715   4200         }
  2716   4201       } else {
  2717   4202         ::practcl::domake $builddir all
  2718   4203       }
  2719   4204     }
  2720         -  method make-install DEST {
         4205  +  Ensemble make::install DEST {
  2721   4206       set PWD [pwd]
  2722   4207       set builddir [my define get builddir]
  2723   4208       if {[my <project> define get LOCAL 0] || $DEST eq {}} {
  2724   4209         if {[file exists [file join $builddir make.tcl]]} {
  2725   4210           puts "[self] Local INSTALL (Practcl)"
  2726   4211           ::practcl::domake.tcl $builddir install
  2727   4212         } elseif {[my define get broken_destroot 0] == 0} {
................................................................................
  2942   4427   method build-library {outfile PROJECT} {
  2943   4428     array set proj [$PROJECT define dump]
  2944   4429     set path $proj(builddir)
  2945   4430     cd $path
  2946   4431     set includedir .
  2947   4432     #lappend includedir [::practcl::file_relative $path $proj(TCL_INCLUDES)]
  2948   4433     lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TCL_SRC_DIR) generic]]]
         4434  +  if {[$PROJECT define get TEA_PRIVATE_TCL_HEADERS 0]} {
         4435  +    if {[$PROJECT define get TEA_PLATFORM] eq "windows"} {
         4436  +      lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TCL_SRC_DIR) win]]]
         4437  +    } else {
         4438  +      lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TCL_SRC_DIR) unix]]]
         4439  +    }
         4440  +  }
         4441  +
  2949   4442     lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(srcdir) generic]]]
         4443  +
  2950   4444     if {[$PROJECT define get tk 0]} {
  2951   4445       lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) generic]]]
  2952   4446       lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) ttk]]]
  2953   4447       lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) xlib]]]
         4448  +    if {[$PROJECT define get TEA_PRIVATE_TK_HEADERS 0]} {
         4449  +      if {[$PROJECT define get TEA_PLATFORM] eq "windows"} {
         4450  +        lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) win]]]
         4451  +      } else {
         4452  +        lappend includedir [::practcl::file_relative $path [file normalize [file join $proj(TK_SRC_DIR) unix]]]
         4453  +      }
         4454  +    }
  2954   4455       lappend includedir [::practcl::file_relative $path [file normalize $proj(TK_BIN_DIR)]]
  2955   4456     }
  2956   4457     foreach include [$PROJECT toolset-include-directory] {
  2957   4458       set cpath [::practcl::file_relative $path [file normalize $include]]
  2958   4459       if {$cpath ni $includedir} {
  2959   4460         lappend includedir $cpath
  2960   4461       }
................................................................................
  3013   4514     }
  3014   4515     set ranlib [$PROJECT define get RANLIB]
  3015   4516     if {$ranlib ni {{} :}} {
  3016   4517       catch {exec $ranlib $outfile}
  3017   4518     }
  3018   4519   }
  3019   4520   method build-tclsh {outfile PROJECT} {
  3020         -  puts " BUILDING STATIC TCLSH "
         4521  +  if {[my define get tk 0] && [my define get static_tk 0]} {
         4522  +    puts " BUILDING STATIC TCL/TK EXE $PROJECT"
         4523  +    set TKOBJ  [$PROJECT tkcore]
         4524  +    if {[info command $TKOBJ] eq {}} {
         4525  +      set TKOBJ ::noop
         4526  +      $PROJECT define set static_tk 0
         4527  +    } else {
         4528  +      ::practcl::toolset select $TKOBJ
         4529  +      array set TK  [$TKOBJ read_configuration]
         4530  +      set do_tk [$TKOBJ define get static]
         4531  +      $PROJECT define set static_tk $do_tk
         4532  +      $PROJECT define set tk $do_tk
         4533  +      set TKSRCDIR [$TKOBJ define get srcdir]
         4534  +    }
         4535  +  } else {
         4536  +    puts " BUILDING STATIC TCL EXE $PROJECT"
         4537  +    set TKOBJ ::noop
         4538  +    my define set static_tk 0
         4539  +  }
  3021   4540     set TCLOBJ [$PROJECT tclcore]
  3022   4541     ::practcl::toolset select $TCLOBJ
  3023   4542     set PKG_OBJS {}
  3024   4543     foreach item [$PROJECT link list core.library] {
  3025   4544       if {[string is true [$item define get static]]} {
  3026   4545         lappend PKG_OBJS $item
  3027   4546       }
................................................................................
  3028   4547     }
  3029   4548     foreach item [$PROJECT link list package] {
  3030   4549       if {[string is true [$item define get static]]} {
  3031   4550         lappend PKG_OBJS $item
  3032   4551       }
  3033   4552     }
  3034   4553     array set TCL [$TCLOBJ read_configuration]
  3035         -
  3036         -  set TKOBJ  [$PROJECT tkcore]
  3037         -  if {[info command $TKOBJ] eq {}} {
  3038         -    set TKOBJ ::noop
  3039         -    $PROJECT define set static_tk 0
  3040         -  } else {
  3041         -    ::practcl::toolset select $TKOBJ
  3042         -    array set TK  [$TKOBJ read_configuration]
  3043         -    set do_tk [$TKOBJ define get static]
  3044         -    $PROJECT define set static_tk $do_tk
  3045         -    $PROJECT define set tk $do_tk
  3046         -    set TKSRCDIR [$TKOBJ define get srcdir]
  3047         -  }
  3048   4554     set path [file dirname $outfile]
  3049   4555     cd $path
  3050   4556     ###
  3051   4557     # For a static Tcl shell, we need to build all local sources
  3052   4558     # with the same DEFS flags as the tcl core was compiled with.
  3053   4559     # The DEFS produced by a TEA extension aren't intended to operate
  3054   4560     # with the internals of a staticly linked Tcl
................................................................................
  3235   4741   
  3236   4742   ###
  3237   4743   # END: class toolset gcc.tcl
  3238   4744   ###
  3239   4745   ###
  3240   4746   # START: class toolset msvc.tcl
  3241   4747   ###
  3242         -::oo::class create ::practcl::toolset.msvc {
         4748  +::clay::define ::practcl::toolset.msvc {
  3243   4749     superclass ::practcl::toolset
  3244   4750     method BuildDir {PWD} {
  3245   4751       set srcdir [my define get srcdir]
  3246   4752       return $srcdir
  3247   4753     }
  3248         -  method make-autodetect {} {
         4754  +  Ensemble make::autodetect {} {
  3249   4755     }
  3250         -  method make-clean {} {
         4756  +  Ensemble make::clean {} {
  3251   4757       set PWD [pwd]
  3252   4758       set srcdir [my define get srcdir]
  3253   4759       cd $srcdir
  3254   4760       catch {::practcl::doexec nmake -f makefile.vc clean}
  3255   4761       cd $PWD
  3256   4762     }
  3257         -  method make-compile {} {
         4763  +  Ensemble make::compile {} {
  3258   4764       set srcdir [my define get srcdir]
  3259   4765       if {[my define get static 1]} {
  3260   4766         puts "BUILDING Static $name $srcdir"
  3261   4767       } else {
  3262   4768         puts "BUILDING Dynamic $name $srcdir"
  3263   4769       }
  3264   4770       cd $srcdir
................................................................................
  3275   4781           cd [file join $srcdir win]
  3276   4782           ::practcl::doexec nmake -f makefile.vc INSTALLDIR=[my <project> define get installdir]  {*}[my NmakeOpts] release
  3277   4783         } else {
  3278   4784           error "No make.tcl or makefile.vc found for project $name"
  3279   4785         }
  3280   4786       }
  3281   4787     }
  3282         -  method make-install DEST {
         4788  +  Ensemble make::install DEST {
  3283   4789       set PWD [pwd]
  3284   4790       set srcdir [my define get srcdir]
  3285   4791       cd $srcdir
  3286   4792       if {$DEST eq {}} {
  3287   4793         error "No destination given"
  3288   4794       }
  3289   4795       if {[my <project> define get LOCAL 0] || $DEST eq {}} {
................................................................................
  3346   4852   
  3347   4853   ###
  3348   4854   # END: class toolset msvc.tcl
  3349   4855   ###
  3350   4856   ###
  3351   4857   # START: class target.tcl
  3352   4858   ###
  3353         -::oo::class create ::practcl::make_obj {
         4859  +::clay::define ::practcl::make_obj {
  3354   4860     superclass ::practcl::metaclass
  3355   4861     constructor {module_object name info {action_body {}}} {
  3356   4862       my variable define triggered domake
  3357   4863       set triggered 0
  3358   4864       set domake 0
  3359   4865       set define(name) $name
  3360   4866       set define(action) {}
................................................................................
  3449   4955   
  3450   4956   ###
  3451   4957   # END: class target.tcl
  3452   4958   ###
  3453   4959   ###
  3454   4960   # START: class object.tcl
  3455   4961   ###
  3456         -::oo::class create ::practcl::object {
         4962  +::clay::define ::practcl::object {
  3457   4963     superclass ::practcl::metaclass
  3458   4964     constructor {parent args} {
  3459   4965       my variable links define
  3460   4966       set organs [$parent child organs]
  3461   4967       my clay delegate {*}$organs
  3462   4968       array set define $organs
  3463   4969       array set define [$parent child define]
................................................................................
  3493   4999   
  3494   5000   ###
  3495   5001   # END: class object.tcl
  3496   5002   ###
  3497   5003   ###
  3498   5004   # START: class dynamic.tcl
  3499   5005   ###
  3500         -::oo::class create ::practcl::dynamic {
         5006  +::clay::define ::practcl::dynamic {
  3501   5007     method cstructure {name definition {argdat {}}} {
  3502   5008       my variable cstruct
  3503   5009       dict set cstruct $name body $definition
  3504   5010       foreach {f v} $argdat {
  3505   5011         dict set cstruct $name $f $v
  3506   5012       }
  3507   5013       if {![dict exists $cstruct $name public]} {
................................................................................
  4037   5543   
  4038   5544   ###
  4039   5545   # END: class dynamic.tcl
  4040   5546   ###
  4041   5547   ###
  4042   5548   # START: class product.tcl
  4043   5549   ###
  4044         -::oo::class create ::practcl::product {
         5550  +::clay::define ::practcl::product {
  4045   5551     method code {section body} {
  4046   5552       my variable code
  4047   5553       ::practcl::cputs code($section) $body
  4048   5554     }
  4049   5555     method Collate_Source CWD {}
  4050   5556     method project-compile-products {} {
  4051   5557       set result {}
................................................................................
  4528   6034     method target {method args} {
  4529   6035       switch $method {
  4530   6036         is_unix { return [expr {$::tcl_platform(platform) eq "unix"}] }
  4531   6037       }
  4532   6038     }
  4533   6039   }
  4534   6040   oo::objdefine ::practcl::product {
         6041  +
  4535   6042     method select {object} {
  4536   6043       set class [$object define get class]
  4537   6044       set mixin [$object define get product]
  4538   6045       if {$class eq {} && $mixin eq {}} {
  4539   6046         set filename [$object define get filename]
  4540   6047         if {$filename ne {} && [file exists $filename]} {
  4541   6048           switch [file extension $filename] {
................................................................................
  4564   6071             .a {
  4565   6072               set mixin ::practcl::product.clibrary
  4566   6073             }
  4567   6074           }
  4568   6075         }
  4569   6076       }
  4570   6077       if {$class ne {}} {
  4571         -      $object morph $class
         6078  +      $object clay mixinmap core $class
  4572   6079       }
  4573   6080       if {$mixin ne {}} {
  4574         -      $object mixin product $mixin
         6081  +      $object clay mixinmap product $mixin
  4575   6082       }
  4576   6083     }
  4577   6084   }
  4578         -::oo::class create ::practcl::product.cheader {
         6085  +::clay::define ::practcl::product.cheader {
  4579   6086     superclass ::practcl::product
  4580   6087     method project-compile-products {} {}
  4581   6088     method generate-loader-module {} {}
  4582   6089   }
  4583         -::oo::class create ::practcl::product.csource {
         6090  +::clay::define ::practcl::product.csource {
  4584   6091     superclass ::practcl::product
  4585   6092     method project-compile-products {} {
  4586   6093       set result {}
  4587   6094       set filename [my define get filename]
  4588   6095       if {$filename ne {}} {
  4589   6096         ::practcl::debug [self] [self class] [self method] project-compile-products $filename
  4590   6097         if {[my define exists ofile]} {
................................................................................
  4597   6104       }
  4598   6105       foreach item [my link list subordinate] {
  4599   6106         lappend result {*}[$item project-compile-products]
  4600   6107       }
  4601   6108       return $result
  4602   6109     }
  4603   6110   }
  4604         -::oo::class create ::practcl::product.clibrary {
         6111  +::clay::define ::practcl::product.clibrary {
  4605   6112     superclass ::practcl::product
  4606   6113     method linker-products {configdict} {
  4607   6114       return [my define get filename]
  4608   6115     }
  4609   6116   }
  4610         -::oo::class create ::practcl::product.dynamic {
         6117  +::clay::define ::practcl::product.dynamic {
  4611   6118     superclass ::practcl::dynamic ::practcl::product
  4612   6119     method initialize {} {
  4613   6120       set filename [my define get filename]
  4614   6121       if {$filename eq {}} {
  4615   6122         return
  4616   6123       }
  4617   6124       if {[my define get name] eq {}} {
................................................................................
  4629   6136       ::source $filename
  4630   6137       if {[my define get output_c] ne {}} {
  4631   6138         # Turn into a module if we have an output_c file
  4632   6139         my morph ::practcl::module
  4633   6140       }
  4634   6141     }
  4635   6142   }
  4636         -::oo::class create ::practcl::product.critcl {
         6143  +::clay::define ::practcl::product.critcl {
  4637   6144     superclass ::practcl::dynamic ::practcl::product
  4638   6145   }
  4639   6146   
  4640   6147   ###
  4641   6148   # END: class product.tcl
  4642   6149   ###
  4643   6150   ###
  4644   6151   # START: class module.tcl
  4645   6152   ###
  4646         -::oo::class create ::practcl::module {
         6153  +::clay::define ::practcl::module {
  4647   6154     superclass ::practcl::object ::practcl::product.dynamic
  4648   6155     method _MorphPatterns {} {
  4649   6156       return {{@[email protected]} {::practcl::[email protected]@} ::practcl::module}
  4650   6157     }
  4651   6158     method add args {
  4652   6159       my variable links
  4653   6160       set object [::practcl::object new [self] {*}$args]
  4654   6161       foreach linktype [$object linktype] {
  4655   6162         lappend links($linktype) $object
  4656   6163       }
  4657   6164       return $object
  4658   6165     }
         6166  +  Dict make_object {}
  4659   6167     method install-headers args {}
  4660         -  method make {command args} {
         6168  +  Ensemble make::_preamble {} {
  4661   6169       my variable make_object
  4662         -    if {![info exists make_object]} {
  4663         -      set make_object {}
  4664         -    }
  4665         -    switch $command {
  4666         -      pkginfo {
  4667         -        ###
  4668         -        # Build local variables needed for install
  4669         -        ###
  4670         -        package require platform
  4671         -        set result {}
  4672         -        set dat [my define dump]
  4673         -        set PKG_DIR [dict get $dat name][dict get $dat version]
  4674         -        dict set result PKG_DIR $PKG_DIR
  4675         -        dict with dat {}
  4676         -        if {![info exists DESTDIR]} {
  4677         -          set DESTDIR {}
  4678         -        }
  4679         -        dict set result profile [::platform::identify]
  4680         -        dict set result os $::tcl_platform(os)
  4681         -        dict set result platform $::tcl_platform(platform)
  4682         -        foreach {field value} $dat {
  4683         -          switch $field {
  4684         -            includedir -
  4685         -            mandir -
  4686         -            datadir -
  4687         -            libdir -
  4688         -            libfile -
  4689         -            name -
  4690         -            output_tcl -
  4691         -            version -
  4692         -            authors -
  4693         -            license -
  4694         -            requires {
  4695         -              dict set result $field $value
  4696         -            }
  4697         -            TEA_PLATFORM {
  4698         -              dict set result platform $value
  4699         -            }
  4700         -            TEACUP_OS {
  4701         -              dict set result os $value
  4702         -            }
  4703         -            TEACUP_PROFILE {
  4704         -              dict set result profile $value
  4705         -            }
  4706         -            TEACUP_ZIPFILE {
  4707         -              dict set result zipfile $value
  4708         -            }
  4709         -          }
  4710         -        }
  4711         -        if {![dict exists $result zipfile]} {
  4712         -          dict set result zipfile "[dict get $result name]-[dict get $result version]-[dict get $result profile].zip"
  4713         -        }
  4714         -        return $result
  4715         -      }
  4716         -      objects {
  4717         -        return $make_object
  4718         -      }
  4719         -      object {
  4720         -        set name [lindex $args 0]
  4721         -        if {[dict exists $make_object $name]} {
  4722         -          return [dict get $make_object $name]
  4723         -        }
  4724         -        return {}
  4725         -      }
  4726         -      reset {
  4727         -        foreach {name obj} $make_object {
  4728         -          $obj reset
  4729         -        }
  4730         -      }
  4731         -      trigger {
  4732         -        foreach {name obj} $make_object {
  4733         -          if {$name in $args} {
  4734         -            $obj triggers
  4735         -          }
  4736         -        }
  4737         -      }
  4738         -      depends {
  4739         -        foreach {name obj} $make_object {
  4740         -          if {$name in $args} {
  4741         -            $obj check
  4742         -          }
  4743         -        }
  4744         -      }
  4745         -      filename {
  4746         -        set name [lindex $args 0]
  4747         -        if {[dict exists $make_object $name]} {
  4748         -          return [[dict get $make_object $name] define get filename]
  4749         -        }
  4750         -      }
  4751         -      task -
  4752         -      target -
  4753         -      add {
  4754         -        set name [lindex $args 0]
  4755         -        set info [uplevel #0 [list subst [lindex $args 1]]]
  4756         -        set body [lindex $args 2]
  4757         -
  4758         -        set nspace [namespace current]
  4759         -        if {[dict exist $make_object $name]} {
  4760         -          set obj [dict get $$make_object $name]
  4761         -        } else {
  4762         -          set obj [::practcl::make_obj new [self] $name $info $body]
  4763         -          dict set make_object $name $obj
  4764         -          dict set target_make $name 0
  4765         -          dict set target_trigger $name 0
  4766         -        }
  4767         -        if {[dict exists $info aliases]} {
  4768         -          foreach item [dict get $info aliases] {
  4769         -            if {![dict exists $make_object $item]} {
  4770         -              dict set make_object $item $obj
  4771         -            }
  4772         -          }
  4773         -        }
  4774         -        return $obj
  4775         -      }
  4776         -      todo {
  4777         -         foreach {name obj} $make_object {
  4778         -          if {[$obj do]} {
  4779         -            lappend result $name
  4780         -          }
  4781         -        }
  4782         -      }
  4783         -      do {
  4784         -        global CWD SRCDIR project SANDBOX
  4785         -        foreach {name obj} $make_object {
  4786         -          if {[$obj do]} {
  4787         -            eval [$obj define get action]
  4788         -          }
  4789         -        }
         6170  +  }
         6171  +  Ensemble make::pkginfo {} {
         6172  +    ###
         6173  +    # Build local variables needed for install
         6174  +    ###
         6175  +    package require platform
         6176  +    set result {}
         6177  +    set dat [my define dump]
         6178  +    set PKG_DIR [dict get $dat name][dict get $dat version]
         6179  +    dict set result PKG_DIR $PKG_DIR
         6180  +    dict with dat {}
         6181  +    if {![info exists DESTDIR]} {
         6182  +      set DESTDIR {}
         6183  +    }
         6184  +    dict set result profile [::platform::identify]
         6185  +    dict set result os $::tcl_platform(os)
         6186  +    dict set result platform $::tcl_platform(platform)
         6187  +    foreach {field value} $dat {
         6188  +      switch $field {
         6189  +        includedir -
         6190  +        mandir -
         6191  +        datadir -
         6192  +        libdir -
         6193  +        libfile -
         6194  +        name -
         6195  +        output_tcl -
         6196  +        version -
         6197  +        authors -
         6198  +        license -
         6199  +        requires {
         6200  +          dict set result $field $value
         6201  +        }
         6202  +        TEA_PLATFORM {
         6203  +          dict set result platform $value
         6204  +        }
         6205  +        TEACUP_OS {
         6206  +          dict set result os $value
         6207  +        }
         6208  +        TEACUP_PROFILE {
         6209  +          dict set result profile $value
         6210  +        }
         6211  +        TEACUP_ZIPFILE {
         6212  +          dict set result zipfile $value
         6213  +        }
         6214  +      }
         6215  +    }
         6216  +    if {![dict exists $result zipfile]} {
         6217  +      dict set result zipfile "[dict get $result name]-[dict get $result version]-[dict get $result profile].zip"
         6218  +    }
         6219  +    return $result
         6220  +  }
         6221  +  Ensemble make::objects {} {
         6222  +    return $make_object
         6223  +  }
         6224  +  Ensemble make::object name {
         6225  +    if {[dict exists $make_object $name]} {
         6226  +      return [dict get $make_object $name]
         6227  +    }
         6228  +    return {}
         6229  +  }
         6230  +  Ensemble make::reset {} {
         6231  +    foreach {name obj} $make_object {
         6232  +      $obj reset
         6233  +    }
         6234  +  }
         6235  +  Ensemble make::trigger args {
         6236  +    foreach {name obj} $make_object {
         6237  +      if {$name in $args} {
         6238  +        $obj triggers
         6239  +      }
         6240  +    }
         6241  +  }
         6242  +  Ensemble make::depends args {
         6243  +    foreach {name obj} $make_object {
         6244  +      if {$name in $args} {
         6245  +        $obj check
         6246  +      }
         6247  +    }
         6248  +  }
         6249  +  Ensemble make::filename name {
         6250  +    if {[dict exists $make_object $name]} {
         6251  +      return [[dict get $make_object $name] define get filename]
         6252  +    }
         6253  +  }
         6254  +  Ensemble make::target {name Info body} {
         6255  +    set info [uplevel #0 [list subst $Info]]
         6256  +    set nspace [namespace current]
         6257  +    if {[dict exist $make_object $name]} {
         6258  +      set obj [dict get $$make_object $name]
         6259  +    } else {
         6260  +      set obj [::practcl::make_obj new [self] $name $info $body]
         6261  +      dict set make_object $name $obj
         6262  +      dict set target_make $name 0
         6263  +      dict set target_trigger $name 0
         6264  +    }
         6265  +    if {[dict exists $info aliases]} {
         6266  +      foreach item [dict get $info aliases] {
         6267  +        if {![dict exists $make_object $item]} {
         6268  +          dict set make_object $item $obj
         6269  +        }
         6270  +      }
         6271  +    }
         6272  +    return $obj
         6273  +  }
         6274  +  clay set method_ensemble make target aliases {task add}
         6275  +  Ensemble make::todo {} {
         6276  +    foreach {name obj} $make_object {
         6277  +      if {[$obj do]} {
         6278  +        lappend result $name
         6279  +      }
         6280  +    }
         6281  +    return $result
         6282  +  }
         6283  +  Ensemble make::todo {} {
         6284  +    global CWD SRCDIR project SANDBOX
         6285  +    foreach {name obj} $make_object {
         6286  +      if {[$obj do]} {
         6287  +        eval [$obj define get action]
  4790   6288         }
  4791   6289       }
  4792   6290     }
  4793   6291     method child which {
  4794   6292       switch $which {
  4795   6293         delegate -
  4796   6294         organs {
................................................................................
  4845   6343       }
  4846   6344       ::practcl::debug [list /[self] [self method] [self class] -- [my define get filename] [info object class [self]]]
  4847   6345       return $result
  4848   6346     }
  4849   6347     method generate-h {} {
  4850   6348       ::practcl::debug [list [self] [self method] [self class] -- [my define get filename] [info object class [self]]]
  4851   6349       set result {}
         6350  +    foreach method {
         6351  +      generate-hfile-public-define
         6352  +      generate-hfile-public-macro
         6353  +    } {
         6354  +      ::practcl::cputs result "/* BEGIN SECTION $method */"
         6355  +      ::practcl::cputs result [my $method]
         6356  +      ::practcl::cputs result "/* END SECTION $method */"
         6357  +    }
  4852   6358       set includes [my generate-hfile-public-includes]
  4853   6359       foreach inc $includes {
  4854   6360         if {[string index $inc 0] ni {< \"}} {
  4855   6361           ::practcl::cputs result "#include \"$inc\""
  4856   6362         } else {
  4857   6363           ::practcl::cputs result "#include $inc"
  4858   6364         }
  4859   6365       }
  4860         -
  4861   6366       foreach method {
  4862         -      generate-hfile-public-define
  4863         -      generate-hfile-public-macro
  4864   6367         generate-hfile-public-typedef
  4865   6368         generate-hfile-public-structure
  4866   6369       } {
  4867   6370         ::practcl::cputs result "/* BEGIN SECTION $method */"
  4868   6371         ::practcl::cputs result [my $method]
  4869   6372         ::practcl::cputs result "/* END SECTION $method */"
  4870   6373       }
................................................................................
  4991   6494   
  4992   6495   ###
  4993   6496   # END: class module.tcl
  4994   6497   ###
  4995   6498   ###
  4996   6499   # START: class project baseclass.tcl
  4997   6500   ###
  4998         -::oo::class create ::practcl::project {
         6501  +::clay::define ::practcl::project {
  4999   6502     superclass ::practcl::module
  5000   6503     method _MorphPatterns {} {
  5001   6504       return {{@[email protected]} {::practcl::@[email protected]} {::practcl::[email protected]@} {::practcl::project}}
  5002   6505     }
  5003   6506     constructor args {
  5004   6507       my variable define
  5005   6508       if {[llength $args] == 1} {
................................................................................
  5097   6600       }
  5098   6601       $tclobj define set config_opts $tcl_config_opts
  5099   6602       $tclobj go
  5100   6603       $tclobj compile
  5101   6604   
  5102   6605       set _TclSrcDir [$tclobj define get localsrcdir]
  5103   6606       my define set tclsrcdir $_TclSrcDir
  5104         -
  5105         -    set tkobj [my tkcore]
  5106         -    lappend tk_config_opts --with-tcl=[::practcl::file_relative [$tkobj define get builddir]  [$tclobj define get builddir]]
  5107         -    if {[my define get debug 0]} {
  5108         -      $tkobj define set debug 1
  5109         -      lappend tk_config_opts --enable-symbols=true
         6607  +    if {[my define get tk 0]} {
         6608  +      set tkobj [my tkcore]
         6609  +      lappend tk_config_opts --with-tcl=[::practcl::file_relative [$tkobj define get builddir]  [$tclobj define get builddir]]
         6610  +      if {[my define get debug 0]} {
         6611  +        $tkobj define set debug 1
         6612  +        lappend tk_config_opts --enable-symbols=true
         6613  +      }
         6614  +      $tkobj define set config_opts $tk_config_opts
         6615  +      $tkobj compile
  5110   6616       }
  5111         -    $tkobj define set config_opts $tk_config_opts
  5112         -    $tkobj compile
  5113   6617     }
  5114   6618     method child which {
  5115   6619       switch $which {
  5116   6620         delegate -
  5117   6621         organs {
  5118   6622   	# A library can be a project, it can be a module. Any
  5119   6623   	# subordinate modules will indicate their existance
................................................................................
  5128   6632       set obj [namespace current]::PROJECT.$pkg
  5129   6633       if {[llength $args]==0} {
  5130   6634         return $obj
  5131   6635       }
  5132   6636       ${obj} {*}$args
  5133   6637     }
  5134   6638     method tclcore {} {
  5135         -    if {[info commands [set obj [my organ tclcore]]] ne {}} {
         6639  +    if {[info commands [set obj [my clay delegate tclcore]]] ne {}} {
  5136   6640         return $obj
  5137   6641       }
  5138   6642       if {[info commands [set obj [my project TCLCORE]]] ne {}} {
  5139   6643         my graft tclcore $obj
  5140   6644         return $obj
  5141   6645       }
  5142   6646       if {[info commands [set obj [my project tcl]]] ne {}} {
................................................................................
  5152   6656         tag release class subproject.core
  5153   6657         fossil_url http://core.tcl.tk/tcl
  5154   6658       }]
  5155   6659       my graft tclcore $obj
  5156   6660       return $obj
  5157   6661     }
  5158   6662     method tkcore {} {
  5159         -    if {[set obj [my organ tkcore]] ne {}} {
         6663  +    if {[set obj [my clay delegate tkcore]] ne {}} {
  5160   6664         return $obj
  5161   6665       }
  5162   6666       if {[set obj [my project tk]] ne {}} {
  5163   6667         my graft tkcore $obj
  5164   6668         return $obj
  5165   6669       }
  5166   6670       if {[set obj [my tool tk]] ne {}} {
................................................................................
  5186   6690   
  5187   6691   ###
  5188   6692   # END: class project baseclass.tcl
  5189   6693   ###
  5190   6694   ###
  5191   6695   # START: class project library.tcl
  5192   6696   ###
  5193         -::oo::class create ::practcl::library {
         6697  +::clay::define ::practcl::library {
  5194   6698     superclass ::practcl::project
  5195   6699     method clean {PATH} {
  5196   6700       set objext [my define get OBJEXT o]
  5197   6701       foreach {ofile info} [my project-compile-products] {
  5198   6702         if {[file exists [file join $PATH objs $ofile].${objext}]} {
  5199   6703           file delete [file join $PATH objs $ofile].${objext}
  5200   6704         }
................................................................................
  5447   6951       set version [my define get pkg_vers [my define get version]]
  5448   6952       if {$version eq {}} {
  5449   6953         set version 0.1a
  5450   6954       }
  5451   6955       set output_tcl [my define get output_tcl]
  5452   6956       if {$output_tcl ne {}} {
  5453   6957         set script "\[list source \[file join \$dir $output_tcl\]\]"
  5454         -    } elseif {[string is true -strict [my define get SHARED_BUILD]]} {
         6958  +    } elseif {[my define get SHARED_BUILD 0]} {
  5455   6959         set script "\[list load \[file join \$dir [my define get libfile]\] $name\]"
  5456   6960       } else {
  5457   6961         # Provide a null passthrough
  5458   6962         set script "\[list package provide $name $version\]"
  5459   6963       }
  5460   6964       set result "package ifneeded [list $name] [list $version] $script"
  5461   6965       foreach alias $args {
................................................................................
  5492   6996   
  5493   6997   ###
  5494   6998   # END: class project library.tcl
  5495   6999   ###
  5496   7000   ###
  5497   7001   # START: class project tclkit.tcl
  5498   7002   ###
  5499         -::oo::class create ::practcl::tclkit {
         7003  +::clay::define ::practcl::tclkit {
  5500   7004     superclass ::practcl::library
  5501   7005     method build-tclkit_main {PROJECT PKG_OBJS} {
  5502   7006       ###
  5503   7007       # Build static package list
  5504   7008       ###
  5505   7009       set statpkglist {}
  5506   7010       foreach cobj [list {*}${PKG_OBJS} $PROJECT] {
................................................................................
  5686   7190           ::practcl::cputs appinit "  Tcl_StaticPackage(interp,\"$statpkg\",$initfunc,NULL)\;"
  5687   7191         } else {
  5688   7192           ::practcl::cputs appinit "\n  Tcl_StaticPackage(NULL,\"$statpkg\",$initfunc,NULL)\;"
  5689   7193           append main_init_script \n $script
  5690   7194         }
  5691   7195       }
  5692   7196       append main_init_script \n {
  5693         -if {[file exists [file join $::SRCDIR packages.tcl]]} {
         7197  +puts [list SRCDIR IS $::SRCDIR]
         7198  +if {[file exists [file join $::SRCDIR pkgIndex.tcl]]} {
  5694   7199     #In a wrapped exe, we don't go out to the environment
  5695   7200     set dir $::SRCDIR
  5696         -  source [file join $::SRCDIR packages.tcl]
         7201  +  source [file join $::SRCDIR pkgIndex.tcl]
  5697   7202   }
  5698   7203   # Specify a user-specific startup file to invoke if the application
  5699   7204   # is run interactively.  Typically the startup file is "~/.apprc"
  5700   7205   # where "app" is the name of the application.  If this line is deleted
  5701   7206   # then no user-specific startup file will be run under any conditions.
  5702   7207   }
  5703   7208       append main_init_script \n [list set tcl_rcFileName [$PROJECT define get tcl_rcFileName ~/.tclshrc]]
................................................................................
  5716   7221         my define set TCL_LOCAL_APPINIT Tclkit_AppInit
  5717   7222       }
  5718   7223       if {![my define exists TCL_LOCAL_MAIN_HOOK]} {
  5719   7224         my define set TCL_LOCAL_MAIN_HOOK Tclkit_MainHook
  5720   7225       }
  5721   7226       set PROJECT [self]
  5722   7227       set os [$PROJECT define get TEACUP_OS]
  5723         -    if {[my define get SHARED_BUILD]} {
         7228  +    if {[my define get SHARED_BUILD 0]} {
  5724   7229         puts [list BUILDING TCLSH FOR OS $os]
  5725   7230       } else {
  5726   7231         puts [list BUILDING KIT FOR OS $os]
  5727   7232       }
  5728   7233       set TCLOBJ [$PROJECT tclcore]
  5729   7234       ::practcl::toolset select $TCLOBJ
  5730   7235   
................................................................................
  5739   7244         if {[string is true [$item define get static]]} {
  5740   7245           lappend PKG_OBJS $item
  5741   7246         }
  5742   7247       }
  5743   7248       # Arrange to build an main.c that utilizes TCL_LOCAL_APPINIT and TCL_LOCAL_MAIN_HOOK
  5744   7249       if {$os eq "windows"} {
  5745   7250         set PLATFORM_SRC_DIR win
  5746         -      if {[my define get SHARED_BUILD]} {
         7251  +      if {[my define get SHARED_BUILD 0]} {
  5747   7252           my add class csource filename [file join $TCLSRCDIR win tclWinReg.c] initfunc Registry_Init pkg_name registry pkg_vers 1.3.1 autoload 1
  5748   7253           my add class csource filename [file join $TCLSRCDIR win tclWinDde.c] initfunc Dde_Init pkg_name dde pkg_vers 1.4.0 autoload 1
  5749   7254         }
  5750   7255         my add class csource ofile [my define get name]_appinit.o filename [file join $TCLSRCDIR win tclAppInit.c] extra [list -DTCL_LOCAL_MAIN_HOOK=[my define get TCL_LOCAL_MAIN_HOOK Tclkit_MainHook] -DTCL_LOCAL_APPINIT=[my define get TCL_LOCAL_APPINIT Tclkit_AppInit]]
  5751   7256       } else {
  5752   7257         set PLATFORM_SRC_DIR unix
  5753   7258         my add class csource ofile [my define get name]_appinit.o filename [file join $TCLSRCDIR unix tclAppInit.c] extra [list -DTCL_LOCAL_MAIN_HOOK=[my define get TCL_LOCAL_MAIN_HOOK Tclkit_MainHook] -DTCL_LOCAL_APPINIT=[my define get TCL_LOCAL_APPINIT Tclkit_AppInit]]
  5754   7259       }
  5755   7260   
  5756         -    if {[my define get SHARED_BUILD]} {
         7261  +    if {[my define get SHARED_BUILD 0]} {
  5757   7262         ###
  5758   7263         # Add local static Zlib implementation
  5759   7264         ###
  5760   7265         set cdir [file join $TCLSRCDIR compat zlib]
  5761   7266         foreach file {
  5762   7267           adler32.c compress.c crc32.c
  5763   7268           deflate.c infback.c inffast.c
................................................................................
  5809   7314       #if {[my define get installdir] ne {}} {
  5810   7315       #  ::practcl::copyDir [file join [my define get installdir] [string trimleft [my define get prefix] /] lib] [file join $vfspath lib]
  5811   7316       #}
  5812   7317       foreach arg $args {
  5813   7318          ::practcl::copyDir $arg $vfspath
  5814   7319       }
  5815   7320   
  5816         -    set fout [open [file join $vfspath packages.tcl] w]
         7321  +    set fout [open [file join $vfspath pkgIndex.tcl] w]
  5817   7322       puts $fout [string map [list %platform% [my define get TEACUP_PROFILE]] {set ::tcl_teapot_profile {%platform%}}]
  5818   7323       puts $fout {
  5819   7324   set ::PKGIDXFILE [info script]
  5820   7325   set dir [file dirname $::PKGIDXFILE]
  5821   7326   if {$::tcl_platform(platform) eq "windows"} {
  5822   7327     set ::g(HOME) [file join [file normalize $::env(LOCALAPPDATA)] tcl]
  5823   7328   } else {
................................................................................
  5860   7365   
  5861   7366   ###
  5862   7367   # END: class project tclkit.tcl
  5863   7368   ###
  5864   7369   ###
  5865   7370   # START: class distro baseclass.tcl
  5866   7371   ###
  5867         -oo::class create ::practcl::distribution {
         7372  +::clay::define ::practcl::distribution {
  5868   7373     method scm_info {} {
  5869   7374       return {
  5870   7375         scm  None
  5871   7376         hash {}
  5872   7377         maxdate {}
  5873   7378         tags {}
  5874   7379         isodate {}
................................................................................
  5877   7382     method DistroMixIn {} {
  5878   7383       my define set scm none
  5879   7384     }
  5880   7385     method Sandbox {} {
  5881   7386       if {[my define exists sandbox]} {
  5882   7387         return [my define get sandbox]
  5883   7388       }
  5884         -    if {[my organ project] ni {::noop {}}} {
         7389  +    if {[my clay delegate project] ni {::noop {}}} {
  5885   7390         set sandbox [my <project> define get sandbox]
  5886   7391         if {$sandbox ne {}} {
  5887   7392           my define set sandbox $sandbox
  5888   7393           return $sandbox
  5889   7394         }
  5890   7395       }
  5891   7396       set sandbox [file normalize [file join $::CWD ..]]
................................................................................
  5921   7426           return
  5922   7427         }
  5923   7428       }
  5924   7429       my ScmUnpack
  5925   7430     }
  5926   7431   }
  5927   7432   oo::objdefine ::practcl::distribution {
  5928         -
  5929   7433     method Sandbox {object} {
  5930   7434       if {[$object define exists sandbox]} {
  5931   7435         return [$object define get sandbox]
  5932   7436       }
  5933         -    if {[$object organ project] ni {::noop {}}} {
         7437  +    if {[$object clay delegate project] ni {::noop {}}} {
  5934   7438         set sandbox [$object <project> define get sandbox]
  5935   7439         if {$sandbox ne {}} {
  5936   7440           $object define set sandbox $sandbox
  5937   7441           return $sandbox
  5938   7442         }
  5939   7443       }
  5940   7444       set pkg [$object define get name]
................................................................................
  5956   7460         $object define set srcdir $srcdir
  5957   7461       }
  5958   7462   
  5959   7463       set classprefix ::practcl::distribution.
  5960   7464       if {[file exists $srcdir]} {
  5961   7465         foreach class [::info commands ${classprefix}*] {
  5962   7466           if {[$class claim_path $srcdir]} {
  5963         -          $object mixin distribution $class
  5964         -          $object define set scm [string range $class [string length ::practcl::distribution.] end]
  5965         -          return [$object define get scm]
         7467  +          $object clay mixinmap distribution $class
         7468  +          set name [$class claim_option]
         7469  +          $object define set scm $name
         7470  +          return $name
  5966   7471           }
  5967   7472         }
  5968   7473       }
  5969   7474       foreach class [::info commands ${classprefix}*] {
  5970   7475         if {[$class claim_object $object]} {
  5971         -        $object mixin distribution $class
  5972         -        $object define set scm [string range $class [string length ::practcl::distribution.] end]
  5973         -        return [$object define get scm]
         7476  +        $object clay mixinmap distribution $class
         7477  +        set name [$class claim_option]
         7478  +        $object define set scm $name
         7479  +        return $name
  5974   7480         }
  5975   7481       }
  5976   7482       if {[$object define get scm] eq {} && [$object define exists file_url]} {
  5977   7483         set class ::practcl::distribution.snapshot
  5978         -      $object define set scm snapshot
  5979         -      $object mixin distribution $class
  5980         -      return [$object define get scm]
         7484  +      set name [$class claim_option]
         7485  +      $object define set scm $name
         7486  +      $object clay mixinmap distribution $class
         7487  +      return $name
  5981   7488       }
  5982   7489       error "Cannot determine source distribution method"
  5983   7490     }
  5984   7491   
  5985         -  method claim_path path {
         7492  +  method claim_option {} {
         7493  +    return Unknown
         7494  +  }
         7495  +
         7496  +  method claim_object object {
  5986   7497       return false
  5987   7498     }
  5988         -  method claim_object object {
         7499  +
         7500  +  method claim_path path {
  5989   7501       return false
  5990   7502     }
  5991   7503   }
  5992   7504   
  5993   7505   ###
  5994   7506   # END: class distro baseclass.tcl
  5995   7507   ###
  5996   7508   ###
  5997   7509   # START: class distro snapshot.tcl
  5998   7510   ###
  5999         -oo::class create ::practcl::distribution.snapshot {
         7511  +::clay::define ::practcl::distribution.snapshot {
  6000   7512     superclass ::practcl::distribution
  6001   7513     method ScmUnpack {} {
  6002   7514       set srcdir [my SrcDir]
  6003   7515       if {[file exists [file join $srcdir .download]]} {
  6004   7516         return 0
  6005   7517       }
  6006   7518       set dpath [::practcl::LOCAL define get download]
................................................................................
  6033   7545       set tag [my ScmTag]
  6034   7546       file mkdir $srcdir
  6035   7547       ::practcl::fossil $srcdir open $fosdb $tag
  6036   7548       return 1
  6037   7549     }
  6038   7550   }
  6039   7551   oo::objdefine ::practcl::distribution.snapshot {
         7552  +
         7553  +  method claim_object object {
         7554  +    return false
         7555  +  }
         7556  +
         7557  +  method claim_option {} {
         7558  +    return snapshot
         7559  +  }
         7560  +
  6040   7561     method claim_path path {
  6041   7562       if {[file exists [file join $path .download]]} {
  6042   7563         return true
  6043   7564       }
  6044   7565       return false
  6045   7566     }
  6046         -  method claim_object object {
  6047         -    return false
  6048         -  }
  6049   7567   }
  6050   7568   
  6051   7569   ###
  6052   7570   # END: class distro snapshot.tcl
  6053   7571   ###
  6054   7572   ###
  6055   7573   # START: class distro fossil.tcl
  6056   7574   ###
  6057         -oo::class create ::practcl::distribution.fossil {
         7575  +::clay::define ::practcl::distribution.fossil {
  6058   7576     superclass ::practcl::distribution
  6059   7577     method scm_info {} {
  6060   7578       set info [next]
  6061   7579       dict set info scm fossil
  6062   7580       foreach {field value} [::practcl::fossil_status [my define get srcdir]] {
  6063   7581         dict set info $field $value
  6064   7582       }
................................................................................
  6156   7674       set srcdir [my SrcDir]
  6157   7675       set tag [my ScmTag]
  6158   7676       ::practcl::fossil $srcdir update $tag
  6159   7677     }
  6160   7678   }
  6161   7679   oo::objdefine ::practcl::distribution.fossil {
  6162   7680   
  6163         -  # Check for markers in the source root
  6164         -  method claim_path path {
  6165         -    if {[file exists [file join $path .fslckout]]} {
  6166         -      return true
  6167         -    }
  6168         -    if {[file exists [file join $path _FOSSIL_]]} {
  6169         -      return true
  6170         -    }
  6171         -    return false
  6172         -  }
  6173         -
  6174   7681     # Check for markers in the metadata
  6175   7682     method claim_object obj {
  6176   7683       set path [$obj define get srcdir]
  6177   7684       if {[my claim_path $path]} {
  6178   7685         return true
  6179   7686       }
  6180   7687       if {[$obj define get fossil_url] ne {}} {
  6181   7688         return true
  6182   7689       }
  6183   7690       return false
  6184   7691     }
         7692  +
         7693  +  method claim_option {} {
         7694  +    return fossil
         7695  +  }
         7696  +
         7697  +  # Check for markers in the source root
         7698  +  method claim_path path {
         7699  +    if {[file exists [file join $path .fslckout]]} {
         7700  +      return true
         7701  +    }
         7702  +    if {[file exists [file join $path _FOSSIL_]]} {
         7703  +      return true
         7704  +    }
         7705  +    return false
         7706  +  }
  6185   7707   }
  6186   7708   
  6187   7709   ###
  6188   7710   # END: class distro fossil.tcl
  6189   7711   ###
  6190   7712   ###
  6191   7713   # START: class distro git.tcl
  6192   7714   ###
  6193         -oo::class create ::practcl::distribution.git {
         7715  +::clay::define ::practcl::distribution.git {
  6194   7716     superclass ::practcl::distribution
  6195   7717     method ScmTag {} {
  6196   7718       if {[my define exists scm_tag]} {
  6197   7719         return [my define get scm_tag]
  6198   7720       }
  6199   7721       if {[my define exists tag]} {
  6200   7722         set tag [my define get tag]
................................................................................
  6227   7749       set srcdir [my SrcDir]
  6228   7750       set tag [my ScmTag]
  6229   7751       ::practcl::doexec_in $srcdir git pull
  6230   7752       cd $CWD
  6231   7753     }
  6232   7754   }
  6233   7755   oo::objdefine ::practcl::distribution.git {
  6234         -  method claim_path path {
  6235         -   if {[file exists [file join $path .git]]} {
  6236         -      return true
  6237         -    }
  6238         -    return false
  6239         -  }
         7756  +
  6240   7757     method claim_object obj {
  6241   7758       set path [$obj define get srcdir]
  6242   7759       if {[my claim_path $path]} {
  6243   7760         return true
  6244   7761       }
  6245   7762       if {[$obj define get git_url] ne {}} {
  6246   7763         return true
  6247   7764       }
  6248   7765       return false
  6249   7766     }
         7767  +
         7768  +  method claim_option {} {
         7769  +    return git
         7770  +  }
         7771  +
         7772  +  method claim_path path {
         7773  +   if {[file exists [file join $path .git]]} {
         7774  +      return true
         7775  +    }
         7776  +    return false
         7777  +  }
  6250   7778   }
  6251   7779   
  6252   7780   ###
  6253   7781   # END: class distro git.tcl
  6254   7782   ###
  6255   7783   ###
  6256   7784   # START: class subproject baseclass.tcl
  6257   7785   ###
  6258         -oo::class create ::practcl::subproject {
         7786  +::clay::define ::practcl::subproject {
  6259   7787     superclass ::practcl::module
  6260   7788     method _MorphPatterns {} {
  6261   7789       return {{::practcl::[email protected]@} {::practcl::@[email protected]} {@[email protected]} {::practcl::subproject}}
  6262   7790     }
  6263   7791     method BuildDir {PWD} {
  6264   7792       return [my define get srcdir]
  6265   7793     }
................................................................................
  6334   7862       cd $::CWD
  6335   7863       ::practcl::distribution select [self]
  6336   7864       my Unpack
  6337   7865       ::practcl::toolset select [self]
  6338   7866       cd $::CWD
  6339   7867     }
  6340   7868   }
  6341         -oo::class create ::practcl::subproject.source {
         7869  +::clay::define ::practcl::subproject.source {
  6342   7870     superclass ::practcl::subproject ::practcl::library
  6343   7871     method env-bootstrap {} {
  6344   7872       set LibraryRoot [file join [my define get srcdir] [my define get module_root modules]]
  6345   7873       if {[file exists $LibraryRoot] && $LibraryRoot ni $::auto_path} {
  6346   7874         set ::auto_path [linsert $::auto_path 0 $LibraryRoot]
  6347   7875       }
  6348   7876     }
................................................................................
  6350   7878       set path [my define get srcdir]
  6351   7879       return [file exists $path]
  6352   7880     }
  6353   7881     method linktype {} {
  6354   7882       return {subordinate package source}
  6355   7883     }
  6356   7884   }
  6357         -oo::class create ::practcl::subproject.teapot {
         7885  +::clay::define ::practcl::subproject.teapot {
  6358   7886     superclass ::practcl::subproject
  6359   7887     method env-bootstrap {} {
  6360   7888       set pkg [my define get pkg_name [my define get name]]
  6361   7889       package require $pkg
  6362   7890     }
  6363   7891     method env-install {} {
  6364   7892       set pkg [my define get pkg_name [my define get name]]
................................................................................
  6380   7908       set download [my <project> define get download]
  6381   7909       my unpack
  6382   7910       set prefix [string trimleft [my <project> define get prefix] /]
  6383   7911       ::practcl::tcllib_require zipfile::decode
  6384   7912       ::zipfile::decode::unzipfile [file join $download $pkg.zip] [file join $DEST $prefix lib $pkg]
  6385   7913     }
  6386   7914   }
  6387         -oo::class create ::practcl::subproject.kettle {
         7915  +::clay::define ::practcl::subproject.kettle {
  6388   7916     superclass ::practcl::subproject
  6389   7917     method kettle {path args} {
  6390   7918       my variable kettle
  6391   7919       if {![info exists kettle]} {
  6392   7920         ::practcl::LOCAL tool kettle env-load
  6393   7921         set kettle [file join [::practcl::LOCAL tool kettle define get srcdir] kettle]
  6394   7922       }
................................................................................
  6395   7923       set srcdir [my SourceRoot]
  6396   7924       ::practcl::dotclexec $kettle -f [file join $srcdir build.tcl] {*}$args
  6397   7925     }
  6398   7926     method install DEST {
  6399   7927       my kettle reinstall --prefix $DEST
  6400   7928     }
  6401   7929   }
  6402         -oo::class create ::practcl::subproject.critcl {
         7930  +::clay::define ::practcl::subproject.critcl {
  6403   7931     superclass ::practcl::subproject
  6404   7932     method install DEST {
  6405   7933       my critcl -pkg [my define get name]
  6406   7934       set srcdir [my SourceRoot]
  6407   7935       ::practcl::copyDir [file join $srcdir [my define get name]] [file join $DEST lib [my define get name]]
  6408   7936     }
  6409   7937   }
  6410         -oo::class create ::practcl::subproject.sak {
         7938  +::clay::define ::practcl::subproject.sak {
  6411   7939     superclass ::practcl::subproject
  6412   7940     method env-bootstrap {} {
  6413   7941       set LibraryRoot [file join [my define get srcdir] [my define get module_root modules]]
  6414   7942       if {[file exists $LibraryRoot] && $LibraryRoot ni $::auto_path} {
  6415   7943         set ::auto_path [linsert $::auto_path 0 $LibraryRoot]
  6416   7944       }
  6417   7945     }
................................................................................
  6443   7971       set srcdir [my define get srcdir]
  6444   7972       ::practcl::dotclexec [file join $srcdir installer.tcl] \
  6445   7973         -pkg-path [file join $DEST $prefix lib $pkg]  \
  6446   7974         -no-examples -no-html -no-nroff \
  6447   7975         -no-wait -no-gui -no-apps
  6448   7976     }
  6449   7977     method install-module {DEST args} {
         7978  +    set srcdir [my define get srcdir]
         7979  +    if {[llength $args]==1 && [lindex $args 0] in {* all}} {
         7980  +      set pkg [my define get pkg_name [my define get name]]
         7981  +      ::practcl::dotclexec [file join $srcdir installer.tcl] \
         7982  +        -pkg-path [file join $DEST $pkg]  \
         7983  +        -no-examples -no-html -no-nroff \
         7984  +        -no-wait -no-gui -no-apps
         7985  +    } else {
         7986  +      foreach module $args {
         7987  +        ::practcl::installModule [file join $srcdir modules $module] [file join $DEST $module]
         7988  +      }
         7989  +    }
         7990  +  }
         7991  +}
         7992  +::clay::define ::practcl::subproject.practcl {
         7993  +  superclass ::practcl::subproject
         7994  +  method env-bootstrap {} {
         7995  +    set LibraryRoot [file join [my define get srcdir] [my define get module_root modules]]
         7996  +    if {[file exists $LibraryRoot] && $LibraryRoot ni $::auto_path} {
         7997  +      set ::auto_path [linsert $::auto_path 0 $LibraryRoot]
         7998  +    }
         7999  +  }
         8000  +  method env-install {} {
         8001  +    ###
         8002  +    # Handle teapot installs
         8003  +    ###
  6450   8004       set pkg [my define get pkg_name [my define get name]]
         8005  +    my unpack
  6451   8006       set prefix [my <project> define get prefix [file normalize [file join ~ tcl]]]
  6452         -    set pkgpath [file join $prefix lib $pkg]
  6453         -    foreach module $args {
  6454         -      ::practcl::installDir [file join $pkgpath $module] [file join $DEST $module]
  6455         -    }
         8007  +    set srcdir [my define get srcdir]
         8008  +    ::practcl::dotclexec [file join $srcdir make.tcl] install [file join $prefix lib $pkg]
         8009  +  }
         8010  +  method install DEST {
         8011  +    ###
         8012  +    # Handle teapot installs
         8013  +    ###
         8014  +    set pkg [my define get pkg_name [my define get name]]
         8015  +    my unpack
         8016  +    set prefix [string trimleft [my <project> define get prefix] /]
         8017  +    set srcdir [my define get srcdir]
         8018  +    puts [list INSTALLING  [my define get name] to [file join $DEST $prefix lib $pkg]]
         8019  +    ::practcl::dotclexec [file join $srcdir make.tcl] install [file join $DEST $prefix lib $pkg]
         8020  +  }
         8021  +  method install-module {DEST args} {
         8022  +    set pkg [my define get pkg_name [my define get name]]
         8023  +    set srcdir [my define get srcdir]
         8024  +    ::practcl::dotclexec [file join $srcdir make.tcl] install-module $DEST {*}$args
  6456   8025     }
  6457   8026   }
  6458   8027   
  6459   8028   ###
  6460   8029   # END: class subproject baseclass.tcl
  6461   8030   ###
  6462   8031   ###
  6463   8032   # START: class subproject binary.tcl
  6464   8033   ###
  6465         -oo::class create ::practcl::subproject.binary {
         8034  +::clay::define ::practcl::subproject.binary {
  6466   8035     superclass ::practcl::subproject
  6467   8036     method clean {} {
  6468   8037       set builddir [file normalize [my define get builddir]]
  6469   8038       if {![file exists $builddir]} return
  6470   8039       if {[file exists [file join $builddir make.tcl]]} {
  6471   8040         ::practcl::domake.tcl $builddir clean
  6472   8041       } else {
................................................................................
  6484   8053       set prefix [my <project> define get prefix [file normalize [file join ~ tcl]]]
  6485   8054       set srcdir [my define get srcdir]
  6486   8055       lappend options --prefix $prefix --exec-prefix $prefix
  6487   8056       my define set config_opts $options
  6488   8057       my go
  6489   8058       my clean
  6490   8059       my compile
  6491         -    my make-install {}
         8060  +    my make install {}
  6492   8061     }
  6493   8062     method project-compile-products {} {}
  6494   8063     method ComputeInstall {} {
  6495   8064       if {[my define exists install]} {
  6496   8065         switch [my define get install] {
  6497   8066           static {
  6498   8067             my define set static 1
................................................................................
  6593   8162       ###
  6594   8163       set srcdir [my define get srcdir]
  6595   8164       if {[my define get static 1]} {
  6596   8165         puts "BUILDING Static $name $srcdir"
  6597   8166       } else {
  6598   8167         puts "BUILDING Dynamic $name $srcdir"
  6599   8168       }
  6600         -    my make-compile
         8169  +    my make compile
  6601   8170       cd $PWD
  6602   8171     }
  6603   8172     method Configure {} {
  6604   8173       cd $::CWD
  6605   8174       my unpack
  6606   8175       ::practcl::toolset select [self]
  6607   8176       set srcdir [file normalize [my define get srcdir]]
  6608   8177       set builddir [file normalize [my define get builddir]]
  6609   8178       file mkdir $builddir
  6610         -    my make-autodetect
         8179  +    my make autodetect
  6611   8180     }
  6612   8181     method install DEST {
  6613   8182       set PWD [pwd]
  6614   8183       set PREFIX  [my <project> define get prefix]
  6615   8184       ###
  6616   8185       # Handle teapot installs
  6617   8186       ###
................................................................................
  6625   8194             set dest  [file join $DEST [string trimleft $PREFIX /] lib [file tail $teapath]]
  6626   8195             ::practcl::copyDir $teapath $dest
  6627   8196             return
  6628   8197           }
  6629   8198         }
  6630   8199       }
  6631   8200       my compile
  6632         -    my make-install $DEST
         8201  +    my make install $DEST
  6633   8202       cd $PWD
  6634   8203     }
  6635   8204   }
  6636         -oo::class create ::practcl::subproject.tea {
         8205  +::clay::define ::practcl::subproject.tea {
  6637   8206     superclass ::practcl::subproject.binary
  6638   8207   }
  6639         -oo::class create ::practcl::subproject.library {
         8208  +::clay::define ::practcl::subproject.library {
  6640   8209     superclass ::practcl::subproject.binary ::practcl::library
  6641   8210     method install DEST {
  6642   8211       my compile
  6643   8212     }
  6644   8213   }
  6645         -oo::class create ::practcl::subproject.external {
         8214  +::clay::define ::practcl::subproject.external {
  6646   8215     superclass ::practcl::subproject.binary
  6647   8216     method install DEST {
  6648   8217       my compile
  6649   8218     }
  6650   8219   }
  6651   8220   
  6652   8221   ###
  6653   8222   # END: class subproject binary.tcl
  6654   8223   ###
  6655   8224   ###
  6656   8225   # START: class subproject core.tcl
  6657   8226   ###
  6658         -oo::class create ::practcl::subproject.core {
         8227  +::clay::define ::practcl::subproject.core {
  6659   8228     superclass ::practcl::subproject.binary
  6660   8229     method env-bootstrap {} {}
  6661   8230     method env-present {} {
  6662   8231       set PREFIX [my <project> define get prefix]
  6663   8232       set name [my define get name]
  6664   8233       set fname [file join $PREFIX lib ${name}Config.sh]
  6665   8234       return [file exists $fname]
................................................................................
  6670   8239   
  6671   8240       set prefix [my <project> define get prefix [file normalize [file join ~ tcl]]]
  6672   8241       lappend options --prefix $prefix --exec-prefix $prefix
  6673   8242       my define set config_opts $options
  6674   8243       puts [list [self] OS [dict get $os TEACUP_OS] options $options]
  6675   8244       my go
  6676   8245       my compile
  6677         -    my make-install {}
         8246  +    my make install {}
  6678   8247     }
  6679   8248     method go {} {
  6680   8249       my define set core_binary 1
  6681   8250       next
  6682   8251     }
  6683   8252     method linktype {} {
  6684   8253       return {subordinate core.library}